0

Excel VBA の HTML ページ タイトル

これはかなり古いことは知っていますが、これには問題があります。ユーザーのコンピューター (Office) で Firefox、IE、Safari、Chrome の履歴データを調べて、このコードを使用していないページのタイトルを取得する browswer 履歴パーサーを作成しました。

非表示にする必要があるにもかかわらず、IE からポップアップが表示されます。このページを離れますか、ポップアップをダウンロードしますか、この ActiveX をインストールしますか、またはそれらが表示されたら閉じる必要があります。

それらを抑制したり、VBA から自動的に閉じたりする方法はありますか? 私が手動でそれを行わないと、コンピュータ/Excel は最終的に動作を停止します。これは、いくつかの閉じられていない IE ウィンドウが表示されるか、IE インスタンスを開けなくなるためにエラーが発生するためです。

さらに、IE が私が何も知らないサイトを開いていることを知って、かなり気分が悪くなりました。このオフィスでは、これまで対処しなければならなかったよりも多くの感染症が発生しています。会社のソフトウェアを実行するには IE を使用する必要があります。

これを行うためのより良い方法はありますか、それとも私たちはシステムの犠牲者にすぎませんか. 私は、OOo BASIC と比較して、MS Office VBA で実際にできることの少なさにただただ驚いています。少なくとも基本的な機能 (配列の再次元化、FTP サポート) に関しては。

サルの愛のために、もっと良い方法があればいいのですが。

私も試してみました....

Function fgetMetaTitle(ByVal strURL) As String

Dim stPnt As Long, x As String
Dim oXH As Object
'Get URL's HTML Source
Set oXH = CreateObject("msxml2.xmlhttp")
With oXH
    .Open "get", strURL, False
    .send
    x = .responseText
End With
Set oXH = Nothing
'Parse HTML Source for Title
If InStr(1, UCase(x), "<TITLE>") Then
    stPnt = InStr(1, UCase(x), "<TITLE>") + Len("<TITLE>")
    fgetMetaTitle = Mid(x, stPnt, InStr(stPnt, UCase(x), "</TITLE>") - stPnt)
Else
    fgetMetaTitle = ""
End If

End Function

そしてこれは……。

Function getMetaDescription(ByVal strURL As String) As String

'Requires Early Binding Reference to MSHTML Object Library
Dim html1 As HTMLDocument
Dim html2 As HTMLDocument

Set html1 = New HTMLDocument
Set html2 = html1.createDocumentFromUrl(strURL, "")

Do Until html2.readyState = "complete": DoEvents: Loop

getMetaDescription = html2.getElementsByTagName("meta").Item("Description").Content

Set html2 = Nothing
Set html1 = Nothing

End Function

ネザーは機能しました。

4

1 に答える 1

3

これを試して。MS Excel 2010で問題なく動作します

Dim title As String
Dim objHttp As Object
Set objHttp = CreateObject("MSXML2.ServerXMLHTTP")
objHttp.Open "GET", "http://www.google.com/", False
objHttp.Send ""

title = objHttp.ResponseText

If InStr(1, UCase(title), "<TITLE>") Then
    title = Mid(title, InStr(1, UCase(title), "<TITLE>") + Len("<TITLE>"))
    title = Mid(title, 1, InStr(1, UCase(title), "</TITLE>") - 1)
Else
    title = ""
End If

MsgBox title
于 2013-01-25T02:29:09.763 に答える