VBAでIE自動操作する際、キャプチャしたい場合があります。
結構昔に参照して、キャプチャできた時は感動したのですが、
現在はそのページがなくなっているようで、こちらの記事参照させて頂きました。
画面キャプチャを行うサンプルコード
Option Explicit 'Window API Private Declare Function GetDesktopWindow Lib "user32" () As Long Private Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" _ (ByVal hwndParent As Long, ByVal hwndChildAfter As Long, _ ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hWnd As Long, lpRect As RECT) As Long Private Declare Function SetWindowPos Lib "user32.dll" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, _ ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long Private Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, _ ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hgdiobj As Long) As Long Private Declare Function GetDIBits Lib "gdi32.dll" (ByVal hdc As Long, ByVal hBMP As Long, ByVal uStartScan As Long, _ ByVal cScanLines As Long, lpvBits As Any, lpbi As BITMAPINFO, ByVal uUsage As Long) As Long Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hdc As Long) As Long Declare Function BitBlt Lib "gdi32.dll" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _ ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _ ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, _ ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long Private Declare Function CloseClipboard Lib "user32.dll" () As Long Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long Private Declare Function EmptyClipboard Lib "user32.dll" () As Long Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Type BITMAPFILEHEADER bfType As String * 2 bfSize As Long bfReserved1 As Integer bfReserved2 As Integer bfOffBits As Long End Type Type BITMAPINFOHEADER biSize As Long biWidth As Long biHeight As Long biPlanes As Integer biBitCount As Integer biCompression As Long biSizeImage As Long biXPelsPerMeter As Long biYPelsPerMeter As Long biClrUsed As Long biClrImportant As Long End Type Type RGBQUAD rgbBlue As Byte rgbGreen As Byte rgbRed As Byte rgbReserved As Byte End Type Type BITMAPINFO bmiHeader As BITMAPINFOHEADER bmiColors As RGBQUAD End Type Const HWND_TOP = 0 Const SWP_NOSIZE = 1 Const SWP_NOMOVE = 2 Const SRCCOPY = &HCC0020 'コピー元をコピー Const DIB_RGB_COLORS = 0 Const BI_RGB = 0 '非圧縮 Const CF_BITMAP = 2 Const BITSPIXEL = 12 Sub IEShot(ie As Object, Optional ReleaseFixedPosition As Boolean = False, Optional FilePath As String = "") Dim dcIE As Long Dim dcDIB As Long Dim hBMP As Long Dim hOldObj As Long Dim Dib() As Byte Dim bfh As BITMAPFILEHEADER Dim bi As BITMAPINFO Dim BMPWidth As Long Dim BMPHeight As Long Dim Handle As Long Dim R As RECT Dim ScrollTop As Long Dim MarginTop As Long Dim PageHeight As Long Dim OverDocHeight As Long If ReleaseFixedPosition Then Dim re As Object Dim css As Object Dim i As Long Set re = CreateObject("VBScript.RegExp") re.IgnoreCase = True re.Pattern = "position:\s*fixed" For Each css In ie.document.styleSheets For i = 0 To css.rules.Length - 1 With css.rules.Item(i) If re.Test(.Style.cssText) Then .Style.cssText = re.Replace(.Style.cssText, "position: absolute") End If End With Next Next Dim elm As Object For Each elm In ie.document.getElementsByTagName("*") If re.Test(elm.Style.cssText) Then elm.Style.cssText = re.Replace(elm.Style.cssText, "position: absolute") End If Next End If SetWindowPos ie.Parent.hWnd, HWND_TOP, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Handle = FindWindowEx(ie.hWnd, 0, "Frame Tab", vbNullString) Handle = FindWindowEx(Handle, 0, "TabWindowClass", vbNullString) Handle = FindWindowEx(Handle, 0, "Shell DocObject View", vbNullString) GetWindowRect Handle, R MarginTop = 2 PageHeight = R.Bottom - R.Top '- 4 BMPWidth = ie.document.body.scrollWidth BMPHeight = ie.document.body.ScrollHeight dcIE = GetDC(Handle) dcDIB = CreateCompatibleDC(dcIE) hBMP = CreateCompatibleBitmap(dcIE, BMPWidth, BMPHeight) hOldObj = SelectObject(dcDIB, hBMP) ScrollTop = 0 While ScrollTop < BMPHeight ie.document.parentWindow.scroll 0, ScrollTop OverDocHeight = ScrollTop + PageHeight - BMPHeight If OverDocHeight <= 0 Then BitBlt dcDIB, 0, ScrollTop, BMPWidth, PageHeight, dcIE, 0, MarginTop, SRCCOPY Else BitBlt dcDIB, 0, ScrollTop, BMPWidth, PageHeight - OverDocHeight, _ dcIE, 0, OverDocHeight, SRCCOPY End If ScrollTop = ScrollTop + PageHeight - MarginTop Wend If FilePath = "" Then OpenClipboard 0 EmptyClipboard SetClipboardData CF_BITMAP, hBMP CloseClipboard Else With bi.bmiHeader .biSize = 40 .biWidth = BMPWidth .biHeight = BMPHeight .biPlanes = 1 .biBitCount = GetDeviceCaps(dcIE, BITSPIXEL) .biSizeImage = BMPWidth * BMPHeight * .biBitCount \ 8 .biCompression = BI_RGB End With GetDIBits dcDIB, hBMP, 0, BMPHeight, 0&, bi, DIB_RGB_COLORS ReDim Dib(bi.bmiHeader.biSizeImage - 1) GetDIBits dcDIB, hBMP, 0, BMPHeight, Dib(0), bi, DIB_RGB_COLORS With bfh .bfType = "BM" .bfReserved1 = 0 .bfReserved2 = 0 .bfSize = Len(bfh) + Len(bi) + UBound(Dib) + 1 .bfOffBits = Len(bfh) + Len(bi) End With Open FilePath For Binary As #1 Put #1, , bfh Put #1, , bi Put #1, , Dib Close #1 End If Call SelectObject(dcDIB, hOldObj) Call DeleteObject(hBMP) Call DeleteDC(dcDIB) Call ReleaseDC(Handle, dcIE) End Sub Sub IEShot4IE11(ie As Object, Optional ReleaseFixedPosition As Boolean = False, Optional FilePath As String = "") Dim dcIE As Long Dim dcDIB As Long Dim hBMP As Long Dim hOldObj As Long Dim Dib() As Byte Dim bfh As BITMAPFILEHEADER Dim bi As BITMAPINFO Dim BMPWidth As Long Dim BMPHeight As Long Dim Handle As Long Dim R As RECT Dim ScrollTop As Long Dim PageHeight As Long Dim OverDocHeight As Long Dim IEScrollTop As Long Dim IEPageHeight As Long Dim IEScrollHeight As Long Dim IEOverDocHeight As Long Dim Window As HTMLWindow2 '参照設定で"Microsoft HTML Object Library"をチェックする If ReleaseFixedPosition Then Dim re As Object Dim css As Object Dim i As Long Set re = CreateObject("VBScript.RegExp") re.IgnoreCase = True re.Pattern = "position:\s*fixed" For Each css In ie.document.styleSheets For i = 0 To css.rules.Length - 1 With css.rules.Item(i) If re.Test(.Style.cssText) Then .Style.cssText = re.Replace(.Style.cssText, "position: absolute") End If End With Next Next Dim elm As Object For Each elm In ie.document.getElementsByTagName("*") If re.Test(elm.Style.cssText) Then elm.Style.cssText = re.Replace(elm.Style.cssText, "position: absolute") End If Next End If SetWindowPos ie.Parent.hWnd, HWND_TOP, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Handle = FindWindowEx(ie.hWnd, 0, "Frame Tab", vbNullString) Handle = FindWindowEx(Handle, 0, "TabWindowClass", vbNullString) Handle = FindWindowEx(Handle, 0, "Shell DocObject View", vbNullString) GetWindowRect Handle, R PageHeight = R.Bottom - R.Top Set Window = ie.document.parentWindow IEPageHeight = Window.innerHeight IEScrollHeight = ie.document.body.ScrollHeight BMPWidth = Fix(ie.document.body.clientWidth * PageHeight / IEPageHeight) BMPHeight = Fix(IEScrollHeight * PageHeight / IEPageHeight) dcIE = GetDC(0) dcDIB = CreateCompatibleDC(dcIE) hBMP = CreateCompatibleBitmap(dcIE, BMPWidth, BMPHeight) hOldObj = SelectObject(dcDIB, hBMP) ScrollTop = 0 IEScrollTop = 0 While IEScrollTop < IEScrollHeight ie.document.parentWindow.scroll 0, IEScrollTop While ie.Busy DoEvents Wend Sleep 50 'スクロール後の描画を取得するために入れている。 DoEvents 'これでもうまく取得できない場合は値を増やしてみるといいかも。 OverDocHeight = ScrollTop + PageHeight - BMPHeight IEOverDocHeight = IEScrollTop + IEPageHeight - IEScrollHeight If OverDocHeight <= 0 Then StretchBlt dcDIB, 0, ScrollTop, BMPWidth, PageHeight, dcIE, R.Left, R.Top, BMPWidth, PageHeight, SRCCOPY Else StretchBlt dcDIB, 0, ScrollTop, BMPWidth, PageHeight - OverDocHeight, dcIE, R.Left, R.Top + OverDocHeight, BMPWidth, PageHeight - OverDocHeight, SRCCOPY End If ScrollTop = ScrollTop + PageHeight IEScrollTop = IEScrollTop + IEPageHeight Wend If FilePath = "" Then OpenClipboard 0 EmptyClipboard SetClipboardData CF_BITMAP, hBMP CloseClipboard Else With bi.bmiHeader .biSize = 40 .biWidth = BMPWidth .biHeight = BMPHeight .biPlanes = 1 .biBitCount = GetDeviceCaps(dcIE, BITSPIXEL) .biSizeImage = BMPWidth * BMPHeight * .biBitCount \ 8 .biCompression = BI_RGB End With GetDIBits dcDIB, hBMP, 0, BMPHeight, 0&, bi, DIB_RGB_COLORS ReDim Dib(bi.bmiHeader.biSizeImage - 1) GetDIBits dcDIB, hBMP, 0, BMPHeight, Dib(0), bi, DIB_RGB_COLORS With bfh .bfType = "BM" .bfReserved1 = 0 .bfReserved2 = 0 .bfSize = Len(bfh) + Len(bi) + UBound(Dib) + 1 .bfOffBits = Len(bfh) + Len(bi) End With Open FilePath For Binary As #1 Put #1, , bfh Put #1, , bi Put #1, , Dib Close #1 End If Call SelectObject(dcDIB, hOldObj) Call DeleteObject(hBMP) Call DeleteDC(dcDIB) Call ReleaseDC(Handle, dcIE) End Sub
注意点
- IE10時代に動作確認しているので、IE11では動作未確認です。
これからIE自動操作よりもSeleniumを使用した自動操作が増えると思いますので、未検証です。
Chrome/Edgeでブラウザ画面をキャプチャする【TakeScreenshot】
関連記事
- VBAでIEを操作する機能のまとめ(逆引き目次)
- Chrome/Edgeでブラウザ画面 全体 をキャプチャする【TakeScreenshot】
- Chrome/Edgeでキャプチャした画像をエクセルに貼付する【TakeScreenshot】
その他
Internet Explorerを使用して、Webスクレイピングは敷居が高い風に捉えられますが、
上記のように、パーツ化して組み合わせ処理するだけです。
Web上のデータを触りたい要望は会社様でも個人様でも多いと思います。
VBA IE操作を覚えて効率化しませんか?
作成が大変であれば弊社で代行開発も可能です。お気軽にお問い合わせください。
コメント