エクセルVBAで「Web未接続」を取得したい。

質問

エクセルVBAで以下のようにWebAPIの助けを借りています。
しかしこれはたぶんネットに接続してなければ使えないのだと思います。
質問は、このマクロを作動させたとき、ネットに接続してなければ「ネットに未接続です」という警告を出したいのです。
しかし、ネットに接続してないことをどう取得すればよいのかわかりません。ご教示ください。

Sub ボタン1_Click()
Dim objXMLHttp As Object, zipArr
Dim yubinNo As Long
Dim line As String
Dim splitLine() As String
Dim i As Long
i = 2 '行番号

Do While Cells(i, 1).Value <> "" '入力値からハイフンの削除
yubinNo = Replace(Worksheets("Sheet1").Cells(i, 1).Value, "-", "")

Set objXMLHttp = CreateObject("MSXML2.XMLHTTP")
objXMLHttp.Open "GET", "http://zip.cgis.biz/csv/zip.php?zn=" & yubinNo, False
objXMLHttp.Send

line = Replace(objXMLHttp.responseText, vbLf, ",") '改行削除
line = Replace(line, """", "") 'クォート削除
line = Replace(line, "none", "") 'noneの文字列削除(情報がない場合、noneのため)

splitLine = Split(line, ",") 'CSVを配列へ格納

Worksheets("Sheet1").Cells(i, 2).Value = splitLine(13) & splitLine(14) & splitLine(15) & splitLine(16)
Worksheets("Sheet1").Cells(i, 3).Value = splitLine(9) & splitLine(10) & splitLine(11) & splitLine(12)

i = i + 1
Loop
End Sub

回答No.7

kkkkkm · ベストアンサー

> 接続できてもサービス一時停止等かどうかを取得する方法はありますか？

objXMLHttp.Open "GET", "http://zip.cgis.biz/csv/zip.php?zn=" & yubinNo, False
objXMLHttp.Send

を実行してエラーもしくは通常と違う情報が返ってくると停止中と思ったのですが、実際停止してないとテストできないので確信はありません。
ただ、No.1でも記載したようにオンラインで一度成功すると、同じ番号だとそのままオフラインにしてもブックを開き直さないとエラーにならないという理由が分からないのでエラーは別にして、何かしら違う情報が返ってくると考えていいのではないでしょうか。
「サービスは停止中です」とか、検索した番号が返ってきた情報には入ってないとか。

> 存在しない番号の場合の対応はどうすればよいのでしょうか？

ちょっと試したところ、番号が存在するかしないかによって.responseTextの情報量(住所情報の有無)に差がありましたので

UBound(splitLine)

の結果で振分ができると思います。

お礼

ありがとうございます。
すみません、週明けから寝込んでしまいお礼が遅くなりました。とても勉強になりました。

回答No.11

kkkkkm

No.10の訂正です。

Int((9999900 - 1111112) * Rnd + 1111111)
と
Int((9999999 - 1111112) * Rnd + 1111111)

なんかおかしい。なぜこんなことになったのか(夜明けで寝ぼけてた)

Int((9999999 - 1111110) * Rnd + 1111111)

にしてください。

お礼

ありがとうございます。

回答No.10

kkkkkm

夜が明けたのでテストしてみました。以下でいけるのではないでしょうか。

Sub ボタン1_Click()
Dim objXMLHttp As Object, zipArr
Dim yubinNo As Long
Dim line As String
Dim splitLine() As String
Dim i As Long
Static mDummy As Long
Dim Temp As Long

Randomize
Temp = Int((9999900 - 1111112) * Rnd + 1111111)
'万が一の為もし前回と同じ乱数が出た場合再度乱数発生
If mDummy = Temp Then
mDummy = Int((9999999 - 1111112) * Rnd + 1111111)
Else
mDummy = Temp
End If

Set objXMLHttp = CreateObject("MSXML2.XMLHTTP")

On Error GoTo ErrorExit
objXMLHttp.Open "GET", "http://zip.cgis.biz/csv/zip.php?zn=" & mDummy, False
objXMLHttp.Send
On Error GoTo 0
'停止してると検索対象の番号がresponseTextに入っていないと思うので
If InStr(objXMLHttp.responseText, mDummy) < 1 Then
MsgBox "郵便番号検索システムが停止している可能性があります", vbInformation
Exit Sub
End If

i = 2 '行番号

Do While Cells(i, 1).Value <> "" '入力値からハイフンの削除

中略

Loop

Set objXMLHttp = Nothing
Exit Sub

ErrorExit:
If Call_CheckPing("www.google.co.jp") = False Then ' 回答No.3のpingを利用
MsgBox "インターネット接続がありません" & vbCrLf & vbCrLf & _
"通知領域(タスクトレイ)のネットワークアイコンで確認してください", vbInformation
Else
MsgBox "郵便番号検索サーバから応答がありません", vbInformation
End If

Set objXMLHttp = Nothing
End Sub

お礼

何度もありがとうございます。

回答No.9

kkkkkm

オンラインで一度成功すると、同じ番号だとそのままオフラインにしてもブックを開き直さないとエラーにならない

毎回7桁の乱数で検索したら、同じ番号での検索にならないので、上記の問題は解決して、No.1の方法でオフラインやサービス停止を認識出来そうです

テストは夜が明けてからやってみます

お礼

ありがとうございます。

回答No.8

kkkkkm

あと、余計なお世話だと思いますが

ループ中にオフラインになったりサーバがおかしくなった場合は、番号が変わるのでエラーになると思います。

On Error GoTo ErrorExit
objXMLHttpTest.Open "GET", "http://zip.cgis.biz/csv/zip.php?zn=" & yubinNo, False
objXMLHttpTest.Send
On Error GoTo 0

で中断して(中断する場合は、最初のオンラインかどうかのチェックはいらなくなります)

ErrorExit:
Dim P1 As Boolean

P1 = Call_CheckPing("www.google.co.jp") 'Pingで調査

P1の結果でオフラインになった為かどうかメッセージを出すか

On Error Resume Next
でエラーを無視して続けるかの処置が必要だと思います。

お礼

ご丁寧にありがとうございました。

回答No.6

HohoPapa

泥臭く、
Yahooと日本銀行の双方のサイトに接続できな場合に
インターネットの異常と判断するようにしてしてみました。

また、郵便番号がヒットしない場合の対応を組み込んでみました。

Sub sample()
　　Dim objXMLHttp As Object, zipArr
　　Dim yubinNo As Long
　　Dim line As String
　　Dim splitLine() As String
　　Dim i As Long
　　i = 2 '行番号

　　 If ((isnetready("https://www.yahoo.jp/") = False) And _
　　　(isnetready("https://www.boj.or.jp/") = False)) Then
　　　MsgBox "インターネット環境が異常です"
　　　Exit Sub
　　ElseIf isnetready("http://zip.cgis.biz/") = False Then
　　　MsgBox "郵便番号検索サイトに接続できません"
　　　Exit Sub
　　End If

　　Do While Cells(i, 1).Value <> ""　　'入力値からハイフンの削除
　　　　yubinNo = Replace(Worksheets("Sheet1").Cells(i, 1).Value, "-", "")

　　　　Set objXMLHttp = CreateObject("MSXML2.XMLHTTP")
　　　　objXMLHttp.Open "GET", "http://zip.cgis.biz/csv/zip.php?zn=" & yubinNo, False
　　　　objXMLHttp.send

　　　　line = Replace(objXMLHttp.responseText, vbLf, ",")　　'改行削除
　　　　line = Replace(line, """", "")　　'クォート削除
　　　　line = Replace(line, "none", "")　　'noneの文字列削除(情報がない場合、noneのため)

　　　　splitLine = Split(line, ",")　　'CSVを配列へ格納

　　　　Debug.Print line

　　　　If UBound(splitLine) > 16 Then
　　　　　　Worksheets("Sheet1").Cells(i, 2).Value = splitLine(13) & splitLine(14) & splitLine(15) & splitLine(16)
　　　　　　Worksheets("Sheet1").Cells(i, 3).Value = splitLine(9) & splitLine(10) & splitLine(11) & splitLine(12)
　　　　Else
　　　　　　 MsgBox "郵便番号がヒットしない:" & yubinNo
　　　　End If
　　　　i = i + 1
　　Loop

End Sub

Function isnetready(tgHostName As String) As Boolean
　　Dim objXML As New MSHTML.HTMLDocument
　　Dim htmlDoc As New MSHTML.HTMLDocument
　　Dim objITEM As Object
　　Dim starttime As Date
　　Dim CheckText As String
　　Set htmlDoc = objXML.createDocumentFromUrl(tgHostName, vbNullString)

　　starttime = Now()
　　Do Until htmlDoc.readyState = "complete"
　　　　DoEvents
　　　　If Now() > DateAdd("S", 10, starttime) Then
　　　　　　Exit Do
　　　　End If
　　Loop
　　DoEvents

　　CheckText = ""
　　For Each objITEM In htmlDoc.getElementsByTagName("title")
　　　　CheckText = CheckText & objITEM.innerText
　　Next

　　Set objITEM = Nothing
　　Set htmlDoc = Nothing
　　Set objXML = Nothing

　　If CheckText = "" Then
　　　isnetready = False
　　Else
　　　isnetready = True
　　End If

End Function

お礼

ありがとうございます。
すみません、週明けから寝込んでしまいお礼が遅くなりました。とても勉強になりました。

回答No.5

kkkkkm

No.1、No.3の補足です。

思うのですが、ネット接続が出来ていて、Pingなどでサーバの稼働が確認できたとしても

objXMLHttp.Open "GET", "http://zip.cgis.biz/csv/zip.php?zn=" & yubinNo, False

が成功しなければ意味がないのではないでしょうか。サーバアクセス確認だけではサービス一時停止とか分からないと思います。

また、現状では製作途中なので手を付けていないのだと思いますが、間違った郵便番号を検索すると最後の方でエラーになると思いますので対処が必要な気もします

お礼

＞サーバアクセス確認だけではサービス一時停止とか分からないと思います。

確かにその通りですね。ネット接続が出来てないのは先ほどので取得できますが、接続できてもサービス一時停止等かどうかを取得する方法はありますか？
また、入力された郵便番号が桁誤りや数値でない場合などは入力時にチェックする予定ですが、存在しない番号の場合の対応はどうすればよいのでしょうか？

回答No.4

HohoPapa

判定タイミングを最初にすべきでしたので、コードを修正します。

なお、
>ネットに接続してなければ
これをどう解釈すればいいののかにより、コードが異なってきましょう。

つまり、
"http://zip.cgis.biz/"
このサイトが停止している場合とインターネットそのものの接続ができない場合を
区別する必要があるのか？
ということです。

先に示したコードは、これを区別せず、
単に、
"http://zip.cgis.biz/"
に接続できるか？　をチェックしているコードです。

Sub ボタン1_Click()
　　Dim objXMLHttp As Object, zipArr
　　Dim yubinNo As Long
　　Dim line As String
　　Dim splitLine() As String
　　Dim i As Long
　　i = 2 '行番号

　　If isnetready = False Then
　　　　MsgBox "ネットに未接続です"
　　　　Exit Sub
　　End If

　　Do While Cells(i, 1).Value <> ""　　'入力値からハイフンの削除
　　　　yubinNo = Replace(Worksheets("Sheet1").Cells(i, 1).Value, "-", "")

　　～以下省略～

End Sub

お礼

> このサイトが停止している場合とインターネットそのものの接続ができない場合を区別する必要があるのか？

なるほど。考えていませんでしたがたしかに区別できたほうがいいですねえ！

回答No.3

kkkkkm

No.1の追加です。

pingで接続確認もあると思います。
サーバーやホストにPingが通るかチェックするサンプルコード
https://vba-create.jp/vba-tips-ping-true-or-false/
どちらにしても、サーバーに接続できるかどうかのチェックですので
動作が単純な方法がいいのではないでしょうか。

お礼

ありがとうございます。とていいやりかたを教えていただきました。
助かりました！

回答No.2

HohoPapa

後記のような関数を仕込んで判定させるのはいかがでしょうか
なお承知かもしれませんが、Microsoft HTML Object Libraryを参照設定する必要があります。

Sub ボタン1_Click()
　　Dim objXMLHttp As Object, zipArr
　　Dim yubinNo As Long
　　Dim line As String
　　Dim splitLine() As String
　　Dim i As Long
　　i = 2 '行番号

　　Do While Cells(i, 1).Value <> ""　　'入力値からハイフンの削除
　　　　yubinNo = Replace(Worksheets("Sheet1").Cells(i, 1).Value, "-", "")

　　If isnetready = False Then
　　　　MsgBox "ネットに未接続です"
　　　　Exit Sub
　　End If

　　～以下省略～

End Sub

Function isnetready() As Boolean
　　Dim objXML As New MSHTML.HTMLDocument
　　Dim htmlDoc As New MSHTML.HTMLDocument
　　Dim objITEM As Object
　　Dim starttime As Date
　　Dim CheckText As String

　　Set htmlDoc = objXML.createDocumentFromUrl("http://zip.cgis.biz/", vbNullString)
　'　以下のようにYahooや国税庁のサイトでもいいかも
　'　Set htmlDoc = objXML.createDocumentFromUrl("https://www.yahoo.jp/", vbNullString)
　'　Set htmlDoc = objXML.createDocumentFromUrl("https://www.nta.go.jp/", vbNullString)

　　starttime = Now()
　　Do Until htmlDoc.readyState = "complete"
　　　　DoEvents
　　　　If Now() > DateAdd("S", 10, starttime) Then
　　　　　　Exit Do
　　　　End If
　　Loop
　　DoEvents

　　CheckText = ""
　　For Each objITEM In htmlDoc.getElementsByTagName("title")
　　　　CheckText = CheckText & objITEM.innerText
　　Next

　　Set objITEM = Nothing
　　Set htmlDoc = Nothing
　　Set objXML = Nothing

　　If CheckText = "" Then
　　　isnetready = False
　　Else
　　　isnetready = True
　　End If

End Function

お礼

ありがとうございます。
Microsoft HTML Object Libraryを参照設定してうまくいきました。

回答No.1

kkkkkm

一度実際に存在する郵便番号でやってみてエラーになったら未接続と考えるのはいかがでしょう。
ただ、一度成功するとその後切れても同じ郵便番号だと再移動しないとエラーにならない。

略
Dim i As Long
i = 2 '行番号

Set objXMLHttp = CreateObject("MSXML2.XMLHTTP")

yubinNo = "1638001" '東京都庁

On Error GoTo ErrorExit
objXMLHttp.Open "GET", "http://zip.cgis.biz/csv/zip.php?zn=" & yubinNo, False
objXMLHttp.Send
On Error GoTo 0

Do While Cells(i, 1).Value <> ""

中略

Loop

Set objXMLHttp = Nothing
Exit Sub

ErrorExit:
Set objXMLHttp = Nothing
MsgBox "Error"

End Sub

お礼

ありがとうございます。でも
＞一度成功するとその後切れても同じ郵便番号だと
ではちと困りますね。