[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『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)を設定して、止まってから2、3秒置いて 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にチェックを入れました。 v6.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
GH行に住所を入れて実行しております。
以前は使えたのに使えなくなってしまった理由がわかりません。
(【みく】) 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.