Results of 1 - 1 of about 1215 for （Mook）
(0.001 sec.)
- [[20150429195616]]
- #score: 9211
- @digest: 83808de294c1337b45ce150e25dd934c
- @id: 67888
- @mdate: 2015-09-14T02:51:43Z
- @size: 21440
- @type: text/plain
- #keywords: objeelm (98855), txturl (76172), encodeurl (73827), objdoc (60584), xdoc (59046), objie (38971), highways (33384), encodeuricomponent (32048), 藻琴 (31932), googleapis (31360), getelementsbytagname (28826), maps (27630), jscript (24754), googlemap (22848), innertext (20390), swait (20271), innerhtml (18528), language (14765), sleep (11859), readystate (11448), navigate (9907), document (9347), kernel32 (7811), internetexplorer (7713), declare (5789), 2015 (4960), 照設 (4093), google (4004), function (3313), 時エ (2889), createobject (2822), txt (2607)
- 『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 ---- Mookさん、早速のコメントありがとうございます。 教えていただいたとおり、マクロの先頭に記述しましたが、 コンパイルエラー このプロジェクトのコードは、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 ---- Mookさん、ありがとうございます。 教えていただいたとおり記述し実行したところ 実行時エラー'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 ---- Mookさん ご教授のとおり記述し実行してみたところ、 下記のエラーが表示されます。 よろしくお願いします。 実行時エラー'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 ---- Mookさん いろいろご検討いただきありがとうございます。 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 ---- Mookさん、カリーニンさん 今回は、時間がない中での質問で、 大変ご迷惑をおかけしました。 今回教えていただいた内容を勉強させていただきます。 その上、解らないことがありましたら、 再度ご教授をお願いいたします。 ありがとうございました。 （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 ですが、これを直接実行してもアクセスが 「拒否されました」 となるでしょうか。 http://maps.googleapis.com/maps/api/distancematrix/xml?language=ja&origins=%E6%9D%B1%E4%BA%AC%E9%83%BD%E5%8D%83%E4%BB%A3%E7%94%B0%E5%8C%BA1%E7%95%AA&destinations=%E5%A4%A7%E9%98%AA%E5%BA%9C%E5%A4%A7%E9%98%AA%E5%B8%82%E4%B8%AD%E5%A4%AE%E5%8C%BA%E5%A4%A7%E9%98%AA%E5%9F%8E%20&avoid=highways これでダメだとなると、ネットワーク環境によるものかもしれませんが、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 ---- webでいろいろ検索してみましたが、 解決出来なかったので、再度ここで質問するところでした。 昨日のMookさんの同期設定 xDoc.async = False を記述したところ無事に回避できました。 ありがとうございました。 （maoh） 2015/05/02(土) 16:42 ---- ・・・・・ ・。・・・ ・・・・・・・最終的にどんなコードにすればいいのですか????? （【みく】） 2015/05/05(火) 10:24 ---- ??? maohさん=みくさん? 解決したのではなかったのですか??? （カシスソーダ） 2015/05/05(火) 13:03 ---- とりあえず、Mookさんの二つの発言をもとに、 （Mook） 2015/04/30(木) 11:52 （Mook） 2015/05/01(金) 12:44 トライしてみては? くれぐれも、参照設定を忘れずに。 口を開けて餌を待つ（失礼）だけでなく、 他人の発言を読む努力はしてください。 （γ） 2015/05/05(火) 13:48 ---- 実行時エラー 424 ってエラーになってしまいます。 オブジェクトが必要です。って表示されます。 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" これが間違っている? ---- 自分も以前使えていたものがエラーになってこまっています。 googlemapのリンクをhttps://www.google.co.jp/maphpにして強引に旧マップを使っていましたが、それも新マップに移行してしまいました。 .all("d_launch").Clickのところでエラーが出ます。 （きさね） 2015/09/14(月) 10:03 ---- googleMap操作に不得手ながら挑戦させてもらいます。 上のやり方は諦めて別の方法で考えてみます。 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... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201504/20150429195616.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97018 documents and 608145 words.
訪問者：