人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

改めて質問します。
Excel VBAからIEを立ち上げ、そのURLを取得したいです。
ユーザーフォームに

ラベル lblURL 「URL表示」
コマンドボタン cmdKensaku 「検索」
コマンドボタン cmdSyutoku 「URL取得」

この3つのオブジェクトを配置し、
「検索」を押すとIEが立ち上がり、URLを取得を押すと
その時表示しているページのURLを取得しラベルに表示させたいです。

IEを立ち上げる方法はわかったのですがURL取得の方法がわからず
困っております。
回答していただいた方にはポイントをはずませてもらいます。

●質問者: taro_tan
●カテゴリ:コンピュータ インターネット
✍キーワード:Excel IE URL VBA オブジェクト
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● Mook
●26ポイント

ご提示の仕様と異なりますが、フォームではなくシートモジュールにボタンを配し、

「URL 取得」を押すごとに表示中のURL を シートに追記していくようにしてみました。


シートにcmdKensaku と cmdSyutoku ボタンを配し、シートモジュールに下記を貼り付けます。

'---------------------------------------------
' 検索ボタン処理
'---------------------------------------------
Private Sub cmdKensaku_Click()
'---------------------------------------------
 startIE
End Sub

'---------------------------------------------
' URL 取得処理
'---------------------------------------------
Private Sub cmdSyutoku_Click()
'---------------------------------------------
 writeURL
End Sub

下記を標準モジュールに貼り付けて実行してみてください。

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public objIE As Object

'---------------------------------------------
Const searchURL = "http://www.google.co.jp/"

'---------------------------------------------
' IE を起動し初期画面を表示
'---------------------------------------------
Public Sub startIE()
'---------------------------------------------
 Set objIE = CreateObject("InternetExplorer.application")
 objIE.Visible = True '見えるようにする
 objIE.Navigate searchURL
 
 Dim wdc As Long
 Do While objIE.Busy = True And wdc < 100
 wdc = wdc + 1
 Sleep 100
 DoEvents
 Loop
End Sub

'---------------------------------------------
' 現在表示しているURL を記録
'---------------------------------------------
Public Sub writeURL()
'---------------------------------------------
 If objIE Is Nothing Then
 MsgBox "有効なブラウザが認識できません。"
 Exit Sub
 End If

 Dim lastRow As Long
 lastRow = Range("A" & Rows.Count).End(xlUp).Row + 1
 Cells(lastRow, "A").Value = objIE.LocationURL
End Sub

ラベルに表示したい場合はセルに代入している writeURL 関数を

'---------------------------------------------
Public Sub writeURL()
'---------------------------------------------
 If objIE Is Nothing Then
 MsgBox "有効なブラウザが認識できません。"
 Exit Sub
 End If

 lblURL.Caption = objIE.LocationURL
End Sub

のように変えれば出来ると思います。

◎質問者からの返答

丁寧なコードを書いていただき、ありがとうございます。

明日以降に作ってみます。またコメントしますのでよろしくお願いします。

(こちらは、先日質問したオークションの商品管理のプログラムの一部です。

オークション出品中の商品ページURLを管理したいのですが、

EXCELにいちいちコピー&ペーストするのが面倒だな・・・と思いまして)


2 ● airplant
●27ポイント

IEを立ち上げている方法が分かりませんが、もし「Microsoft Internet Controls」を使っているのであれば、次のプロパティに入っています。

LocationURL

サンプルコードです。

Option Explicit

Sub IEstart()

 With New SHDocVw.InternetExplorer
 .Navigate "http://www.microsoft.com/japan"
 .Visible = True
 MsgBox "Wait!", vbOKOnly '立ち上がるまで待つ
 'URLとサイト名
 MsgBox .LocationURL & vbCrLf & .LocationName
 
 End With

End Sub

立ち上がってすぐに「Wait!」のボックスでOKを押すと、「http://www.microsoft.com/ja/jp/default.aspx」がメッセージボックスに現れます。

適当にサイトを移動してからOKを押すと、その時点のアドレスが表示されます。


該当OCXを「ツール→参照設定」で参照設定しておく必要あります。

◎質問者からの返答

丁寧なコードを書いていただき、ありがとうございます。

明日以降に作ってみます。またコメントしますのでよろしくお願いします。


3 ● F-15X
●27ポイント

7.7 <BODY>部のHTMLを取得する

http://www.happy2-island.com/vbs/cafe02/capter00707.shtml

※Document.Body.InnerHtmlというプロパティで取得


以下の関数はgoogleで検索した結果(html)から正規表現でurlとタイトルを表示するサンプルです。

※使い方

Call ExtractResults(取得したhtmlタグ)


'結果抽出

Private Function ExtractResults(ByVal html)

    Dim objRegExp, objMatch, objMatches, objSubMatches

    Set objRegExp = CreateObject("VBScript.RegExp")

    With objRegExp

        .Global = True

        .IgnoreCase = True

    End With

    objRegExp.Pattern = "<h2 class=r><a href=""(.*?)"" class=l .*?>(.*?)</a></h2>"

    Set objMatches = objRegExp.Execute(html)

    For Each objMatch In objMatches

        Set objSubMatches = objMatch.SubMatches

        MsgBox  objSubMatches.Item(0) 'URL

        MsgBox  EraseTags(objSubMatches.Item(1)) 'タイトル

   Next

   Set objRegExp = Nothing

End Function

'タグの除去

Private Function EraseTags(ByVal tag)

    Dim objRegExp

    Set objRegExp = CreateObject("VBScript.RegExp")

    With objRegExp

        .Global = True

        .IgnoreCase = True

    End With

    objRegExp.Pattern = "<.*?>"

    EraseTags = objRegExp.Replace( tag, "" )

    Set objRegExp = Nothing

End Function


その他

IEを起動しないで行う方法を紹介します。

通常はこちらの方がスマートでしょう。

Web ページをダウンロードする方法? MSXML 編?

http://www.f3.dion.ne.jp/~element/msaccess/AcTipsVbaXMLHTTP.html

◎質問者からの返答

丁寧なコードを書いていただき、ありがとうございます。

明日以降に作ってみます。またコメントしますのでよろしくお願いします。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ