最新閲覧日:

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
------------------------------

宜しくお願い致します。

このQ&Aに関連する最新のQ&A

A 回答 (3件)

参照設定をして、以下のコードを実行すると


指定した。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で表示して、たぶん文字コードが
文字化けしていなければ
大丈夫なような気もしますが。
未検証です。
    • good
    • 0
この回答へのお礼

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

お礼日時:2010/01/24 18:42

こんにちは。



>忍者ブログの記事タイトルを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
'-------------------------------------------
    • good
    • 0
この回答へのお礼

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

お礼日時:2010/01/24 18:42

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
にしてみては?
    • good
    • 0
この回答へのお礼

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

お礼日時:2010/01/24 18:41

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

このQ&Aを見た人が検索しているワード


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング

おすすめ情報