シートシート上のURLのソースを取得

※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。

※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。

Option Explicit

Sub SheetHTMLsourceGet()
'****************************
'シート上のURLのソースを取得
'****************************
'即興で作成
'少しコードが荒いです
'適当に変換して使って下さい。
Dim sht As Worksheet
Dim n As Long, tmp(4) As String, i As Long
Dim Character As String, SPL As Variant, SP(4) As String
Dim Ffind(24) As String, Lfind(24) As String, SPL2 As Variant

Set sht = ThisWorkbook.Worksheets("Sheet2")

Ffind(11) = "<title>"
Lfind(12) = "</title>"
Ffind(13) = "<div class=""適当な文字"">"
Lfind(14) = "<div class=""適当な文字"">"
SP(1) = "<div>"
SP(2) = "<"

With sht
For n = 1 To .Cells(65536, 1).End(xlUp).Row

    Character = responseXMLText(.Cells(n, 1).Value)
        tmp(1) = CharacterFindNext(Character, Ffind(11), Lfind(12))
        Debug.Print tmp(1)
        .Cells(n, 3).Value = tmp(1)
        tmp(2) = CharacterFindNext(Character, Ffind(13), Lfind(14))
        Debug.Print tmp(2)
        SPL = Split(tmp(2), SP(1))
        For i = LBound(SPL) To UBound(SPL)
        SPL2 = Split(Trim(SPL(i)), SP(2))
        Debug.Print SPL2(0)
        .Cells(n, i + 4).Value = SPL2(0)
        Next i

Next n
End With
MsgBox "END!"
End Sub

Private Sub GetMSXML(ByRef objMSXML As Object, ByRef blnErr As Boolean)
'***************************************************
'XML_Parser(MSXML)をObject定義する
'***************************************************
'リロードを伴わずにソース情報取得
'元々はXML形式のデータのやり取りを行うもの
'XML Parser
'JavaScriptではAjax(Asynchronous JavaScript + XML)

On Error Resume Next
    Set objMSXML = CreateObject("MSXML2.XMLHTTP") 'MSXML2Class
    If (Err.Number <> 0) Then
        Set objMSXML = CreateObject("Microsoft.XMLHTTP")
            If (Err.Number <> 0) Then
                Set objMSXML = CreateObject("MSXML.XMLHTTPRequest")
            End If
    End If

On Error GoTo 0
    If objMSXML Is Nothing Then
        blnErr = True
    Else
        blnErr = False
    End If

End Sub

Private Function responseXMLText(strURL As String) As String
'*********************************************
'XML又はTextで取得する
'*********************************************
'*********************************************
'Shift -JISをUnicodeに変換
'*********************************************

Dim objMSXML As Object, blnErr As Boolean
'Dim strURL As String
Dim lngStatus As Long, strStatus As String, strSRC As String
Dim XMLTXT As Byte, blnSJIS As Boolean

'パラメータ
'strURL = "http://www.yahoo.co.jp/"

'パラメータ
'XMLデータ(responseXML) = 0
'TXTデータ(responseText) = 1
XMLTXT = 1

'パラメータ
'Shift-JIS  の場合 = True
'Unicode    の場合 = False
blnSJIS = False

Call GetMSXML(objMSXML, blnErr)

If blnErr = True Then Exit Function

With objMSXML
    .Open "GET", strURL, True
    .send
reTry:
    If .ReadyState <> 4 Then
        DoEvents
        GoTo reTry:
    End If

    lngStatus = .Status
    strStatus = .StatusText
    If (.Status < 200 Or .Status >= 300) Then
        Debug.Print lngStatus & vbTab & strStatus
        Exit Function
    Else
        Debug.Print lngStatus & vbTab & strStatus
    End If

    If XMLTXT = 0 Then
        'XML形式以外はエラーになります。
        strSRC = .responseXML
    Else
        strSRC = .responseText
    End If

    If blnSJIS = True Then
        strSRC = StrConv(.responseBody, vbUnicode)
    Else
        strSRC = .responseText
    End If

'    Debug.Print strSRC
    responseXMLText = strSRC
End With

End Function

JPIA

JP-IA 日本インポートアプリ

シートシート上のURLのソースを取得