エクセルＶＢＡで、Yahooの路線の片道料金を取得する

A2に（出発地の）大阪、
B2に（目的地の）名古屋とあったら、
C2に（運賃：片道）6,180円が入るようにしたいのです。
コードを教えて頂きたく御願いします。
（この部分しか書けませんでした。）
Sub test()
Dim IE
Set IE = CreateObject("InternetExplorer.Application")
IE.Navigate "http://transit.map.yahoo.co.jp"
IE.Visible = True
IE.Quit
SetIE = Nothing
End Sub

No.1 回答者： fujillin 回答日時： 2009/09/03 11:06

ざっとの、方法のみですが…

1）大阪、名古屋をエンコードしてURLのサーチ部分に追加したものを
　表示させる。（手動で検索するのとほぼ同じ）
　例の場合だと
　from=%E5%A4%A7%E9%98%AA&to=%E5%90%8D%E5%8F%A4%E5%B1%8B
2）表示された結果のソースから「<dl class="price">」や「運賃：」
　などをキーに料金を検索。（この例だと3箇所みつかるはず）
3）検索された料金を表示。
　（3箇所 6,180円、6,410円、5,980円からどの様に選択して表示する
　　のかはご質問文からは不明）

具体的な方法のヒントはこのあたりにあると思います。
　http://www2s.biglobe.ne.jp/~iryo/vba/IE/index01. …


しかし、実際には、
この他にもパラメータがいろいろあるので、それを無視して利用しても全ての場合に正しい結果が得られるのか不明。
（利用設定や日付などによって料金が変わると思われる）
入力値が不正な場合のチェックをどうするのか？
例のように結果の料金がいろいろある場合にどれを採用するのか？
などなど、ご質問文だけでは不明な点がいろいろあります。

コーディングで行うには、これらの起こり得る可能性について対処しておく必要があるので、かなり複雑になるでしょう。
（例えば、IEのトラブルや、ネット環境が何らかの不具合で繋がらないなどの場合に、値を取ろうとしても即エラーになりますよね？）
また、ご提示のサイトの仕様が変更された時はどうするのかなどなど、他にもいろいろ問題がありそうな気がします。
（そもそも、このような利用ってありなのと言う気がしないでもない）

それなので、ご提示のように検索画面を表示させて、「大阪」、「名古屋」をそれぞれ出発地、目的地の欄にコピーするぐらいまでにしておいた方が宜しいような気がしますが…（あとの操作はユーザにさせる）

この回答への補足

検索された金額で、最初のものを使用しています。

補足日時：2009/09/03 12:10

この回答へのお礼

早速の御回答を有難う御座います。
御指摘のとおりすごく曖昧ですみません。
自分だけが使うので、起こり得る可能性に関しては
とりあえず、置いといて、まず、料金の取得方法を知りたいと思いました。
会社内で、旅費交通費の金額が間違いなく請求されているかをチェックするのに、
何回も繰り返して調べているので、
何か良い方法がＶＢＡを使用して出来ないかと思っています。

お礼日時：2009/09/03 12:21

No.2 回答者： Wendy02 回答日時： 2009/09/03 14:16

こんにちは。

複数の運賃を探す場合は、ループするか、正規表現を使わなくてはなりませんが、とりあえず、参考までコードを書いておきます。今回は、最初に出てくるものだけを取り出しています。

本来、正規表現での取得のほうが、いろんな面で失敗が少ないのですが、私は、検索スピードが落ちるような気がしています。細かい部分は、もう少し手を加えなくてはなりません。

なお、ヤフーは、年に一度か二度はHTMLコードを書き換えますので、結構、泣かされます。だから、やはり正規表現のほうが便利です。それは、研究してください。

ワークシートにボタンを置いて、A1,A2 に書いてあげれば、A3に、金額が出てきます。
例：

Private Sub CommandButton1_Click()
　Call GetFareTest1
End Sub

出力例：

A1:大阪
A2:名古屋
A3:6,180円

なお、失敗したときも表示します。

'-------------------------------------------
'標準モジュール
'-------------------------------------------
'Option Explicit

Sub GetFareTest1()
　　Dim IE As Object
　　Dim myURL As String
　　Dim myContent As String
　　Dim buf As String
　　Dim sST As String
　　Dim sDST As String
　　'ヤフー運賃検索(Yahoo!路線情報)
　　myURL = "http://transit.map.yahoo.co.jp"
　　
　　sST = Encode_Uni2UTF(Range("A1").Value)
　　sDST = Encode_Uni2UTF(Range("A2").Value)
　　If sST = "" Or sDST = "" Then MsgBox "セルに文字がありません。", 48: Exit Sub
　　myURL = myURL & "/search/result?from=" & sST & "&to=" & sDST
　　
　　Set IE = CreateObject("InternetExplorer.Application")
　　With IE
　　　　'.Visible = True 　'コメントブロックをしたら、表示する
　　　　.Navigate myURL
　　　　Do While .Busy
　　　　　　DoEvents
　　　　Loop
　　　　Do Until .ReadyState = 4
　　　　　　DoEvents
　　　　Loop
　　　　myContent = .Document.body.innerHTML
　　　　'情報が取れなくなったときは、ここでログを取る
　　　　.Quit
　　End With
　　Set IE = Nothing
　　
　　'出力
　　Range("A3").Value = PickUpString(myContent, "片道")
End Sub
Function PickUpString(ByVal strContent As String, SearchTxt As String)
Dim buf As String
Dim i As Long
Dim j As Long
　buf = Mid$(strContent, InStr(1, strContent, SearchTxt, 1) + 2, 40)
　　 i = InStr(1, buf, ">", 1) + 1
　　 j = InStrRev(buf, "</S", , 1)
　　 If i * j > 0 Then
　　 PickUpString = Mid$(buf, i, j - i)
　　 Else
　　 PickUpString = "取得に失敗"
　　 End If
End Function

Private Function Encode_Uni2UTF(ByRef strUni As String)
Dim buf As Variant
Dim tbuf As Variant
Dim n As Variant
Const CSET = "UTF-8"
Dim ADOstrm As Object 'ADODB.Stream

　　On Error GoTo ErrHandler
　　Set ADOstrm = CreateObject("ADODB.Stream")　'New ADODB.Stream
　　ADOstrm.Open
　　ADOstrm.Type = ADTYPETEXT
　　ADOstrm.Charset = CSET
　　ADOstrm.WriteText strUni
　　ADOstrm.Position = 0
　　ADOstrm.Type = adTypeBinary
　　ADOstrm.Position = 3
　　buf = ADOstrm.Read()
　　ADOstrm.Close
　　Set ADOstrm = Nothing
　　
　　For Each n In buf
　　　 tbuf = tbuf & "%" & Hex(n)
　　Next
　　Encode_Uni2UTF = tbuf
　　Exit Function
ErrHandler:
　　If ADOstrm Is Nothing = False Then ADOstrm.Close
　　Set ADOstrm = Nothing
End Function

この回答へのお礼

御回答を有難うございます。
Private Function Encode_Uni2UTF(ByRef strUni As String)
のところで止まります。
（ボタンを作成し、標準モジュール１にコピペしました。
A1に大阪、A2に名古屋と手入力してあります。）
すみませんが宜しく御願いします。

お礼日時：2009/09/03 17:57

No.3 ベストアンサー 回答者： Wendy02 回答日時： 2009/09/03 18:29

こんばんは。

失礼しました。ADO を参照設定ままで、作っていたので、それを外さずに動かしていたからです。

>Private Function Encode_Uni2UTF(ByRef strUni As String)
>のところで止まります。
止まる理由はよく分かりませんが、以下のようにすればよいはずです。
ただ、金額は、日時設定していませんから、値段が変わります。

ひとつのまとまりを、以下に、そのまま上書きしてしてください。

'-------------------------------------------
Private Function Encode_Uni2UTF(ByRef strUni As String)
Dim buf As Variant
Dim tbuf As Variant
Dim n As Variant
Const CSET = "UTF-8"
Const ADTYPETEXT = 2
Const ADTYPEBINARY = 1
Dim ADOstrm As Object 'ADODB.Stream

　　On Error GoTo ErrHandler
　　Set ADOstrm = CreateObject("ADODB.Stream")　'New ADODB.Stream
　　ADOstrm.Open
　　ADOstrm.Type = ADTYPETEXT
　　ADOstrm.Charset = CSET
　　ADOstrm.WriteText strUni
　　ADOstrm.Position = 0
　　ADOstrm.Type = ADTYPEBINARY
　　ADOstrm.Position = 3
　　buf = ADOstrm.Read()
　　ADOstrm.Close
　　Set ADOstrm = Nothing
　
　　For Each n In buf
　　　 tbuf = tbuf & "%" & Hex(n)
　　Next
　　Encode_Uni2UTF = tbuf
　　Exit Function
ErrHandler:
　　If ADOstrm Is Nothing = False Then ADOstrm.Close
　　Set ADOstrm = Nothing
End Function

この回答へのお礼

まるごと全部作成して頂き、本当に感謝の気持ちでいっぱいです。
頭が良いと、こんなに業務が楽になるんだなあとつぐつぐ思います。
今の私のレベルでは、難し過ぎて解読出来ないので、
そのまま使用させてもらうのですが、理解出来る様に、
勉強を続けたいと思います。
御指導有難うございました。

お礼日時：2009/09/04 00:10