レッスン-投稿一覧パソコン仕事５倍塾ポータル

投稿/コメントを表示します。

エクセルマクロVBA「Web連携」

たかちゃんさんの投稿

(投稿ID: 4974)

課題に使う新たなデータを求めスクレイピングをした所、いつもの方法ではBodyが文字化けした為、ADODB.Streamを使用した文字化け対策に挑戦しました。以下の過去コメントを参照しコピペで作成。
備忘録として記念投稿します。
因みに、文字化けしたWebページは、文字コードが「utf-8」でした。

結局、取得したかった数字は全て画像データ？となっていたので、文字化け解消してもデータ取得は不可でした。。。

ADODB.stream使う際は、該当の文字をByte型の配列に入れて、
下にある手順で設定をすれば何とかなる所までは分かりました。(^^)
（Byte型で読み込ませて、設定後、テキスト型で出力。）

'必要なライブラリ:
'[1] Microsoft ActiveX Data Object x.x Library -> 文字コード変更のため(x.x の部分は一番大きいバージョンを選べばまず間違いなくOK)
'[2] Microsoft WinHTTP Services, version 5.1 -> HTTPリクエストをするため

Sub GetRequestSimple1()
    Dim url As String
    url = "ここにhttp://～のURLを記入"

    Dim xh As New WinHttp.WinHttpRequest 'HTTPリクエストを制御するクラスのインスタンスを生成
    xh.Open "GET", url, False
    xh.send
    
    Dim sCode As String
    sCode = xh.Status
    If sCode <> 200 Then 'ステータスコードを調べる
        MsgBox "リクエストに失敗しました" & vbNewLine & sCode
    End If
    
    '普通にボディを取ってくると何故か文字化けする為、ADODB.Streamで文字化け対策
    '因みに上記のWebページの文字コードはutf-8
    '１．ボディを取ってきて、Byte型の配列に入れる
    Dim get_body() As Byte
    get_body = xh.ResponseBody
    
    
    Dim msg1 As String
    Dim msg2 As String
    msg1 = get_body 'Byte()を文字列に変換(msg1 as string だから)
    MsgBox msg1
    
    
    '２．ADODB.streamで、文字化け対策
    Dim ado_stream As New ADODB.Stream
    
    ado_stream.Open
    ado_stream.Position = 0
    ado_stream.Type = 1
    ado_stream.Write get_body
    
    ado_stream.Position = 0
    ado_stream.Type = 2
    ado_stream.Charset = "utf-8"
    msg2 = ado_stream.ReadText
    ado_stream.Close
    
    MsgBox msg2
    
    Range("B2").Value = msg2
    
End Sub

2021/01/04 13:20

田中宏明さんのコメント

(コメントID: 7034)

たかちゃんさん:

なんと文字化け対策もマスターですね。
文字コードを自動的に判定する方法があるようなので、機会があれば実験してみてください。
ADODB.StreamオブジェクトのCharsetプロパティに"_autodetect_all"
を指定します。

Private Function ADODB_autodetect(ByRef xh As Object) As String
    '生の情報は文字化けの可能性があるので、ADOを用いた。
    Dim strm As  ADODB.Stream
    Set strm = New ADODB.Stream

    strm.Open
    strm.Position = 0
    strm.Type = 1 'adTypeBinary
    strm.Write xh.responseBody

    strm.Position = 0
    strm.Type = 2 'adTypeText
    strm.Charset = "_autodetect"
    ADODB_autodetect = strm.ReadText    
    strm.Close
End Function

上記関数をメインから呼び出すための変更

htmlDoc.body.innerHTML = ADODB_autodetect(xh)
'htmlDoc.body.innerHTML = xh.responseText

2021/01/05 07:20

田中宏明さんのコメント

(コメントID: 7035)

たかちゃんさん:

Charsetプロパティに"_autodetect_all"を指定し、実際に動かしてみると「文字化け」だらけの結果になりました。
すみません。忘れてください。

2021/01/05 07:36

たかちゃんさんのコメント

(コメントID: 7036)

田中宏明さん:
いつもありがとうございます。
ADODB.StreamオブジェクトのCharsetプロパテの"_autodetect_all"について気になって調べてみました。（"_autodetect"は、日本語用）
解読先の文字コードが、ANSIとutf-8だと、正常に判別できないらしいです。
きっとそれ以外のWebページだったら上手く動くのだと思います。(^^)
> たかちゃんさん:
>
> Charsetプロパティに"_autodetect_all"を指定し、実際に動かしてみると「文字化け」だらけの結果になりました。
> すみません。忘れてください。
>
>

2021/01/05 10:04

田中宏明さんのコメント

(コメントID: 7062)

たかちゃんさん:

文字化け対策に再チャレンジ。charsetを読み取って条件分岐させました。

Dim nnn As Long
    nnn = InStr(1, xh.responseText, "charset=")
    If nnn > 0 Then
        Select Case True

            Case InStr(1, UCase(Mid(xh.responseText, nnn, 20)), "SHIFT_JIS") > 0
                htmlDoc.body.innerHTML = ADODB_SHIFT_JIS(xh)
        
            Case InStr(1, UCase(Mid(xh.responseText, nnn, 20)), "SHIFT-JIS") > 0
                htmlDoc.body.innerHTML = ADODB_SHIFT_JIS(xh)
                
            Case InStr(1, UCase(Mid(xh.responseText, nnn, 20)), "EUC-JP") > 0
                htmlDoc.body.innerHTML = ADODB_EUC_JP(xh)
                        
            Case InStr(1, UCase(Mid(xh.responseText, nnn, 20)), "UTF-8") > 0
                htmlDoc.body.innerHTML = ADODB_UTF8(xh)
    
            Case Else
                htmlDoc.body.innerHTML = ADODB_autodetect(xh)
        
        End Select
    Else
        htmlDoc.body.innerHTML = xh.responseText
    End If

> ADODB.StreamオブジェクトのCharsetプロパテの"_autodetect_all"について気になって調べてみました。（"_autodetect"は、日本語用）
> 解読先の文字コードが、ANSIとutf-8だと、正常に判別できないらしいです。

2021/01/09 21:06

小川慶一さんのコメント

(コメントID: 7065)

田中宏明さん:

charsetを取得するサンプルを僕も作ってみました。
こんな感じですかね。

Sub get_charset_sample()
    Dim url As String
    url = "https://www.sej.co.jp/products/area.html"
  
    Dim xh As New WinHttp.WinHttpRequest
    xh.Open "GET", url, False
    xh.send
      
    Dim sCode As String
    sCode = xh.Status
    If sCode <> 200 Then
        MsgBox "リクエストに失敗しました" & vbNewLine & sCode
    End If
        
    Dim ct As String
    ct = xh.getResponseHeader("Content-Type") 'text/html; charset=UTF-8 等の文字列を得る
    
    Dim stct() As String
    stct = Split(ct, ";")
    
    Dim c As Long
    Dim charset As String
    For c = LBound(stct) To UBound(stct)
        If InStr(LCase(stct(c)), "charset") Then
            charset = Trim(LCase(Split(stct(c), "=")(1)))
            Debug.Print "charsetは" & charset & "です。"
        End If
    Next
End Sub

2021/01/09 21:38

小川慶一さんのコメント

(コメントID: 7066)

田中宏明さん:

続きです。さらに書くと、たとえばこんな雰囲気で。

Public Sub get_response_text_for_various_webpages()
    get_charset_sample_with_func url:="https://www.sej.co.jp/products/area.html"
    get_charset_sample_with_func url:="https://www.yahoo.co.jp/"
    get_charset_sample_with_func url:="https://www.facebook.com/"
    get_charset_sample_with_func url:="https://www.amazon.co.jp/" '結果は文字化けする理由は未調査
    get_charset_sample_with_func url:="https://www.amazon.com/" '503エラーで終わる。たぶん、リクエストヘッダーを参照してエラーを返しているのであろう
End Sub
Private Sub get_charset_sample_with_func(url As String)
    Dim xh As New WinHttp.WinHttpRequest
    xh.Open "GET", url, False
    xh.send
      
    Dim sCode As String
    sCode = xh.Status
    If sCode <> 200 Then
        MsgBox "リクエストに失敗しました" & vbNewLine & sCode
    End If

    Dim charset As String, response_body As String
    charset = get_charset(xh)
    Debug.Print charset
    Select Case charset
        Case "shift_jis", "euc_jp", "utf-8" '既知のタイプの場合
            response_body = get_response_body_encoded(xh, charset)
        Case Else
            Debug.Print "unknown charset"
            response_body = get_response_body_encoded(xh, "_autodetect") 'ダメ元で autodetect
    End Select
    Debug.Print response_body
End Sub
Private Function get_response_body_encoded(xh As WinHttp.WinHttpRequest, charset As String)
    Dim byte_body() As Byte
    byte_body = xh.responseBody
    
    Dim ado_stream As New ADODB.Stream
    Dim result As String
     
    ado_stream.Open
    ado_stream.Position = 0
    ado_stream.Type = 1
    ado_stream.Write byte_body
     
    ado_stream.Position = 0
    ado_stream.Type = 2
    ado_stream.charset = charset
    result = ado_stream.ReadText
    ado_stream.Close
    get_response_body_encoded = result
End Function
Private Function get_charset(xh As WinHttp.WinHttpRequest)
    Dim ct As String
    ct = xh.getResponseHeader("Content-Type") 'text/html; charset=UTF-8 等の文字列を得る
    
    Dim stct() As String
    stct = Split(ct, ";")
    
    Dim c As Long
    Dim charset As String
    For c = LBound(stct) To UBound(stct)
        If InStr(LCase(stct(c)), "charset") Then
            charset = Trim(LCase(Split(stct(c), "=")(1)))
            get_charset = charset
        End If
    Next
End Function

2021/01/09 22:08

田中宏明さんのコメント

(コメントID: 7067)

小川慶一さん:

私が提案したコードよりもシンプルになっています。恐れ入りました。
> 続きです。さらに書くと、たとえばこんな雰囲気で。

2021/01/10 03:27

小川慶一さんのコメント

(コメントID: 7077)

田中宏明さん:

あとから提案する人の出すコードのほうが、おのずと、洗練されたものになるものです。
ベースがあって、それをリファクタリングしていくわけですので (^_^;

ともあれ、みなさんであれこれやっている間に、かなり汎用性の高い部品になった感じがありますね (^^*

2021/01/11 08:01