[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBAでGoogle Mapを使用したルート検索』（maoh）
VBA初心者です。
[[20150420151851]]【みく】に掲載のあるVBAと同様かと思いますが、旧GoogleMapでは使用できたのですがGoogleMapの使用変更に伴い検索が出来なくなりました。
よろしくお願いします！
「コンパイルエラー
subまたはFunctionが定義されていません」で1行目でエラーが出ます。
Sub KmH()
Dim IE As Object
Dim i As Long
Dim j As Long
Set IE = CreateObject("InternetExplorer.application")
IE.Visible = True
IE.Navigate "http://maps.google.co.jp/maps"
Call sWait(IE)
Sleep 1000
With IE.Document
.all("d_launch").Click
Call sWait(IE)
' Sleep 20000
.all("dir_d_btn").Click
Call sWait(IE)
For i = 5 To Cells(Rows.Count, "C").End(xlUp).Row
.all("d_d").Value = Cells(i, "B").Text
.all("d_daddr").Value = Cells(i, "C").Text
.all("d_sub").Click
.all("d_options_show").Click
Call sWait(IE)
Sleep 5000
For j = 0 To .getElementsByTagName("SPAN").Length - 1
If Right(.getElementsByTagName("SPAN")(j).innerHTML, 2) = "km" Then
Cells(i, "D").Value = .getElementsByTagName("SPAN")(j).innerHTML
Cells(i, "E").Value = .getElementsByTagName("SPAN")(j + 1).innerHTML
Exit For
End If
Next j
Next i
End With
IE.Quit
Set IE = Nothing
End Sub
Sub sWait(OBJ As Object)
Sleep 1000
While OBJ.readyState <> 4
While OBJ.Busy = True
DoEvents
Sleep 100
Wend
Wend
Sleep 1000
End Sub
＜ 使用 Excel：Excel2013、使用 OS：Windows7 ＞
エラーメッセージからはあまり関係なさそうですが、マクロの先頭に Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) がないせいじゃないでしょうか。
http://www.vba-ie.net/function/sleep.html
（Mook） 2015/04/29(水) 20:18
教えていただいたとおり、マクロの先頭に記述しましたが、
コンパイルエラー
このプロジェクトのコードは、64ビットで使用するために更新する必要があります。
Declareステートメントの確認及び更新を行い、次にDeclareステートメントにPtrSafe属性を設定してくださいとのメッセージが表示されます。
初心者で申し訳ありません。
よろしくお願いします。
（maoh） 2015/04/29(水) 20:47
先のリンク先に64bit 版の記述もありますが、 Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr) を書いてみてどうでしょうか。
（Mook） 2015/04/29(水) 21:01
実行時エラー’424’
オブジェクトが必要です。
.all("d_launch").Click
のところでエラーがでます。
あと、オプションで「高速道路を使用しない」を指定する記述が解りましたら教えてください。
よろしくお願いします。
（maoh） 2015/04/29(水) 21:25
いろいろと人のコードを見るのは面倒なので書き直してみました。
>オプションで「高速道路を使用しない」を指定する記述が解りましたら教えてください。 というのは、手動では設定できるのでしょうか？
#If VBA7 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr) #Else Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long) #End If
'//--------------------------------------
Sub SearchDistanceAndTime()
'//--------------------------------------
Dim objIE As Object
Dim i As Long
Dim j As Long
Set objIE = CreateObject("InternetExplorer.application")
objIE.Visible = True
Dim txtURL As String
For i = 5 To Cells(Rows.Count, "C").End(xlUp).Row
txtURL = "http://maps.google.co.jp/maps?hl=ja&dirflg=d&saddr=" _
& EncodeURL(Cells(i, "B").Text) & "&daddr=" & EncodeURL(Cells(i, "C").Text)
objIE.Navigate txtURL
Call sWait(objIE)
Sleep 3000
SetOption objIE
Call sWait(objIE)
Sleep 3000
With objIE.Document
For j = 0 To .getElementsByTagName("SPAN").Length - 1
If Right(.getElementsByTagName("SPAN")(j).innerHTML, 2) = "km" Then
Cells(i, "D").Value = .getElementsByTagName("SPAN")(j).innerHTML
Cells(i, "E").Value = .getElementsByTagName("SPAN")(j + 1).innerHTML
Exit For
End If
Next
End With
Next
objIE.Quit
Set objIE = Nothing
End Sub
'//--------------------------------------
Sub SetOption(objIE As Object)
'//--------------------------------------
Set cb = objIE.Document.getElementById("directions-omnibox-avoid-highways")
cb.Checked = True
End Sub
'//--------------------------------------
Sub sWait(objIE As Object)
'//--------------------------------------
Sleep 1000
Do While objIE.readyState <> 4 Or objIE.Busy = True
DoEvents
Loop
Sleep 1000
End Sub
#If VBA7 Then
'//--------------------------------------
Private Function EncodeURL(ByVal txt As String) As String
'//--------------------------------------
Dim objDoc As Object
Dim objEelm As Object
txt = Replace(txt, "\", "\\")
txt = Replace(txt, "'", "\'")
Set objDoc = CreateObject("HtmlFile")
Set objEelm = objDoc.CreateElement("Span")
objEelm.SetAttribute "id", "result"
objDoc.AppendChild objEelm
objDoc.ParentWindow.execScript "document.getElementById('result').innerText = encodeURIComponent('" & txt & "');", "JScript"
EncodeURL = objEelm.innerText
End Function
#Else
'//--------------------------------------
Private Function EncodeURL(ByVal txt As String) As String
'//--------------------------------------
With CreateObject("ScriptControl")
.Language = "JScript"
EncodeURL = .CodeObject.encodeURIComponent(txt)
End With
End Function
#End If
（Mook） 2015/04/29(水) 22:02
実行時エラー'429'
ActiveXコンポーネントはオブジェクトを作成できません。
With CreateObject("ScriptControl")
（maoh） 2015/04/29(水) 22:24
64bit はいろいろなところで制約がありますね。 http://www.ka-net.org/office/of32.html
高速オプションも見つかったので、修正しました。
（Mook） 2015/04/29(水) 22:52
どうもオプションにはチェックをつけても、DOMからの操作だと経路の再検索をしない ようなので高速道路を使用しないは、反映していなようです。
っていうことで、素直に API 使って書き直しました。 https://developers.google.com/maps/?hl=ja
#If VBA7 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr) #Else Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long) #End If
'//--------------------------------------
Sub SearchDistanceAndTime()
'//--------------------------------------
Dim i As Long
Dim j As Long
Dim objIE As Object
Set objIE = CreateObject("InternetExplorer.application")
objIE.Visible = True
Dim txtURL As String
For i = 5 To Cells(Rows.Count, "C").End(xlUp).Row
txtURL = "http://maps.googleapis.com/maps/api/distancematrix/xml?" _
& "language=ja" _
& "&origins=" & EncodeURL(Cells(i, "B").Text) _
& "&destinations=" & EncodeURL(Cells(i, "C").Text) _
& "&avoid=highways"
objIE.Navigate txtURL
readyStateWait objIE
Cells(i, "D").Value = getResultValue(objIE.Document, "distance")
Cells(i, "E").Value = getResultValue(objIE.Document, "duration")
Next
objIE.Quit
End Sub
'//--------------------------------------
Function getResultValue(dom As Object, tagName As String)
'//--------------------------------------
Dim res
res = dom.getElementsByTagName(tagName)(0).getElementsByTagName("text")(0).innerText
res = Replace(res, "<text>", "")
getResultValue = Replace(res, "</text>", "")
End Function
'//--------------------------------------
Sub readyStateWait(objIE As Object)
'//--------------------------------------
Do While objIE.readyState <> 4 Or objIE.Busy = True
DoEvents
Loop
Sleep 1000
End Sub
#If VBA7 Then
'//--------------------------------------
Private Function EncodeURL(ByVal txt As String) As String
'//--------------------------------------
Dim objDoc As Object
Dim objEelm As Object
txt = Replace(txt, "\", "\\")
txt = Replace(txt, "'", "\'")
Set objDoc = CreateObject("HtmlFile")
Set objEelm = objDoc.CreateElement("Span")
objEelm.SetAttribute "id", "result"
objDoc.AppendChild objEelm
objDoc.ParentWindow.execScript "document.getElementById('result').innerText = encodeURIComponent('" & txt & "');", "JScript"
EncodeURL = objEelm.innerText
End Function
#Else
'//--------------------------------------
Private Function EncodeURL(ByVal txt As String) As String
'//--------------------------------------
With CreateObject("ScriptControl")
.Language = "JScript"
EncodeURL = .CodeObject.encodeURIComponent(txt)
End With
End Function
#End If
（Mook） 2015/04/30(木) 11:04
って書いてみたら、XML 処理だけですむことに気が付いた。 こっちなら IE も Sleep もいりません。 なにより、処理が早いと思います。
'//--------------------------------------
Sub getDistanceAndDulationAPI()
'//--------------------------------------
Dim i As Long
Dim xDoc As New MSXML2.DOMDocument '// [参照設定] で "Microsoft XML, version x.0" にチェック。
Dim txtURL As String
For i = 5 To Cells(Rows.Count, "C").End(xlUp).Row
txtURL = "http://maps.googleapis.com/maps/api/distancematrix/xml?" _
& "language=ja" _
& "&origins=" & EncodeURL(Cells(i, "B").Text) _
& "&destinations=" & EncodeURL(Cells(i, "C").Text) _
& "&avoid=highways"
xDoc.Load txtURL
If xDoc.SelectNodes("/DistanceMatrixResponse/status")(0).Text = "OK" Then
Cells(i, "D").Value = xDoc.SelectNodes("/DistanceMatrixResponse/row/element/duration/text")(0).Text
Cells(i, "E").Value = xDoc.SelectNodes("/DistanceMatrixResponse/row/element/distance/text")(0).Text
End If
Next
End Sub
#If VBA7 Then
'//--------------------------------------
Private Function EncodeURL(ByVal txt As String) As String
'//--------------------------------------
Dim objDoc As Object
Dim objEelm As Object
txt = Replace(txt, "\", "\\")
txt = Replace(txt, "'", "\'")
Set objDoc = CreateObject("HtmlFile")
Set objEelm = objDoc.CreateElement("Span")
objEelm.SetAttribute "id", "result"
objDoc.AppendChild objEelm
objDoc.ParentWindow.execScript "document.getElementById('result').innerText = encodeURIComponent('" & txt & "');", "JScript"
EncodeURL = objEelm.innerText
End Function
#Else
'//--------------------------------------
Private Function EncodeURL(ByVal txt As String) As String
'//--------------------------------------
With CreateObject("ScriptControl")
.Language = "JScript"
EncodeURL = .CodeObject.encodeURIComponent(txt)
End With
End Function
#End If
（Mook） 2015/04/30(木) 11:52
いろいろご検討いただきありがとうございます。
11:04のスクリプトは無事に出力できましたが、
11:52のスクリプトでは下記エラーが表示されます。
2行目 Sub getDistanceAndDulationAPI()
5行目 xDoc As New MSXML2.DOMDocument
「コンパイルエラー
ユーザー定義型は定義されていません。」
のエラーが出ます。
どのように修正すれば良いのでしょうか。
よろしくお願いします。
（maoh） 2015/04/30(木) 21:19
横から失礼します。
>5行目 xDoc As New MSXML2.DOMDocument
↓はチェックされてますか？
>Dim xDoc As New MSXML2.DOMDocument '// [参照設定] で "Microsoft XML, version x.0" にチェック。 （カリーニン） 2015/04/30(木) 21:29
すいません。
初心者なのでよく解りません。
ご教授よろしくお願いします。
（maoh） 2015/04/30(木) 21:39
チェックする項目は違いますが、手順は下記が参照になると思います。 http://officetanaka.net/excel/vba/tips/tips100.htm
いろいろとわからないことはあるでしょうが、VBA、参照設定 等で検索はしてみたでしょうか。
今の時代、簡単に自力で調べられることもまた、多いと思います。
（Mook） 2015/04/30(木) 22:13
今回は、時間がない中での質問で、
大変ご迷惑をおかけしました。
今回教えていただいた内容を勉強させていただきます。
その上、解らないことがありましたら、
再度ご教授をお願いいたします。
ありがとうございました。
（maoh） 2015/04/30(木) 22:22
迷惑ではありませんよ。 おかげで GoogleMap をいろいろと楽しめました。
ただ、ちょっと調べればわかることも多いので、検索してみてくださいね。 っていうことです。
調べたり、手を動かした結果わからないことは、いくらでも質問してください。 御自身で苦労したことは、同じことを質問しても理解できることが多いと思います。
（Mook） 2015/04/30(木) 22:30
横からすみません。
11:52のコードを動かすと，
If xDoc.SelectNodes("/DistanceMatrixResponse/status")(0).Text = "OK" Then
のところで，実行時エラー91となります。
調べてみたのですが，よくわかっていません。 私の環境では動作しないのでしょうか。
win7 32bit Excel2010 32bit （藻琴） 2015/05/01(金) 12:04
同期設定を入れたほうが良いですね。
xDoc.Load txtURL
を
xDoc.async = False
xDoc.Load txtURL
と修正して、再度試してみてください。
あとこの処理は、B列とC列の5行目以降に出発地と、目的地がある前提の処理ですので、 まずは、B5 に出発地、C5 に目的地 を書いて試してみてください。
それでダメなら、
xDoc.Load txtURL
のまえに、
Cells(i,"F").Value = txtURL
などとして、その内容を直接 Web で入力してみて、出た結果を教えてください。
（Mook） 2015/05/01(金) 12:44
ありがとうございます。
修正しました。 実行時エラー アクセスが拒否されました となりました。
Cells(i,"F").Value = txtURL とすると，F5に http://maps.googleapis.com/maps/api/distancematrix/xml?language=ja&origins=%E7%AD(中略)&avoid=highways と表記されます。 （藻琴） 2015/05/01(金) 14:10
下記はこちらで同様にして動いている URL ですが、これを直接実行してもアクセスが 「拒否されました」 となるでしょうか。
これでダメだとなると、ネットワーク環境によるものかもしれませんが、GoogleMap を頻繁に利用していたりするでしょうか。
直接の原因ではないかもしれませんが、フリーで利用できるリクエスト数等に 制約があるようです。 https://developers.google.com/maps/licensing?hl=ja
（Mook） 2015/05/01(金) 14:41
通常の環境では拒否されないのですね。
11:04のコードでは，IEが立ち上がって，「こちらで同様にして動いている URL」と同じようなxmlが開きます。そして，
res = dom.getElementsByTagName(tagName)(0).getElementsByTagName("text")(0).innerText
のところで，実行時エラー91 となります。
>これを直接実行して って，具体的にどうやるのでしょうか。 （藻琴） 2015/05/01(金) 17:31
上の URL を開いてもらったのがその対応になります。
F5 の文字列をコピーして、IE のアドレスバーに貼り付けたら、同じような結果が表示 されますか？ というのが先の質問の意図です。 住所の入力に問題が無ければ、表示されるはずなのですが。
あとは、関係無いと思いますが、 > [参照設定] で "Microsoft XML, version x.0" でチェックしたバージョンはいくつでしょうか。
できれば下記のようにデバッグしてもらえると、もう少し原因が絞り込めると思います。
xDoc.Load txtURL
でブレークポイント（F9）を設定して、止まってから２、３秒置いて F8 を押して
ステップ実行していっても、同じエラーが出るでしょうか。
それから気になるのは、IE のセキュリティ設定でしょうか。 https://www.st.ryukoku.ac.jp/security/windows/ie.html でインターネットのセキュリティレベルはどうなっているでしょうか。
上記の参照先の手順で、IE の信頼済サイトに、 http://maps.googleapis.com を追加しても変化しないでしょうか。 （Mook） 2015/05/01(金) 17:56
ありがとうございます。
URLを開くことはできます。 Microsoft XMLはv3.0にチェックを入れました。 ｖ6.0もあります。
ブレークポイント設定して，F8で実行しても同じエラーです。。。
インターネットセキュリティレベルは中です。
信頼済サイトに追加しました。
が，実行時エラー 2147024891(80070005)アクセスが拒否されました。と xDoc.Load txtURL で出てしまいます。
（藻琴） 2015/05/01(金) 18:24
うーん、ことごとく予想が外れますね。
ブラウザの表示を「互換性表示」にしてから実行しても同じでしょうか。
あとはウィルス対策ソフトが入っていたりするでしょうか。 あっても、流石に切ることはできないですよね。
うーん、後は何が考えられるかな・・・。
（Mook） 2015/05/01(金) 18:35
もしかして，IEのバージョンが8なのが影響してますかね？ （職場のPCで，Ver.8指定なのです。） でも，ほかの環境では正しく動くとのことなので，週末にほかの環境で試してみます。 （藻琴） 2015/05/01(金) 19:08
IE8 の方が素直に動きそうですけれど。 環境に依存するコードはなかなか面倒ですね。
関係無いとは思いますが、こちらでは XML Ver6.0 で試しています。
また何か気が付いたらコメントします。
（Mook） 2015/05/01(金) 19:15
昨日のMookさんの同期設定
xDoc.async = False
を記述したところ無事に回避できました。
ありがとうございました。
（maoh） 2015/05/02(土) 16:42
（【みく】） 2015/05/05(火) 10:24
???
maohさん＝みくさん？ 解決したのではなかったのですか？？？ （カシスソーダ） 2015/05/05(火) 13:03
くれぐれも、参照設定を忘れずに。
口を開けて餌を待つ（失礼）だけでなく、
他人の発言を読む努力はしてください。
（γ） 2015/05/05(火) 13:48
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("G:H")) Is Nothing Then Exit Sub
If Cells(Target.Row, 7).Text = "" Or Cells(Target.Row, 8).Text = "" Then Exit Sub
Dim objIE As Object
Dim tgt1
Dim tgt2
Set objIE = CreateObject("InternetExplorer.application")
tgt1 = Cells(Target.Row, 7).Text
tgt2 = Cells(Target.Row, 8).Text
objIE.Visible = True
objIE.Navigate "http://maps.google.co.jp/maps"
Do While objIE.Busy = True Or objIE.ReadyState <> 4: Loop
'--ルート乗換案内オブジェクトページのの項目をダイレクト書き込み
With objIE.Document
.all("d_launch").Click
Do While objIE.Busy = True Or objIE.ReadyState <> 4: Loop
Application.Wait Now + TimeValue("00:00:02")
'--車で行く〜自社住所〜得意先住所〜検索
.all("dir_d_btn").Click
.all("d_d").Value = tgt1
.all("d_daddr").Value = tgt2
.all("d_sub").Click
.all("d_options_show").Click
End With
Set objIE = Nothing
End Sub
ＧＨ行に住所を入れて実行しております。
以前は使えたのに使えなくなってしまった理由がわかりません。
（【みく】） 2015/05/05(火) 14:59
objIE.Navigate "http://maps.google.co.jp/maps" これが間違っている？
.all("d_launch").Clickのところでエラーが出ます。
（きさね） 2015/09/14(月) 10:03
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("G:H")) Is Nothing Then Exit Sub
If Cells(Target.Row, 7).Text = "" Or Cells(Target.Row, 8).Text = "" Then Exit Sub
Dim objIE As Object
Dim tgt1
Dim tgt2
Set objIE = CreateObject("InternetExplorer.application")
tgt1 = Cells(Target.Row, 7).Text
tgt2 = Cells(Target.Row, 8).Text
objIE.Visible = True
objIE.Navigate "http://maps.google.co.jp/maps"
Do While objIE.Busy = True Or objIE.ReadyState <> 4: Loop
'--ルート乗換案内オブジェクトページのの項目をダイレクト書き込み
With objIE.Document
.GetElementsByClassName("searchbox-directions")(0).Click
Application.Wait Now + TimeValue("00:00:02")
.GetElementsByClassName("directions-travel-mode-icon directions-drive-icon")(0).Click
Application.Wait Now + TimeValue("00:00:02")
.GetElementsByClassName("tactile-searchbox-input")(2).Value = tgt1
SendKeys "{ENTER}"
.GetElementsByClassName("tactile-searchbox-input")(3).Value = tgt2
SendKeys "{ENTER}"
End With
Set objIE = Nothing
End Sub
sendkeyとClassnameでの制御となっております。
参考URL
http://officetanaka.net/excel/vba/statement/SendKeys.htm
http://www.vba-ie.net/form/text.html
http://www.vba-ie.net/form/button.html
classのnameが変わった場合はまた使えなくなります。その時はまた作り直せばいいのです。(ダメですかね）
またこれを作成するには開発ツールが必須となります。
（デイト） 2015/09/14(月) 11:51
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.