tagCANDY CGI VBレスキュー(花ちゃん) - 指定のHTMLファイルの全体を画像(bmp・gif・png)として保存(VB6.0) - Visual Basic 6.0 VB2005 VB2010
VB2005用トップページへVBレスキュー(花ちゃん)のトップページVB6.0用のトップページ
指定のHTMLファイルの全体を画像(bmp・gif・png)として保存(VB6.0)
元に戻る スレッド一覧へ 記事閲覧
このページ内の検索ができます。(AND 検索や OR 検索のような複数のキーワードによる検索はできません。)

指定のHTMLファイルの全体を画像(bmp・gif・png)として保存(VB6.0) [No.250の個別表示]
     サンプル投稿用掲示板  VB2005 〜 用トップページ  VB6.0 用 トップページ
日時: 2010/01/25 23:23
名前: 花ちゃん

***********************************************************************************
* カテゴリー:[インターネット][描画・画像][ファイル入出力][メッセージ]       *
* キーワード:GIF形式に変換,PNG形式で保存,モードレスメッセージボックス,WebBrowser *
***********************************************************************************

※ 何度か修正を行っておりますので、上記の日時を確認して最新のものをお使い下さい。

記事No:14403 / タイトル:WebBrowserをbmp出力 で質問があったのですが、詳しい目的や
環境等が書いていない事もあって、適当な怪答をしていたのですが、OleDraw で領域さえ
指定してやれば、隠れている部分の取得も可能と知り自分でも作って見る事にしました。
OleDraw については、ずいぶん以前に、K.J.K さんに教えてもらって、主に MSChart で
よく使ってはいたのですが、その事もあって、クライアント領域のような見える範囲でないと
だめだと言う先入観があったものだから...。

ただ、画像として取得するだけでは面白くないので、取得した画像を GIF や PNG 形式でも
保存できるようにして見ました。(GIF 形式の場合は、BPM → GIF に変換ですが。)

主な機能の紹介
1.指定のURLのHTMLファイルの表示内容(スクロールしないと見えない部分も含む)を
  画像として取得し、ピクチャーボックスに表示
2.ピクチャーボックスに表示された画像をファイルに保存(通常のbmp形式で)  
3.フリーソフトのGiFFY.exe を使って2.で保存したファイルをGIF形式に変換して保存
4.フリーソフトの TransG32.DLL を使って、PNG 形式で高圧縮で保存
5.表示中の画像及び保存前の画像が全て確認できるように、マウスのドラッグで移動して
  見えない部分も確認できるように設定
6.自由なサイズで取得できるように、取得中にサイズ変更して確認できるように設定
7.メッセージボックスの表示中でもサイズ変更等の入力作業が自由にできるように、
  モードレスメッセージボックス(モードレス風かな)の作成(最下部の実行中の図参照)
8.上下・左右に余白を設けて画像を取得できるように設定
    これにより、下記のように、Yahoo! のトップ画面も一発で綺麗に取得できています。
  http://www.hanatyan.sakura.ne.jp/bbs_gif/yahoo.gif
    但し、yahoo! の場合枠線が完全に消えず残ってしまうので、枠線の分を除いて再転送
  する事によって消している(下図と見比べて見て下さい)
  http://www.hanatyan.sakura.ne.jp/bbs_gif/yahoo1.gif
    Element.Style.BorderStyle = "none" で消えてくれれば必要がないのだが。

使用コントロールとサイズ等は、No.1 の画像や Form_Load イベント内を参考にして下さい。
尚、ご使用される場合は、必ず、一度現状のままで動作を確認後、変更するなりして下さい。
理解しないまま、一部分だけを利用したりされた場合正常に動作しない可能性があります。
又、OS や IE のバージョン、取得するHTMLファイル等環境によってもうまく動作しない場合が
起きるかも知れません、その時の問題点を切り分ける意味でも現状でうまく取得できるか確認
願います。


HTMLファイルのサイズを取得する上で下記のような条件があります。
1.本来、HTMLファイルを作成された方が意図する画面サイズで表示する必要がある。
2.横スクロールバーを表示させた状態で高さを取得すると文字等の折り返し表示により
  本来の高さより高く取得できその分最下部に空白が表示される。
3.当サイトのトップページのようにフレームのページは、サイズ取得ができない。
  (最下部の下段の保存した図参照)
4.この掲示板のように表示画面のサイズによって表示領域が変わるような場合は、2.と
  同様に最下部に空白行が入ったり、文字の折り返しが変なところで折り返される。
5.Yahoo! のトップページのように縦スクロールバーが非表示ならないような場合も高さが
  低く取得されたり、左側が欠けて取得できたりする。

従って、上記のような場合でもうまく取得できるようにするには、WebBrowser のサイズを
取得したいサイズに合わせる必要がある。

それで、今回は最初標準的な方法で仮サイズを取得して、一旦そのサイズで表示させサイズを
変更するか、確認後、そのサイズで再取得する事で好みのサイズで取得できるようにしています。

途中、メッセージボックスをモードレスで表示させその間サイズの修正・最下部の取得状態が
マウスのドラッグで移動させて確認できるようにしています。

尚、IE からでは、IViewObjectインターフェイスをサポートしていないので取得できないようです。

-------------------------------------------------------------------------------------
'==================================================================
'SampleNo:563    2010.01.22     A 2010.01.25
'タイトル:指定のHTMLファイルの全体を画像として取得・保存(563)
'動作確認:WindowsVista  WindowsXP(SP2) VB6.0(SP6) IE 7.0 で確認
'プロジェクト→コンポーネント で Microsoft Internet Controls に
'チェックを入れて、WebBrowserコントロールをFormに貼り付けて下さい
'==================================================================
Option Explicit

'-------------------------------------------------------------------------------------
'OleDraw 関数を使用する為の宣言・設定部分
Private Enum DVASPECT
   DVASPECT_CONTENT = 1    'オブジェクトをコンテナ内の埋め込みオブジェクトとして表示する
   DVASPECT_THUMBNAIL = 2  'オブジェクトのサムネイル表示。
   DVASPECT_ICON = 4       'オブジェクトのアイコン表示。
   DVASPECT_DOCPRINT = 8   'プリンタに印刷したような画面上のオブジェクトの表現
End Enum

'領域を取得・設定する RECT 構造体
Private Type RECT
   Left   As Long
   Top    As Long
   Right  As Long
   Bottom As Long
End Type

'指定のオブジェクトを他のオブジェクトに表示する関数の宣言
'(IViewObjectインターフェイスをサポートしているオブジェクト)
Private Declare Function OleDraw Lib "ole32.dll" ( _
   ByVal pUnk As Object, ByVal dwAspect As DVASPECT, _
   ByVal hDCDraw As Long, lprcBounds As RECT) As Long
'引数
'pUnk
'表示元のオブジェクトを指定する
'dwAspect
'表示目的を、DVASPECT_ 定数より選択
'hDCDraw
'表示先のデバイス コンテキスト ハンドル(hDC)を指定
'lprcBounds
'取得元の表示範囲の領域を構造体で指定する

'戻り値
'オブジェクトが正常に描画された場合 0
'エラーの場合、0 以外の値
  '-2147221497  OLE_E_BLANK        = &H80040007  描画するデータがありませんから
  '-2147467260  E_ABORT            = &H80004004  描画操作は中断されました。
  '-2147221184  VIEW_E_DRAW        = &H80040140  エラーの描画が発生しました。
  '-2147221491  OLE_E_INVALIDRECT  = &H8004000D  四角形が無効です。
  'このオブジェクトは、IViewObjectインターフェイスをサポートしていません。
  '-2147221395  DV_E_NOIVIEWOBJECT = &H8004006D
  '-2147024809  E_INVALIDARG       = &H80070057  関数が失敗しています。
  '-2147024882  E_OUTOFMEMORY      = &H8007000E  関数が失敗しています。

'--------------------- ここまで ----------------------------------

'----------------------------------------------------------------
'明熊工房さんの「TransG32.DLL」を使って、PNG 形式に変換保存。
'「TransG32.DLL」は下記よりダウンロードして下さい。
'TransG32.dll はプログラムと同じフォルダーに入れて置いて下さい。
' http://www.vector.co.jp/soft/win95/prog/se148530.html

'PNG 形式で保存する必要がない場合は下記はコメントにしておいて下さい。
Private Declare Function DCSavetoPNG Lib "TransG32.DLL" ( _
   ByVal srchDC As Long, ByVal SrcWidth As Long, _
   ByVal SrcHeight As Long, ByVal pngf As String, _
   ByVal Value As Byte) As Integer
'----------------------------------------------------------------

'----------------------------------------------------------------
'マウスのドラッグでコントロールを移動させる為の設定
'マウスのキャプチャを解放する(1046)
Private Declare Function ReleaseCapture Lib "user32" () As Long
'指定のウインドウにメッセージを送る(750)
Private Declare Function SendMessage Lib "user32" _
   Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
   ByVal wParam As Long, lParam As Any) As Long
'非クライアント領域内において左ボタンをマウスダウンした時
'              ポストされるメッセージ(869)
Private Const WM_NCLBUTTONDOWN = &HA1
'キャプションバー上にある(868)
Private Const HTCAPTION = 2
'----------------------------------------------------------------

Private myURL    As String
Private wbHeight As Integer
Private wbWidth  As Integer
Private SNo      As Integer
Private VNo      As Integer

Private Sub Form_Load()
   '別途、プロパティで設定出来るものは、プロパティで設定して下さい。
   Me.ScaleMode = vbPixels
   Me.WindowState = vbMaximized
   With Picture1              'Picture1 の初期設定・他
      .Visible = False         '非表示でも OK
      .Cls
      .Appearance = 0
      .BorderStyle = 0
      .ScaleMode = vbPixels
      .AutoRedraw = True
      .Top = 40
      .Left = 10
      .Height = 350
      .Width = 350
   End With
  
   'Pictur1 のプロパティの設定と同じで(この場合はコピーして貼り付け)
   Picture2.Move 10, 40, 350 + 30, 350
   Picture2.BackColor = vbBlue
  
   'WebBrowser1 は、Picture2 の上に貼り付けて下さい。
   WebBrowser1.Move 0, 0, 350, 350
End Sub

Private Sub Command1_Click()
'指定の URL を WebBrowser に表示(この辺はお好みで)
   If Command1.Caption = "PictureBox に表示その1" Then
      myURL = "http://hanatyan.sakura.ne.jp/top.htm"
      Command1.Caption = "PictureBox に表示その2"
   ElseIf Command1.Caption = "PictureBox に表示その2" Then
      myURL = "http://www.yahoo.co.jp/"
      Command1.Caption = "PictureBox に表示その3"
   ElseIf Command1.Caption = "PictureBox に表示その3" Then
      myURL = "http://hanatyan.sakura.ne.jp/index.html"
      Command1.Caption = "PictureBox に表示その1"
   End If
  
   WebBrowser1.Visible = True
   Picture1.Visible = False
   Picture2.Visible = True
   Picture2.Move 10, 40, 350 + 30, 350
   WebBrowser1.Move 0, 0, 350, 350
   SNo = 1
   VNo = 0
   WebBrowser1.Navigate myURL
End Sub

Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
   If myURL <> "" And URL = myURL Then
      Dim wbDoc   As Object
      Dim Element As Object
      Set wbDoc = WebBrowser1.Document
      If WebBrowser1.Document.compatMode = "CSS1Compat" Then
         '標準モードの場合
         Set Element = wbDoc.documentElement
      Else
         '後方互換モードの場合
         Set Element = wbDoc.body
      End If
      Element.Style.BorderStyle = "none"
      Element.Style.overflowX = "hidden"
      Element.Style.overflowY = "hidden"
      Element.Style.marginTop = "10px"    'お好みで
      Element.Style.marginLeft = "0px"    'お好みで

      If SNo = 1 Then
         '一旦取得時同じ条件で表示してサイズを取得
         If VNo = 0 Then
            wbWidth = Element.scrollWidth + 20     '左右の余白 分
            WebBrowser1.Width = wbWidth
            DoEvents    'これがないと正確なサイズが取得できない。
            wbHeight = Element.scrollHeight + 10   '下部の余白
            '取得したサイズをテキストボックスに表示
         End If
         'フレームのようなサイズを取得できない場合は、一旦仮サイズで取得
         If wbHeight < 375 And wbWidth < 375 Then
            wbHeight = 1000
            wbWidth = 950
         End If
         WebBrowser1.Height = wbHeight
         WebBrowser1.Width = wbWidth
         Text1.Text = wbWidth
         Text2.Text = wbHeight
         Picture2.Move 10, 40, WebBrowser1.Width + 30, WebBrowser1.Height
         Picture2.Refresh
       '  WebBrowser1.Refresh
         'マウスのキャプチャを解放する
          Call ReleaseCapture
         'マウスがキャプションバー上にあるようにメッセージを送る
         Call SendMessage(Picture2.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&)

         'MsgBox の表示中にサイズ変更が可能なようにモードレスで最前面に表示
         Dim Ret As Integer, msg As String
         msg = "この表示サイズで取得しますか?" & vbCrLf & _
               "青い部分をドラッグして、下部の表示も確認できます。" & vbCrLf & _
               "サイズ修正後再確認するなら、[いいえ]ボタンをクリック"
         Ret = CreateObject("WScript.Shell").Popup(msg, 0, "表示サイズ確認", _
                                 vbYesNo Or vbMsgBoxSetForeground Or &H40000)
        
         '変更後のサイズを設定
         wbWidth = CLng(Text1.Text)
         wbHeight = CLng(Text2.Text)
         WebBrowser1.Height = wbHeight
         WebBrowser1.Width = wbWidth
         If Ret = vbNo Then
            SNo = 1
            VNo = 1
            '変更したサイズで再表示
            WebBrowser1.Navigate myURL
            Exit Sub
         End If
         SNo = 2
         VNo = 0
         '変更したサイズで再表示
         WebBrowser1.Navigate myURL
         Exit Sub
      End If
      If SNo = 2 Then
         'スクロールバーを表示させない状態で取得
         Element.style.BorderStyle = "none"  'Yahoo! では有効にならない
         Element.style.overflowX = "hidden"
         Element.style.overflowY = "hidden"
         'ここでは余白分の設定は要りません(すでに織り込み済み)
        
         DoEvents    'Refresh を使うとスクロールバーが表示するので注意
         With Picture1
            .Visible = False     '非表示でも OK
            .Cls
            .Height = wbHeight   'HTML ファイルの大きさに合わせる
            .Width = wbWidth     'HTML ファイルの大きさに合わせる
            .Refresh
         End With
        
         Dim udtRect As RECT
         With udtRect
            .Left = 0
            .Top = 0
            .Right = wbWidth     '表示(取得)範囲をHTMLファイルのサイズに設定
            .Bottom = wbHeight   '表示(取得)範囲をHTMLファイルのサイズに設定
         End With
        
         '画像が多かったり、アクセスカウンターの表示を待つなら
         '少しの間待ち時間を作る必要があるかも。(OS や回線も影響するかな)
         Dim lngSt As Long
         lngSt = Timer
         Do While Timer - lngSt < 1.5   '0.5 秒間待つ
            DoEvents  '制御をWindowsに渡す
         Loop
        
         'Document の表示内容を画像としてPicture1 に表示
         Ret = OleDraw(WebBrowser1.Document, DVASPECT_CONTENT, Picture1.hDC, udtRect)
         If Ret <> 0 Then
            MsgBox "エラーが発生しました。"
         End If
        
         WebBrowser1.Visible = False
         Picture2.Visible = False
         Picture1.Visible = True
         Picture1.Refresh
      End If
   End If
End Sub

Private Sub Command2_Click()
'PictureBox の画像を色々な形式で保存
'JPG 形式で保存する場合は下記をご覧下さい
'http://www.hanatyan.sakura.ne.jp/vbhlp/Picturejpg.htm

'--------------------------------------------------------------------------------
'PictureBox の画像をBMP形式でファイルに保存
   SavePicture Picture1.Image, App.Path & "\MyHTML.bmp"

   'Yahoo! 等のように上部と左側の枠が消えないのが気になる場合は
  '(WinXP で確認したら、右側と下側も薄く残っています。)
   'もう1個 Picture3 を用意して、Picture1.Image の領域を指定して
   'Picture3 に転送して、Picture3.Image を保存すれば、枠の部分を
   '除いて保存する事が出来ます。
   'この場合、Picture1 のプロパティの設定は同じとし、非表示で、OK です。
   Picture3.Width = Picture1.Width - 4
   Picture3.Height = Picture1.Height - 4
   Picture3.PaintPicture Picture1.Image, 0, 0, Picture1.Width - 4, Picture1.Height - 4, _
                                         2, 2, Picture1.Width - 4, Picture1.Height - 5
   SavePicture Picture3.Image, App.Path & "\MyHTML1.bmp"
  
'--------------------------------------------------------------------------------
'フリーソフトの GiFFY.exe を使って MyHTML.bmp → MyHTML.GIF を作成
'GiFFY(ジフィー) は下記より入手して下さい。
'GiFFY.exe はプログラムと同じフォルダーに入れて置いて下さい。
'http://www.altech-ads.com/product/10001392.htm
'GIF 形式で保存する必要がない場合は下記3行をコメントにしておいて下さい。
   Dim MyFile As String
   MyFile = Chr$(34) & App.Path & "\MyHTML.bmp" & Chr$(34)
   Shell App.Path & "\GiFFY.exe /ay " & MyFile, vbHide
  
'--------------------------------------------------------------------------------
'明熊工房さんの「TransG32.DLL」を使って、PNG 形式に変換保存。
'「TransG32.DLL」は下記よりダウンロードして下さい。
'TransG32.dll はプログラムと同じフォルダーに入れて置いて下さい。
' http://www.vector.co.jp/soft/win95/prog/se148530.html
   'srchDC…ピクチャボックスなどのデバイスコンテキスト
   'SrcWidth  … 画像の幅
   'SrcHeight … 画像の高さ
   'pngf    … PNFファイル名
   'Value   … 圧縮率   0=通常    1=圧縮率低い  2=最高圧縮率&不可逆
   '画像のサイズに設定
'PNG 形式で保存する必要がない場合は下記7行をコメントにしておいて下さい。
   Picture1.Height = wbHeight
   Picture1.Width = wbWidth
   Dim Ret As Long
   'これで、下記で魔界の仮面弁士 さんが紹介されていた AzConvPNG と同じ圧縮率になります。
   'http://www.hanatyan.sakura.ne.jp/yybbs/read.cgi?mode=view2&f=167&no=1
   Ret = DCSavetoPNG(Picture1.hDC, Picture1.Width, _
                     Picture1.Height, App.Path & "\MyHTML.png", 2)
'--------------------------------------------------------------------------------
   MsgBox "保存しました。"
End Sub

'マウスのドラッグでコントロールを移動させる為の処理
Private Sub Picture1_MouseDown(Button As Integer, _
                               Shift As Integer, X As Single, Y As Single)
   'マウスのキャプチャを解放する
   Call ReleaseCapture
   'マウスがキャプションバー上にあるようにメッセージを送る
   Call SendMessage(Picture1.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&)
End Sub

Private Sub Picture2_MouseDown(Button As Integer, _
                               Shift As Integer, X As Single, Y As Single)
   'マウスのキャプチャを解放する
   Call ReleaseCapture
   'マウスがキャプションバー上にあるようにメッセージを送る
   Call SendMessage(Picture2.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&)
End Sub

※ 例によって、エラーチェックはつけておりませんので、ご自分の環境で動作確認後
  設定して下さい。

  (それぞれの画像をクリックすると元のサイズで見る事ができます。) 
   図No.1 IDE 上の画面            実行中の図      下段の図は保存した図
メンテ

Page: 1 |

 投稿フォーム               スレッド一覧へ
題  名 スレッドをトップへソート
名  前
パスワード (記事メンテ時に使用)
投稿キー (投稿時 投稿キー を入力してください)
コメント

   クッキー保存   
スレッド一覧へ