現在開いているWebページをエクセル保存したい

お世話になります。

VBAで作成しております。
現在(1)のコードで、「指定したURL」をエクセル保存しているのですが、
「現在開いているページ」エクセル保存したいのですが
どのようにすればよいでしょうか？

お手数ですが何卒宜しくお願いします。

---------(1)-------------
Set g_msg = CreateObject("CDO.Message")
g_msg.CreateMHTMLBody ★指定したURL, 0, "", ""
DoEvents
Set g_stm = g_msg.GetStream
DoEvents
g_stm.SaveToFile ★書き出すファイル名.xls, 2
----------途中までがんばったところ----------
Dim objIEログイン As Object
Set objIEログイン = CreateObject("InternetExplorer.Application")
objIEログイン.Navigate "指定したＵＲＬ"
★★★★★★objIEログインを使用して、エクセルに保存したい★★★

No.1 ベストアンサー 回答者： mitarashi 回答日時： 2013/08/02 23:42

CDOというのは初めて扱ったので、参照設定してみました。

g_stmの型は何？ 調べてみると、ADODB.Streamの様なので、こちらも無駄に参照設定。（As Objectでも十分ですが）
一応動いている様に見えますが、ご希望のものが保存出来ているのかは判断つきかねます。ご参考まで。

Declare Function FindWindow Lib "User32.dll" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

Sub test()
Dim ie As WebBrowser
Dim g_msg As CDO.Message
Dim g_stm As ADODB.Stream

Set ie = getTopIeTab
If ie Is Nothing Then Exit Sub
Set g_msg = New CDO.Message
g_msg.CreateMHTMLBody ie.LocationURL, 0, "", ""
DoEvents
Set g_stm = g_msg.GetStream
DoEvents
g_stm.SaveToFile GetDesktopPath & "\test.txt", 2

Set g_stm = Nothing
Set g_msg = Nothing
Set ie = Nothing
End Sub

'IEの最前面Tabを取得
Function getTopIeTab(Optional matchWord As String) As WebBrowser
Dim hWnd As Long
Dim ie As WebBrowser
Dim targetIe As WebBrowser
Const IEClassName As String = "IEFrame" 'IEのClass名

hWnd = FindWindow(IEClassName, vbNullString)
For Each ie In CreateObject("Shell.Application").Windows()
If hWnd = ie.hWnd Then
ie.StatusBar = True
ie.statusText = CStr(hWnd)

If ie.statusText = CStr(hWnd) Then
If matchWord = "" Then
Set getTopIeTab = ie
ie.statusText = ""
Exit Function
Else
If InStr(ie.LocationURL, matchWord) > 0 Then
Set getTopIeTab = ie
Exit Function
End If
End If
End If
End If
Next ie
Set getTopIeTab = Nothing
End Function

Private Function GetDesktopPath() As String
Dim wScriptHost As Object, strInitDir As String
Set wScriptHost = CreateObject("Wscript.Shell")
GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
Set wScriptHost = Nothing
End Function

この回答へのお礼

誠にありがとうございます。

できました！

お礼日時：2013/08/05 11:37