改めて質問します。

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

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

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

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

回答の条件
  • 1人2回まで
  • 登録:2007/07/07 11:41:44
  • 終了:2007/07/14 11:45:03

回答(3件)

id:Mook No.1

Mook回答回数1312ベストアンサー獲得回数3912007/07/07 22:41:12

ポイント26pt

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

「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

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

id:taro_tan

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

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

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

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

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

2007/07/08 01:12:36
id:airplant No.2

airplant回答回数220ベストアンサー獲得回数492007/07/07 15:56:24

ポイント27pt

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を「ツール→参照設定」で参照設定しておく必要あります。

id:taro_tan

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

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

2007/07/08 01:05:53
id:F-15X No.3

F-15X回答回数111ベストアンサー獲得回数132007/07/07 18:17:48

ポイント27pt

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

id:taro_tan

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

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

2007/07/08 01:05:57

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません