excel vbaでレート取得についてです。

excelで仮想通貨のレート取得をexcel VBAでやっていますが、
windows10 office2016(64bit)ではレートを取得できますが、
windowsXP excel2007(32bit)ではエラーが出てしまいます(こちらでやりたい)
エラー内容
・ With CreateObject("WinHttp.WinHttpRequest.5.1")
実行時エラー’-2146893018(80090326)'
予期されない、または形式が間違ったメッセージを受信しました。

・ With CreateObject("MSXML2.XMLHTTP")
実行時エラー’-2146697208(800c0008)’
The download of the specified resource has failed.

上記2種類で試してみました。
ネットで調べてみましたが、サーバーの証明エラーでソフトを更新しても駄目でした。

http://xl.hisholy.net/excelvba/bitcoin-1/　様を参考に作成しました。

**************************************************
Application.ScreenUpdating = False '画面描画を無効

Dim url As String 'レートを取得するためのURL
Dim res As String '取得するレスポンステキスト
Dim tbl As ListObject 'レートを記載するテーブルオブジェクト
Dim Rmax As Long 'テーブルの行数
Dim R As Long 'テーブルを繰り返すループ用変数

'シートに作成済みのテーブルをオブジェクト変数にセット
Set tbl = ThisWorkbook.Worksheets("bitbank").ListObjects("bitbank")

Rmax = tbl.ListRows.Count 'テーブルの最終行数を取得

For R = 1 To Rmax 'テーブルの1行目から最終行までループ

'単位に記載された仮想通貨のレートを取得するAPIのURLを設定
'仮想通貨単位を小文字に変換して _jpy を結合　例）BTC -> btc_jpy
url = "https://public.bitbank.cc/" _
& LCase(tbl.ListColumns("単位").DataBodyRange(R)) _
& "_jpy/ticker"

With CreateObject("WinHttp.WinHttpRequest.5.1") 'XMLHTTPオブジェクトを生成

.Open "GET", url, False '非同期モードで通信を開始
.send 'リクエストを送信
If .Status <> 200 Then Exit Sub 'リクエスト失敗で終了

res = "[" & .responsetext & "]" 'JSON文字列のレスポンス


'Javascriptオブジェクトを生成
With CreateObject("ScriptControl"): .Language = "JScript"

'JSON文字列をJSONオブジェクトに変換するJavascript関数
.Addcode "function getVal(num,key,res){" _
& "var json=eval('('+res+')');" _
& "var json2=json[num-1][""data""];" _
& "return json2[key];}"

'JSONオブジェクトからrateキーの値を取得
tbl.ListColumns("レート").DataBodyRange(R) = _
.CodeObject.getVal(1, "last", res)

End With

End With

Next 'ループここまで

Application.ScreenUpdating = True '画面描画を有効

*************************************************

何卒宜しくお願い致します。

No.6 ベストアンサー 回答者： WindFaller 回答日時： 2018/03/15 14:31

こんにちは。

DLL-Files.com で、Urlmon.dll (https://www.dll-files.com/)を検索・入手してみたらいかがでしょうか？
ここのサイトなら、セキュアブレインのPhishWallで調べる限りは安全と出てきます。
前述の細部のリビジョンまで同じバージョンは見つかりませんが、Ver.6.0.290　の近いバージョンがヒットします。

本来ですと、Microsoft にあってよいはすですが、あまりに古すぎるようです。

入れる場所、Windows\System32\
コマンド・プロンプトから
＞regsvr32 urlmon.dll

とすると、「成功しました」のレスポンスが返るはずです。

なお、これは、あえてDOM(objHTTP)で行う方法であり、objct IE以外にもインターネットのAPIからデータを取る方法はあると思います。

この回答へのお礼

期間が空いて申し訳ございません。
ご指示通り、やってみたけど
うまくいきませんでした。

お礼日時：2018/04/05 18:56

No.5 回答者： WindFaller 回答日時： 2018/03/14 16:54

何度もすみません。

試行錯誤で、ちゃんとした回答まですぐにいかないのでご不便をおかけします。

私の考え方が間違っていたようです。
昨日は、以下のサイトを見つけることができませんでした。

https://support.microsoft.com/ja-jp/help/906379/ …

•URL にバインドするには、 IMoniker::BindToStorage関数を使用します。
•HTTP POST データを提供するのにには、 IStreamインターフェイスを使用します。＊
•サーバー証明書に問題があります。＊
•既存の HTTP 接続ではなく、新規の HTTP 接続が使用されます。

ただ、そのサイトに書かれている　URLリンク先は、生きていません。

Urlmon.dll　6.0.2900.2771
これを手に入れる必要があるということです。

Windows10 にもあるのですが、それを入れてもうまくいかないような気がします。
MS以外で安全なサイトで手に入れる方法があると思いますが、今、それがどこだったか見失っています。ふつう、同じOSのバージョンなら、他のPCからコピーをとって入れるのは簡単ですが、そうでもなさそうです。

この回答へのお礼

いろいろ調べて頂き有難うございます。

お時間のある時にでも何か情報があれば幸いです。

お礼日時：2018/03/14 18:08

No.4 回答者： WindFaller 回答日時： 2018/03/13 20:03

追伸です。

やはりエラーが出た場合の対処です。

>Function CreateHttpRequest() As Object
>　Dim progIDs As Variant
>　Dim obj As Object

この特殊な使い方を説明させていただきます。
　　　i = 0 の [0]　の部分を、途中の progID 番号から始めることができます。
　　　たとえば、i = 8 からやってみたらどうだろうか、と考えています。

　For i = 0 To UBound(progIDs)
　If progIDs(i) <> "" Then
　Set obj = CreateObject(Trim(progIDs(i)))

No.3 回答者： WindFaller 回答日時： 2018/03/13 18:01

こんにちは。

>実行時エラー’-2146697208(800c0008)’
#2のアップの後で、考えてみましたが、どうやら別の問題だったようです。
「オートメーションエラーです」
https://docs.microsoft.com/en-us/previous-versio …

私は対処の仕方が分かりません。検索してみましたが、明確な解決方法は見当たりませんでした。

ただ、オートメーションエラーなら、#2のコードも、元の質問のコードも無理っぽいですから、事前に分かるように書かなくてはなりませんね。それは、ひとまず後にして、確認してください。

1.ファイルの確認
"MSXML2.XMLHTTP"
"WinHttp.WinHttpRequest.5.1"
これらがインストールされて、Register で登録されているか、疑問を持ちました。

まず、ファイルはありますか？
MSXML2.XMLHTTP
　　C:\Windows\system32\msxml3.dll
WinHttp.WinHttpRequest.5.1
　　C:\Windows\system32\winhttpcom.dll
次に、VBEditor のツール－参照設定で、
--------------------------------------
Microsoft WinHTTP Services, version 5.1
Microsoft XML, v3.0
--------------------------------------
は表示されているでしょうか？
別にチェックを入れる必要はありません。[添付画像]
(ない場合に、手に入れる方法はありますが、セキュリティが効いていないから、かなりリスクが大きいです。）

2．コードの書き換え
ダメ元ですが、ユーザー定義関数を書き加え、#2のコードまたは、元の質問にあったコードのオブジェクトを生成する部分を入れ替えてください。
もともと、実行時エラーですから、このコードは期待値は低いです。

もし、これでダメなら、もうIEオブジェクトで行うか、思い切って、DLLを再度インストールするかだと思います。OS をXPで使おうとするのには無理があるのかもしれません。


'//
Sub GetRage2()
Dim objHTTP As Object　　'＊変数の宣言を一つ上部に書き加える
'略

　For i = 0 To UBound(AryNames)
　　 url = urlBase & AryNames(i) & "/ticker"
　　 ''With CreateObject("MSXML2.XMLHTTP"　''ここを以下の2行に書き換えます。
　　Set objHTTP = CreateHttpRequest()　　'*
　　With objHTTP　　'*
'略

EndOfLoop:
　　　End With
　　　Set objHTTP = Nothing　　'*書き加える
Next
End Sub

'//標準モジュール
Function CreateHttpRequest() As Object
　Dim progIDs As Variant
　Dim obj As Object
　Dim i As Long
　Set obj = Nothing
　progIDs = Array("", _
　　　　　 "WinHttp.WinHttpRequest.5", _
　　　　　 "WinHttp.WinHttpRequest", _
　　　　　 "Msxml2.ServerXMLHTTP.6.0", _
　　　　　 "Msxml2.ServerXMLHTTP.5.0", _
　　　　　 "Msxml2.ServerXMLHTTP.4.0", _
　　　　　 "Msxml2.ServerXMLHTTP.3.0", _
　　　　　 "Msxml2.ServerXMLHTTP", _
　　　　　 "Microsoft.ServerXMLHTTP", _
　　　　　 "Msxml2.XMLHTTP.6.0", _
　　　　　 "Msxml2.XMLHTTP.5.0", _
　　　　　 "Msxml2.XMLHTTP.4.0", _
　　　　　 "Msxml2.XMLHTTP.3.0", _
　　　　　 "Msxml2.XMLHTTP", _
　　　　　 "Microsoft.XMLHTTP")
　On Error Resume Next
　For i = 0 To UBound(progIDs)
　If progIDs(i) <> "" Then
　Set obj = CreateObject(Trim(progIDs(i)))
　End If
　If Not obj Is Nothing Then Exit For
　Next
　On Error GoTo 0
　Set CreateHttpRequest = obj
End Function

この回答へのお礼

いつも有難うございます。

”まず、ファイルはありますか？
MSXML2.XMLHTTP
　　C:\Windows\system32\msxml3.dll　　　＊有ります
WinHttp.WinHttpRequest.5.1
　　C:\Windows\system32\winhttpcom.dll　＊ありません
次に、VBEditor のツール－参照設定で、
--------------------------------------
Microsoft WinHTTP Services, version 5.1　　＊表示されています
Microsoft XML, v3.0　　　　　　　　　　　　＊表示されています。
--------------------------------------
は表示されているでしょうか？”

C:\Windows\system32\にwinhttp.dllがあります。

お礼日時：2018/03/14 09:38

No.2 回答者： WindFaller 回答日時： 2018/03/13 00:38

こんばんは。

bitbank の方も、APIだったのですね。APIであるかどうか、分かりませんでした。
それに、今回、直接、スクリプトを動かすならともかく、VBAで既に動かしていますから、最後まで任せても大丈夫のような気がします。(気に入らないとお思いでしたら、少なくともカテゴリを変えた方がよいです）

エラーの原因は、もともとの名称の食い違いではないかと思いますが、元のマクロは、エラーを出すとマクロのループを離脱してしまうので、エラーしか分からないことになります。呼出方法を、前のものに合わせるから問題であって、#1で書いたような新規に建てるなら問題はありません。以下をみてください。　新規のシートに書き出すように出来ています。(使用環境：Excel 2007, Windows 10-32bit)

'//新規のシートで試してみてください。
Sub getRate2()
　Dim url As String
　Dim urlBase As String: urlBase = "https://public.bitbank.cc/"
　Dim res As String
　Dim i As Long
　Dim AryNames
　Dim aPart As Variant
　Dim buf As String
　AryNames = Array("btc_jpy", "xrp_jpy", "mona_jpy", "bcc_jpy")
　'' "ltc_btc", "eth_btc","mona_btc","bcc_btc　'日本以外は取りやめ
　For i = 0 To UBound(AryNames)
　　 url = urlBase & AryNames(i) & "/ticker"
　　 With CreateObject("MSXML2.XMLHTTP")
　　　 .Open "GET", url, False
　　　 .send
　　　 If .Status <> 200 Then GoTo EndOfLoop　　'エラーを出したら、ループの最後に行く
　　　　res = .responseText
　　　　buf = Mid(res, InStr(1, res, "{""sell", vbTextCompare) + 1)
　　　　buf = Replace(buf, """", "")
　　　　buf = Replace(buf, "sell:", "")
　　　　buf = Replace(buf, "buy:", "")
　　　　aPart = Split(buf, ",")
　　　　Cells(1, 1).Resize(, 3).Value = Array("取引所", "売値", "買値")
　　　　Cells(i + 2, 1).Value = AryNames(i)
　　　　Cells(i + 2, 2).Value = Replace(aPart(0), """", "")
　　　　Cells(i + 2, 3).Value = Replace(aPart(1), """", "")
EndOfLoop:
　　　 End With
　Next
　End Sub

この回答へのお礼

有難うございます。

試してみましたが、

実行時エラー’-2146697208(800c0008)’
オートメーションエラーです

がでてしまいました。

お礼日時：2018/03/13 10:40

No.1 回答者： WindFaller 回答日時： 2018/03/09 12:17

こんにちは。

最初に、coincheck.comの場合は、api と指定していますから、Excel 2016だったら、
既存のWebservice 関数が使えますから、マクロは必要ありません。
=WEBSERVICE("https://coincheck.com/api/rate/" & レート[@単位] & "_jpy/")
　レート[@単位　の部分に、btc などが入ります。

問題は、2007 ですが、Webservice関数そのものよりも、
"https://public.bitbank.cc/"

この場所は、会員に対して公開されているものではないでしょうか。ログインして見るものなのか、こちらではエラーが発生します。
マクロのエラー自体はこちらでは不明というか、私は、DOMの動的な値を取得するノウハウを知りませんし、元のコードをみて、手間を省いて、一気に取ればと思うぐらいです。
その代わりと言ってはなんですが、これは、ビットバンクの表に出ているレート表を一括して取得する方法です。

ログイン内部での取得方法は別にありますが、ログインからするのではなく、画面からデータを取得する方法ですので、今の所は割愛しておきます。
コメントアウトしている　ShDocVw は、参照設定した場合の書き方です。
'//


Sub GetBitBankData()
　Dim objIE As Object ' ShDocVw.InternetExplorer
　Dim strURL As String
　Dim i As Long, j As Long
　Dim resTbl As Object
　Set objIE = CreateObject("InternetExplorer.Application")
　'Set objIE = New ShDocVw.InternetExplorer
　strURL = "https://bitbank.cc/"
　objIE.Navigate2 strURL
　Do While objIE.Busy Or objIE.readyState <> 4: DoEvents: Loop
　With objIE
　Set resTbl = .document.getElementsByClassName("table-responsive")
　 For i = 0 To resTbl(0).Rows.Length - 1
　For j = 0 To resTbl(0).Rows(i).Cells.Length - 1
　　Cells(i + 1, j + 1).Value = resTbl(0).Rows(i).Cells(j).innerText
　Next j
　Next i
　End With
End Sub

この回答へのお礼

ご指導有難うございます。

”問題は、2007 ですが、Webservice関数そのものよりも、
"https://public.bitbank.cc/"
この場所は、会員に対して公開されているものではないでしょうか。”

このサイトはログインしていなくてもアクセス可能です。
ちなみにexcel2007のハイパーリンクを使用するとブラウザで
レートが返信されます

お礼日時：2018/03/12 09:33