サンプル投稿用掲示板 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 に変換ですが。)
主な機能の紹介
１．指定のURLのHTMLファイルの表示内容(スクロールしないと見えない部分も含む)を
画像として取得し、ピクチャーボックスに表示
２．ピクチャーボックスに表示された画像をファイルに保存(通常のbmp形式で)
３．フリーソフトのGiFFY.exe を使って２．で保存したファイルをGIF形式に変換して保存
４．フリーソフトの TransG32.DLL を使って、PNG 形式で高圧縮で保存
５．表示中の画像及び保存前の画像が全て確認できるように、マウスのドラッグで移動して
見えない部分も確認できるように設定
６．自由なサイズで取得できるように、取得中にサイズ変更して確認できるように設定
７．メッセージボックスの表示中でもサイズ変更等の入力作業が自由にできるように、
モードレスメッセージボックス(モードレス風かな)の作成(最下部の実行中の図参照)
８．上下・左右に余白を設けて画像を取得できるように設定
これにより、下記のように、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ファイルのサイズを取得する上で下記のような条件があります。
１．本来、HTMLファイルを作成された方が意図する画面サイズで表示する必要がある。
２．横スクロールバーを表示させた状態で高さを取得すると文字等の折り返し表示により
本来の高さより高く取得できその分最下部に空白が表示される。
３．当サイトのトップページのようにフレームのページは、サイズ取得ができない。
(最下部の下段の保存した図参照)
４．この掲示板のように表示画面のサイズによって表示領域が変わるような場合は、２．と
同様に最下部に空白行が入ったり、文字の折り返しが変なところで折り返される。
５．Yahoo! のトップページのように縦スクロールバーが非表示ならないような場合も高さが
低く取得されたり、左側が欠けて取得できたりする。
従って、上記のような場合でもうまく取得できるようにするには、WebBrowser のサイズを
取得したいサイズに合わせる必要がある。
それで、今回は最初標準的な方法で仮サイズを取得して、一旦そのサイズで表示させサイズを
変更するか、確認後、そのサイズで再取得する事で好みのサイズで取得できるようにしています。
途中、メッセージボックスをモードレスで表示させその間サイズの修正・最下部の取得状態が
マウスのドラッグで移動させて確認できるようにしています。
尚、IE からでは、IViewObjectインターフェイスをサポートしていないので取得できないようです。
-------------------------------------------------------------------------------------
'==================================================================
'SampleNo：563 2010.01.22 ② 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 に表示その１" Then
myURL = "http://hanatyan.sakura.ne.jp/top.htm"
Command1.Caption = "PictureBox に表示その２"
ElseIf Command1.Caption = "PictureBox に表示その２" Then
myURL = "http://www.yahoo.co.jp/"
Command1.Caption = "PictureBox に表示その３"
ElseIf Command1.Caption = "PictureBox に表示その３" Then
myURL = "http://hanatyan.sakura.ne.jp/index.html"
Command1.Caption = "PictureBox に表示その１"
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 で確認したら、右側と下側も薄く残っています。)
'もう１個 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 形式で保存する必要がない場合は下記３行をコメントにしておいて下さい。
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 形式で保存する必要がない場合は下記７行をコメントにしておいて下さい。
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 上の画面 実行中の図 下段の図は保存した図
 |
