シート シート上のURLのソースを取得
※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。
※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。
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 |