• ベストアンサー
  • 困ってます

サイトタイトルの中に、指定した語句があれば○

  • 質問No.9633125
  • 閲覧数99
  • ありがとう数1
  • 気になる数0
  • 回答数2
  • コメント数0

お礼率 4% (25/505)

下記は、URL先のソースの中に、
指定した語句があれば、○を付けるマクロです。

このURL先のソース、全てを対象にするのではなく、
<title></title>、つまりサイトタイトルの中に、
指定した語句があれば、○を付けるというように制限して調べたいです。

・下記のマクロ
URL先のソース全体の中に、指定した語句があれば○

・希望のマクロ
<title></title>(サイトタイトル)の中に、指定した語句があれば○

これは、どの部分を修正、追加すればできるようになるでしょうか?

また、「指定した語句」の他にも、「指定した語句2」「指定した語句3」、
つまり、<title></title>の中に、「●●」「▲▲」「■■」のどれかが含まれていたら、
隣のセルに○を付ける。という風にしたいです。

ソース全体で調べるなら、
nRtn = InStr(sHtml, "●●") + InStr(sHtml, "▲▲") + InStr(sHtml, "■■")
で出来ると思うのですが、制限させて調べる場合は、
どのような記述になるでしょうか?
よろしくお願いいたします。


Sub 指定した語句()
'!!!! [Microsoft XML v6.0] に参照設定すること
Dim xHttp As IServerXMLHTTPRequest
Dim myErr_Number As Long, myErr_Description As String
Set xHttp = CreateObject("MSXML2.ServerXMLHTTP")
Dim aCell As Range
R = 1
For Each aCell In Selection.Columns(1).Cells '選択セルの1列目がURL
Application.Goto aCell '対象URLの列にジャンプ表示
DoEvents
sUrl = aCell.Value
If sUrl <> "" Then
xHttp.Open "GET", sUrl, True
xHttp.setOption SXH_OPTION_IGNORE_SERVER_SSL_CERT_ERROR_FLAGS, _
SXH_SERVER_CERT_IGNORE_ALL_SERVER_ERRORS ' SSL関係のエラーを無視
On Error Resume Next
xHttp.send
If xHttp.readyState <> 4 Then
xHttp.waitForResponse 5 '5秒まってだめならタイムアウト
End If
If xHttp.readyState <> 4 Then Err.Raise 1004, , "タイムアウト"
myErr_Number = Err.Number
myErr_Description = Err.Description
On Error GoTo 0
If myErr_Number = 0 Then
sHtml = xHttp.responseText
nRtn = InStr(sHtml, "指定した語句")
If nRtn = 0 Then
aCell.Offset(, 1).Value = "--"
Else
aCell.Offset(, 1).Value = "○"
End If
Else
aCell.Offset(, 1).Value = myErr_Description ' エラー時はエラー内容を表示
End If
DoEvents
End If
Next
Set xHttp = Nothing
End Sub

質問者が選んだベストアンサー

  • 回答No.2
  • ベストアンサー

ベストアンサー率 61% (224/364)

他カテゴリのカテゴリマスター
No1 です。修正します。

Function GetTitle(iHTML As String) As String
 Const SKey = "<title>"
 Const EKey = "</title>"
 Dim sPos As Long
 Dim ePos As Long
 sPos = InStr(UCase(iHTML), UCase(SKey))
 ePos = InStr(UCase(iHTML), UCase(EKey))
 GetTitle = ""
 If ((sPos > 0) And (ePos > 0)) Then
  GetTitle = Mid(iHTML, sPos + Len(SKey), ePos - sPos - Len(SKey))
 End If
 'Debug.Print
End Function

このほうが丈夫です。<m(__)m>

その他の回答 (全1件)

  • 回答No.1

ベストアンサー率 61% (224/364)

他カテゴリのカテゴリマスター
力技ですが...

Function GetTitle(iHTML As String) As String
 Const SKey = "<title>"
 Const EKey = "</title>"
 Dim sPos As Long
 Dim ePos As Long
 sPos = InStr(UCase(iHTML), UCase(SKey))
 ePos = InStr(UCase(iHTML), UCase(EKey))
 GetTitle = Mid(iHTML, sPos + Len(SKey), ePos - sPos - Len(SKey))
 'Debug.Print GetTitle
End Function

↑な関数を仕込み
ポストされたコードを↓のように直す対応はいかがでしょうか?

   'ここまで省略
   On Error GoTo 0
   If myErr_Number = 0 Then
    'sHtml = xHttp.responseText     '<<これを
    sHtml = GetTitle(xHttp.responseText) '<<これに修正
    nRtn = InStr(sHtml, "指定した語句")
    If nRtn = 0 Then
     aCell.Offset(, 1).Value = "--"
    Else
     aCell.Offset(, 1).Value = "○"
    End If
   Else
    aCell.Offset(, 1).Value = myErr_Description '
   End If
   DoEvents
   'これ以降省略
結果を報告する
このQ&Aにはまだコメントがありません。
あなたの思ったこと、知っていることをここにコメントしてみましょう。
AIエージェント「あい」

こんにちは。AIエージェントの「あい」です。
あなたの悩みに、OKWAVE 3,600万件のQ&Aを分析して最適な回答をご提案します。

関連するQ&A

その他の関連するQ&Aをキーワードで探す

ピックアップ

ページ先頭へ