2013年5月23日木曜日

web pageをゲットの2種方法 xmlhttp と querytables、querytablesの取得完了を待ってから処理する

Public oXMLHTTP As New MSXML2.xmlhttp

Public Function ShowHTML(ByVal strURL, Optional ByVal strName = "") As String
    On Error GoTo ErrorHandler
    Dim strError As String
    strError = ""
    Dim strResponse As String
    strResponse = ""

    With oXMLHTTP
        .Open "GET", strURL, False
        .send ""
        If .Status <> 200 Then
            strError = .statusText
            GoTo CleanUpAndExit
        Else
                If strName <> "" Then
                    Dim outtext As Long
                    outtext = FreeFile
                    Open ActiveWorkbook.Path & "\" & strName & ".txt" For Output As #outtext
                    Write #outtext, .responseText
                    Close #outtext
                End If
                strResponse = .responseText
        End If
    End With
CleanUpAndExit:
    On Error Resume Next ' Avoid recursive call to error handler
    ' Clean up code goes here
    Set oXMLHTTP = Nothing
    ' Report any error
    If Len(strError) > 0 Then
        MsgBox strError
    Else
        ShowHTML = strResponse
    End If
    Exit Function
ErrorHandler:
    strError = Err.Description
    Resume CleanUpAndExit
End Function

Sub test1()
    repstr = ShowHTML("http://kagen88.blogspot.jp/")
    ActiveSheet.Range("A1") = repstr
End Sub

Sub test2()
Set shFirstQtr = Workbooks(1).Worksheets(1)
Set qtQtrResults = shFirstQtr.QueryTables _
 .Add(Connection:="URL;http://kagen88.blogspot.jp/", _
 Destination:=shFirstQtr.Cells(1, 1))
    With qtQtrResults
        '.WebFormatting = xlAll
        .WebFormatting = xlWebFormattingAll
        .Refresh
    End With

Dim timeToRun As Date
timeToRun = Now + TimeValue("0:00:05")
Application.OnTime timeToRun, "doSomething" '5秒を待って "doSomething"を実行
End Sub
Sub doSomething()
   'Do Anything
End Sub

0 件のコメント:

コメントを投稿