(7)HTTPオブジェクトで取得のＨＴＭＬソースの使用・修正・再保存例
久しぶりにホームページをつくりましたが、ページ内に目次のテーブルを設定する方式にしたので多数のHTML
ファイルに同じテーブルタグを挿入する必要があり、マニュアルで1ファイルずつ挿入は面倒なので、マクロを
作成しました。本マクロを使ったし新規開設したHPは、ガンバレ御嶽海です。

また、PART4でWebページを操作するテクニックを記載しましたが、HTMLソースをそのまま使用する例が無いの
のでここに追加掲載します。


[1]ＨＴＭＬソースへテーブルタグを挿入例
実際のマクロは、KIテーブル挿入(KIinput-table)　からダウンロードできます。
ここにマクロ説明を記載した関係で、マクロに保護プロテクトを掛けて無いので、詳細は実際の「KIテーブル挿入」
マクロを参照して下さい。

下図は3個のHTMLファイルの表示例ですが、赤で囲った同じ「タイトルと目次テーブル」を挿入した例です。


下記「Web表示」プロシージャで、UserForm1.web1（web1は設定したWebBrowser コントロール)上にHTML
ファイルを表示する。実際はメモリー上に表示で、UserForm1.Show 0のステートメントはコメントにしてあるので
（デバッグ用にあり）Webページは表示されない。画像表示など無しで実効速度が速くなっています。
Sub Web表示()
ダイアログ表示
    With UserForm1
        .Caption = "HTMLファイルへテーブル挿入" & va
    End With
        urla = ThisWorkbook.Worksheets("操作ページ").Cells(zf, 1)
 
        UserForm1.web1.Navigate urla
        enchk = 0
            Call 読込終了確認
   ' UserForm1.Show 0
End Sub
----------------------------------------------------------------
Sub 読込終了確認()
timck = Timer + 4
Do
If enchk = 1 Then: Exit Do
    If Timer > timck Then: Exit Do
    DoEvents
Loop
 
If enchk = 0 Then
    MsgBox "Webページの取り込みに失敗しました。"
End If
End Sub

以下のユーザーフォーム　コードウインドウに記載のプロシージャで、RULを取得し、取得したURL（変数urlb）
からソースを取り出すことが出来ます。
ユーザーフォーム　コードウインドウ
Private Sub web1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
    urlb = URL
    enchk = 1
End Sub

以下のプロシージャで、「HTMLソース」シートに取得したソースを貼り付けます。
なお改行としChr(10)で貼り付け行を変えます。Chr(10)は組み込み定数vbCrLfでも良いと思ったがダメだった。

(oHttp.responseBody, 64) の引数64は、システムの既定のコードページを使用して文字列をUnicodeに変換
します。これで文字化けを直しますが、直らない場合は、その下に記述の oHttp.responsetextで実行して下さい。
Sub ソース取り込み()
貼り付けシート作成
    For Each sheet_name In Worksheets
        If sheet_name.Name = "HTMLソース" Then
            Application.DisplayAlerts = False
                Worksheets("HTMLソース").Delete
            Application.DisplayAlerts = True
            Exit For
         End If
    Next
    Sheets.Add.Name = "HTMLソース"
    Worksheets("HTMLソース").Move After:=Sheets(Sheets.Count)
 
ソース取込
Set oHttp = CreateObject("Microsoft.XMLHTTP")
    oHttp.Open "GET", urlb, False
    oHttp.Send
 
   dathaml = StrConv(oHttp.responseBody, 64)   '文字化けの場合下記に変える
dathaml = oHttp.responsetext
 
Worksheets("HTMLソース").Select
    tmp = Split(dathaml, Chr(10))
For i = 0 To UBound(tmp)
    Cells(i + 1, 1) = tmp(i)
Next
    Set oHttp = Nothing
   'UserForm1.Hide
復帰削除
     Cells.Replace What:=Chr(13), Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Range("A1").Select
 
End Sub

以下のプロシージャで、HTMLソースシートの所定の場所に、事前に取得してあるテーブルタグを挿入する。
Sub テーブル挿入()
If Val(Application.Version) > 11 Then
    ThisWorkbook.Sheets("操作ページ").Select
        For Each zu In ActiveSheet.Shapes
           shname = zu.Name
           If InStr(1, shname, "Text", 1) > 0 Then
                shname1 = zu.Name
           End If
    Next
        Set ObjText1 = ActiveSheet.Shapes(shname1)
        ddd = ObjText1.TextFrame.Characters().Text
Else
　　’Execl2003以前は変数へ代入値255以下の制限があり細工が必要（記述省略）
End If
 
Sheets("HTMLソース").Select
endr = Cells(10000, 1).End(xlUp).Row
 
For i = 1 To endr
    stsu = InStr(Cells(i, 1), "リンクテーブル注入")
 
    If stsu > 0 Then
        If InStr(Cells(i + 1, 1), "リンクテーブルEND") = 0 Then
           MsgBox "テーブル挿入済み"
           sumi = 1
           Exit Sub
        End If
 
        cnt = cnt + 1
        sts = 1
        ia = i + 1
         Do
            ens = InStr(sts, ddd, Chr(10))
             If ens = 0 Then
                    Exit Do
            End If
 
            d1 = Mid(ddd, sts, ens - sts)
 
            '挿入行を空ける
                Rows(ia).Insert Shift:=xlDown
                Cells(ia, 1) = "'" & d1
                ia = ia + 1
                sts = ens + 1
         Loop
      Exit For
    End If
Next
 
Call テーブル色付け
 
ファイル名の指定
n1 = InStrRev(urlb, "\")
n2 = InStrRev(urlb, ".")
      dai = Mid(urlb, n1 + 1, n2 - n1 - 1)
 
End Sub

以下のプロシージャで、修正したHTMLファイルを保存する。保存場所の指定が無い場合は上書保存。
Sub ファイル保存()
If ThisWorkbook.Worksheets("操作ページ").Cells(3, 12) = "" Then
    phn = Replace(urlb, dai & ".html", "")                       '上書き保存
Else
    phn = ThisWorkbook.Worksheets("操作ページ").Cells(3, 12)     '指定フォルダ
End If
 
    Worksheets("HTMLソース").Activate
    endr = Cells(10000, 1).End(xlUp).Row
 
    With ActiveSheet
        endr = Cells(10000, 1).End(xlUp).Row
        Open phn & dai & ".html" For Output As #1
 
        For i = 1 To endr
            gyou = .Cells(i, 1)
            Print #1, gyou
        Next
        Close #1
    End With
End Sub



[2]取得したＨＴＭＬソースから必要データ取得例
実際のマクロは、KI力士番号取得(KIrikisino-get)　からダウンロードできます。
ここにマクロ説明を記載した関係で、マクロに保護プロテクトを掛けて無いので、詳細は実際の「KIテーブル挿入」
マクロを参照して下さい。本マクロ自体は特定のWebページからと既定のデータを抜き取るマクロであり汎用性
はありませんが、必要に応じて改造して使用して下さい。

下図HTMLソースの、赤丸印3箇所のデータを取得して、Excelシートに貼り付けるマクロです。


関取番号シートに、A列力士名、B列ポロフィル用番号、C列顔写真用番号　をExcelシートに取り込んだ例。





下記はメインのプロシージャで全体を制御する。取得のURLも固定ですが、＝2で十両の番付表です。
読み込み終了の確認はしていますが、前述[1]と同様にWeｂページは表示してないので、マクロは高速です。
Sub 番号取得実行()
ダイアログ表示
    UserForm1.Caption = "力士番号取得" & va
 
    urla = "http://www.sumo.or.jp/honbasho/banzuke/index?rank=1"
 
前データ削除
    Sheets("関取番号").Select
    Cells.ClearContents
IEへ表示
        UserForm1.web1.Navigate urla
        enchk = 0
            Call 読込終了確認　’(7)[1]と同じ
 
        ia = 1
            Call ソース取り込み
            Call 番号貼付け
        Sheets("関取番号").Select
   End Sub


Yahooからダウンロードですが、responsetext です。
Sub ソース取り込み()
 
-----下記のみ(7)[1]と異なります----
   dathaml = StrConv(oHttp.responseBody, 64)
dathaml = oHttp.responsetext                  '文字化けの場合上記に変える
 
End Sub

下記マクロは、力士名・顔写真番号・プロフィール番号の3点を取得し、関取番号シートに貼り付けています。
Sub 番号貼付け()
 
Sheets("HTMLソース").Select
endr = Cells(10000, 1).End(xlUp).Row
 
For i = 1 To endr
    kensaku = InStr(Cells(i, 1), "profile")
    If kensaku > 0 Then
        datr = Cells(i, 1)
            stss = InStr(1, datr, "id=")
    '力士No
        rikno = Mid(datr, stss + 3, 4)
            ecds1 = InStr(stss, datr, ">")
            ecds2 = InStr(ecds1, datr, "&#")
        namae = Mid(datr, ecds1 + 1, ecds2 - 1 - ecds1)
 
        Worksheets("関取番号").Cells(ia, 1) = namae
        Worksheets("関取番号").Cells(ia, 2) = Val(rikno)
 
    '顔写真No
        datr1 = Cells(i - 4, 1)
            stss = InStr(1, datr1, "60/")
        kaono = Mid(datr1, stss + 3, 8)
            Worksheets("関取番号").Cells(ia, 3) = kaono
        ia = ia + 1
    End If
Next
End Sub



[3]自分のPCにあるＨＴＭＬファイルのタグ修正例
自分の出しているHPで、HTMLタグのスタイルシートの「・・・｝;・・・　」ステータスが、IE8からIE11に更新したら、
不具合が発生しリンク箇所の色付けが上手く行かなくなりました。調べたら自分のミスで、「・・・;｝・・・」と記述
が正解だった。多数のHTMLファイルで同じミスがあり、ファイルを探し不具合箇所を直すのは大変であり、
自分のPC上の指定したフォルダの全ＨＴＭＬファイルを自動的にチェックし訂正するマクロを作りました。

HTMLソースのみ取得し、訂正・保存であり、前述[1]項と基本的には同じマクロですが、こちらを後から作って
関係で一部改善してあります。
なお、ソース公開は[1][2]と同じで、KIhtmlタグ修正(KIhtml-change)　からダウンロードできます。
【修正前例】<STYLE>A{text-decoration:none;color:#000000};A:ACTIVE{color:#000000};A・・・・
 
【修正後例】<STYLE>A{text-decoration:none;color:#000000;}A:ACTIVE{color:#000000;}A・・・・

下記「Web表示」プロシージャのWebの取り込み終了の確認を、変数urlbにURL代入済みで行っている件が、
[1]項からの改善箇所で、[1]項の変数enchkは必要のない変数だった。
Sub Web表示()
ダイアログ表示
    With UserForm1
        .Caption = "HTMLタグ修正" & va
    End With
        urla = ThisWorkbook.Worksheets("操作ページ").Cells(zf, 1)
 
        UserForm1.web1.Navigate urla
        urlb = ""
            Call 読込終了確認
       bbase = ActiveWindow.Caption
End Sub

以下のユーザーフォーム　コードウインドウに記載のプロシージャで、RULを取得し、取得したURL（変数urlb）
からソースを取り出すことが出来ます。
ユーザーフォーム　コードウインドウ
Private Sub web1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
    urlb = URL
End Sub

下記「 ソース取り込み」プロシージャは、[1]とほぼ同じですが、取得したデータからChr(13)【復帰】、
Chr(10)【改行】を削除しました。これはシートに取り込んだデータをHTMLタグとして保存する時、ソースが2段
空白になるケースがあり、保存の時改行または復帰が2個記入される不具合を防止する為です。
Sub ソース取り込み()
Application.ScreenUpdating = False
貼り付けシート作成
 
ソース取込
    Set oHttp = Nothing
------------　以上は[1]と同じです　-------
 
 '復帰削除
     Cells.Replace What:=Chr(13), Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Range("A1").Select
 '改行削除
     Cells.Replace What:=Chr(10), Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Range("A1").Select
 
End Sub

下記「タグ修正」プロシージャは、[1]の「テーブル挿入」プロシージャに当たる部分で、こちらはデータ挿入でなく
データを1行書き換えます。具体的には変数「 mae」のキーワード文字を全行チェックし、一致する行があったら
変数「 ato」の内容に書き換えます。
Sub タグ修正()
Dim mae As String  '訂正キーワード文字
Dim ato As String  '訂正キーワード文字
Dim sts As Integer   '
Dim ia As Integer    '注入END行
Dim stsu As Integer  'スタート文字数
 
sumi = 0
    mae = Worksheets("操作ページ").Cells(11, 4)
    ato = Worksheets("操作ページ").Cells(15, 4)
 
Sheets("HTMLソース").Select
endr = Cells(10000, 1).End(xlUp).Row
 
For i = 1 To endr
    stsu = InStr(Cells(i, 1), mae)
 
    If stsu > 0 Then
        Cells(i, 1) = ato
        sumi = 1
        cnt = cnt + 1
    End If
Next
 
ファイル名の指定
n1 = InStrRev(urlb, "\")
n2 = InStrRev(urlb, ".")
      dai = Mid(urlb, n1 + 1, n2 - n1 - 1)
 
End Sub

下記「ファイル保存」プロシージャは、[1]の「ファイル保存」プロシージャを大幅に変えました。どちらの方法でも
Webページに表示する結果は同じですが、[1]のソースをダイレクトに書き換える方法が簡単で良いが、保存した、
ソースをメモ帳に表示して見ると空白行が余分に入る場合があったり、メモ帳に開いたソースを上書き保存す
ると改行のタグがなくなっている等、 Print #1でシートのデータを1行ずつシーケンシャルにファイルのデータを
書き換えますが、各行のセルデータの最後に改行Chr（10）が書き込まれないケースが問題のようです。

改善方法を色々実験したが上手い方法が見つからなかったので、最終的には、一度拡張子テキストファイル
（スペース区切り）の拡張子prnで保存し、そのprnを強制的にhtmlに変更する方法にしました。
Sub ファイル保存()
Application.ScreenUpdating = True
 
If ThisWorkbook.Worksheets("操作ページ").Cells(3, 7) = "" Then
    uwa = "上書き"
    phn = Replace(urlb, dai & ".html", "")                       '上書き保存
Else
    phn = ThisWorkbook.Worksheets("操作ページ").Cells(3, 7)     '指定フォルダ
End If
 
------- HTMLタグ保存用ブック　---------------------
Application.ScreenUpdating = False
Application.CopyObjectsWithCells = True
 
     Windows(bbase).Activate
     Sheets("HTMLソース").Select
     Cells.Select
     Selection.Copy
 
HTMLを貼るブック作成
    Workbooks.Add
    Range("A1").Select
    ActiveSheet.Paste
    Range("A2").Select
       bname = ActiveWindow.Caption
 
        Application.CutCopyMode = False
        Range("A3").Select
 
------　HTMLファイル保存　------------------------
 
    Windows(bname).Activate
    Sheets("Sheet1").Select
 
 
保存
Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=phn & dai & ".prn", FileFormat _
        :=xlTextPrinter, CreateBackup:=False
    Application.DisplayAlerts = True

ダミ−のブックを閉じる
    Application.DisplayAlerts = False
        Application.Windows(dai & ".prn").Activate
        ActiveWorkbook.Close
    Application.DisplayAlerts = True

ファイル名変更
       fff = Dir(phn & dai & ".html")
       If fff = "" Then
            Name phn & dai & ".prn" As phn & "\" & dai & ".html"
       Else
            Kill phn & dai & ".html"
            Name phn & dai & ".prn" As phn & "\" & dai & ".html"
       End If
元ブックを表示
        Windows(bbase).Activate
        Range("A1").Select
         Application.CutCopyMode = False
        ActiveWindow.WindowState = xlMaximized
 
End Sub
 


【戻る】　　　　【Top画面】　　　【HPへ】