[[20140712092251]]　『mht形式でのWEBページ保存』（田吾作）　ページの最後に飛ぶ

『mht形式でのWEBページ保存』（田吾作）

おはようございます。よろしくお願いいたします。

 ↓を参考に現在IEで表示しているWEBページをmht形式で保存するコードをほとんどコピーですが作成
 しました。

 EXCEL　VBAでWEBページ保存2
http://oshiete.goo.ne.jp/qa/4253824.html

 2008/08/18 00:46のKenKen_SPさんの↓sample2を流用しました。

 Sub sample2()

 　　' // この方法でも完全ではないが、実用上はほぼ問題ないか。。な

 　　Const cdoSuppressNone　　　 As Long = 0
  　　Const adSaveCreateOverWrite As Long = 2

  　　Dim msg　　　　 As Object ' // CDO.Message
  　　Dim stm　　　　 As Object ' // ADODB.Stream
  　　Dim url　　　　 As String
  　　Dim outFilename As String

  　　url = "http://www.goo.ne.jp/" 'ここを変える
  　　outFilename = ThisWorkbook.Path & "\sample.mht"

  　　Set msg = CreateObject("CDO.Message")
  　　msg.CreateMHTMLBody url, cdoSuppressNone, "", ""
  　　Set stm = msg.GetStream
  　　stm.SaveToFile outFilename, adSaveCreateOverWrite
  　　stm.Close

 　　Set stm = Nothing
  　　Set msg = Nothing

 End Sub

 sample2のURLを特定のものに変えるだけだったら問題なく
 保存でき、保存したものも元のWEBページと同じものが表示
 されます。

 しかし、下記のようにFunction化して実行すると画像のリンクが切れたり
 フォーマットが崩れます。マクロの実行も時間がかかったりします。
 保存したmhtファイルを開くのも時間がかかります。

 「mhtsave」FunctionはURLの部分とoutFilenameの部分以外は変更していま
 せん。

 どのように書き換えたらいいでしょうか？
 ご指導お願いいたします。

 Sub test()
  Dim mywindow As Object
  Dim w As Object
  Dim myurl As String
  Dim myttl As String
   Set mywindow = CreateObject("Shell.Application")
   For Each w In mywindow.Windows
    If UCase(Right(w.FullName, 12)) = "IEXPLORE.EXE" Then 'IEだったら
       myurl = w.LocationURL 'IEからURL取得
       myttl = w.document.Title 'IEからタイトル取得
       Call mhtsave(myurl, myttl) 'mhtsave呼び出し
    End If
   Next
   Set mywindow = Nothing
 End Sub

 Function mhtsave(ByVal myurl As String, myttl As String)
  Const cdoSuppressNone       As Long = 0
  Const adSaveCreateOverWrite As Long = 2
  Dim msg         As Object ' // CDO.Message
  Dim stm         As Object ' // ADODB.Stream
  Dim url         As String
  Dim outFilename As String
   url = myurl
   outFilename = CreateObject("WScript.Shell").SpecialFolders("Desktop") _
    & "\" & myttl & ".mht"
   Set msg = CreateObject("CDO.Message")
   msg.CreateMHTMLBody url, cdoSuppressNone, "", ""
   Set stm = msg.GetStream
   stm.SaveToFile outFilename, adSaveCreateOverWrite
   stm.Close
   Set stm = Nothing
   Set msg = Nothing
 End Function

 ※11:22追記
 関係あるかわかりませんが、Vistaは32ビット、IEは9です。

 ※7/13 10:23追記

 ↓のように一旦テキストボックスにURL、タイトルを取得してIEを閉じた後10秒ほどおいて
 mht保存するコードを実行しても同様にだめでした。

 Private Sub CommandButton3_Click()
  Dim MyWindow As Object
  Dim w As Object
  Dim myurl As String
  Dim myttl As String
   Set MyWindow = CreateObject("Shell.Application")
   For Each w In MyWindow.Windows
    If UCase(Right(w.FullName, 12)) = "IEXPLORE.EXE" Then
       Me.TextBox1.Value = w.LocationURL
       Me.TextBox2.Value = w.document.Title
    End If
   Next
   Set MyWindow = Nothing
 End Sub

 Private Sub CommandButton4_Click()
  Dim myurl As String
  Dim myttl As String
   myurl = Me.TextBox1.Value
   If myurl = "" Then Exit Sub
   myttl = Me.TextBox2.Value
   If myttl = "" Then myttl = Format(Now, "yymmdd_hhmmss")
   Call mhtsave(myurl, myttl)
 End Sub

 そこでIEのURLを取得してテキストボックスのURLをコピーしてクリップボードに格納
 しておきブックを手動で閉じて再度ブックを開いてテキストボックスにURLを貼り付け
 てからmht保存を実行したらフォーマットが崩れないで保存出来ました。
 このときは元のIEは開いたままでもＯＫでした。

 そこで、IE取得した時のエクセルが悪さしてるのかな、と思い↓のようにVBSにしてみ
 ましたがやはりダメでした。

  Dim MyWindow
  Dim w
  Dim myurl
  Dim myttl
   Set MyWindow = CreateObject("Shell.Application")
   For Each w In MyWindow.Windows
    If UCase(Right(w.FullName, 12)) = "IEXPLORE.EXE" Then
       myurl = w.LocationURL
       myttl = w.document.Title
       call mhtsave(myurl,myttl)
    End If
   Next
   Set MyWindow = Nothing
 wscript.quit

 Function mhtsave(ByVal myurl, myttl)
  Const cdoSuppressNone = 0
  Const adSaveCreateOverWrite = 2
  Dim msg 'As Object ' // CDO.Message
  Dim stm 'As Object ' // ADODB.Stream
  Dim url 'As String
  Dim outFilename 'As String
   url = myurl
   outFilename = CreateObject("WScript.Shell").SpecialFolders("Desktop") _
    & "\" & myttl & ".mht"
   Set msg = CreateObject("CDO.Message")
   msg.CreateMHTMLBody url, cdoSuppressNone, "", ""
   Set stm = msg.GetStream
   stm.SaveToFile outFilename, adSaveCreateOverWrite
   stm.Close
   Set stm = Nothing
   Set msg = Nothing
 End Function

＜使用 Excel：Excel2007、使用 OS：WindowsVista ＞

 フォーマットが崩れるのはフレームを使っているWEBページのようです。

 エクセルの学校で試したら崩れませんでした。
（田吾作） 2014/07/13(日) 18:17

 ＷＥＢページによってはうまく保存出来ない理由が少しづつ
 分かってきました。

 フレーム云々ではなく、ＷＥＢページのタイトルによるみたいです。
 保存時にＷＥＢページのタイトルではなく、適当に付けた名前で保存
 したらmhtファイルがきちんと開けました。

 おそらく、なのですが、WEBページのタイトルの見た目スペースに
 なっている部分が悪さしているようです。タイトルのスペース部分
 と感嘆符部分を削除して保存したらうまくいきました。

 ファイルの保存がうまくいってなかったのではなく、保存したファ
 イルを開くときにファイル名に不適切？な文字が入っているとうま
 く開けないようです。

 保存ファイル名を編集することで対応することにしました。
 ご検討いただいた方がいらっしゃいましたらありがとうございま
 した。
（田吾作） 2014/07/14(月) 00:38

コメント返信：

[ 一覧(最新更新順) ]

[[20140712092251]] 『mht形式でのWEBページ保存』（田吾作） ページの最後に飛ぶ

[[20140712092251]]　『mht形式でのWEBページ保存』（田吾作）　ページの最後に飛ぶ