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

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

エクセルマクロ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

５倍速！メールマガジン

このメールマガジンの詳細はこちら

受講生の声

たった1ヶ月で人生が劇的に変わりました

佐藤信さん

役員クラスの方から高い評価を受けるようになりました。

佐賀県 - 岩本徹さん

今までまったく知らなかったショートカットキーを使いまくっています。

東京都 - 鷹觜慶さん

年齢60才間近、営業で外回りの時間が多い私でも退社時間が1-2時間程度早くなりました。

東京都 - 宗内隆明さん

受講前もすでにパソコン得意でしたが、そんな私でも受講して本当に良かったと思えた講座です。

東京都 - 佐伯とも子さん

ここまで包括的に仕事に役立つ深い学びを受けれた講座は初めてでした

東京都 - 飯田倫子さん

受講生の声一覧へ

サイト運営者紹介

小川慶一講師/教材/システム開発者紹介

この学習サイトの教材制作、サポート、システム開発をすべてやっています。

より詳しい紹介はこちら