エクセルでURLからタイトルのみを抽出する方法

質問

URLからタイトルを抽出するマクロについて教えて下さい。
忍者ブログの記事タイトルをURLから抽出しようとしたのですが
文字化けしてしまい全く分かりません。
他のサイトやブログだと普通に抽出出来るのですが・・・
文字コード？か何かだと思うのですが、原因が分かりません。
ちなみに以下のマクロは、ネット上で検索して見つけたものを
そのままコピーして使用しています。

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Public Sub ReadTitle()
Dim url As Range
Dim Http, buf As String

Set Http = CreateObject("MSXML2.XMLHTTP")
Set url = Range("A3")
Do While (url.Value <> "")
Http.Open "GET", url.Value, False
Http.Send
buf = StrConv(Http.ResponseBody, vbUnicode)
'msgbox buf
url.Offset(0, 1).Value = getTitle(buf)
Set url = url.Offset(1, 0)
Loop
Set Http = Nothing
End Sub

Private Function getTitle(buf As String) As String
Dim pos1 As Long, pos2 As Long

pos1 = InStr(1, buf, "<title>")
If pos1 = 0 Then
pos1 = InStr(1, buf, "<TITLE>")
If pos1 = 0 Then
getTitle = ""
Exit Function
Else
pos2 = InStr(pos1 + 7, buf, "</TITLE>")
End If
Else
pos2 = InStr(pos1 + 7, buf, "</title>")
End If
getTitle = Mid(buf, pos1 + 7, pos2 - pos1 - 7)
End Function
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

宜しくお願い致します。

回答No.1

hotosys · ベストアンサー

utf-8みたいなので
>buf = StrConv(Http.ResponseBody, vbUnicode)
を
With CreateObject("ADODB.Stream")
.Open
.Type = 2 'adTypeText
.Charset = "unicode"
.Writetext Http.ResponseBody
.Position = 0
.Charset = "utf-8"
buf = .ReadText()
.Close
End With
にしてみては？

お礼

一発解決出来ました。
ありがとうございました！

回答No.3

tom11

参照設定をして、以下のコードを実行すると
指定した。URLで、IEが起動して、
URLのタイトルがエクセルのイミディエイトウィンドに出ます。

Dim ie As New InternetExplorer
Dim dc As HTMLDocument

ie.Navigate "http://oshiete1.goo.ne.jp/qa5617517.html"

ie.Visible = True

Do While ((ie.Busy = True) Or (ie.ReadyState <> READYSTATE_COMPLETE))

DoEvents

Loop

Set dc = ie.Document

Debug.Print dc.Title

Set ie = Nothing

******
実行結果

エクセルでURLからタイトルのみを抽出する方法 - 教えて！goo

********
文字コードは、検証していませんが。
ieで表示して、たぶん文字コードが
文字化けしていなければ
大丈夫なような気もしますが。
未検証です。

お礼

皆様のおかげで解決することが出来ました。
お時間を割いて頂きありがとうございました。

回答No.2

Wendy02

こんにちは。

>忍者ブログの記事タイトルをURLから抽出しようとしたのですが

こんな感じでいかがですか？
>buf = StrConv(Http.ResponseBody, vbUnicode)
ここがへんかもしれません。

以下は、必要でしたら、サブルーチン・プロシージャに分けてください。
'-------------------------------------------
Public Sub ReadTitleR()
Dim stRng As Range
Dim buf As String, ar As Variant
Dim i As Long
With CreateObject("MSXML2.XMLHTTP")
　　Set stRng = Range("A3")
　　For i = 1 To Cells(Rows.Count, stRng.Column).End(xlUp).Row
　　　　If StrConv(stRng.Cells(i, 1).Value, vbLowerCase) Like "http://??*" Then
　　　　　　.Open "GET", stRng.Cells(i, 1).Value, False
　　　　　　On Error Resume Next
　　　　　　.Send
　　　　　　On Error GoTo 0
　　　　　　buf = .ResponseText
　　　　　　If .Status >= 200 And .Status < 300 And buf <> "" Then
　　　　　　　　ar = Split(buf, "title>")
　　　　　　　　stRng.Cells(i, 2).Value = Mid(ar(1), 1, Len(ar(1)) - 2)
　　　　　　End If
　　　　End If
　　Next i
End With
End Sub
'-------------------------------------------

お礼

皆様のおかげで解決することが出来ました。
お時間を割いて頂きありがとうございました。