Internet Explorer(IE)をキャプチャしてExcelに貼る

筆箱にVBAのカンニングペーパーを入れる係のみすくです。こんにちは。

IEをキャプチャして、Excelに貼ります。
フォームのボタンを押したら、IEをキャプチャして貼り付けます。
エラー制御などは入れていません。

キャプチャするコードは緑里庵さんからいただきました。

アドインのリボンはQiitaを参考にしました。

Option Explicit

Private Sub btnCapture_Click()
    Dim ieCtrl As ClsIECtrl       'IE操作クラス
    Dim xlCtrl As ClsExcelCtrl    'Excel操作クラス
    Dim shName As String          'ワークシート名
    Dim sh As Worksheet           'ワークシートオブジェクト
    
    Set ieCtrl = New ClsIECtrl
    Set xlCtrl = New ClsExcelCtrl
    
    'シート名取得
    shName = frmIECapture.txtSheetName.Value
    If xlCtrl.isExistSheet(shName) = False Then
        Set sh = xlCtrl.AddSheetAtLast(shName)
    Else
        Set sh = Worksheets(shName)
        sh.Activate
    End If
    
    'URL書き込み
    sh.Range("A1").Value = ieCtrl.locationUrl
    'キャプチャ取得
    Call ieCtrl.captureIE
    '
    sh.Range(frmIECapture.txtCellAddress.Value).Select
    sh.Paste
    
    '後始末
    Call ieCtrl.captureIE
    Set ieCtrl = Nothing
End Sub

Option Explicit

Public Enum eHWnd
   SW_HIDE = 0             'ウィンドウを非表示にし、他のウィンドウをアクティブにします。
   SW_SHOWNORMAL = 1       'ウィンドウをアクティブにして表示します。ウィンドウが最小化または最大化されていた場合は、その位置とサイズを元に戻します。初めてウィンドウを表示するときには、このフラグを指定してください。
   SW_SHOWMINIMIZED = 2    'ウィンドウをアクティブにして、最小化します。
   SW_MAXIMIZE = 3         'ウィンドウを最大化します。
   SW_SHOWNOACTIVATE = 4   'ウィンドウを直前の位置とサイズで表示します。
   SW_SHOW = 5             'ウィンドウをアクティブにして、現在の位置とサイズで表示します。
   SW_MINIMIZE = 6         'ウィンドウを最小化し、Z 順位が次のトップレベルウィンドウをアクティブにします。
   SW_SHOWMINNOACTIVE = 7  'ウィンドウを最小化します。SW_SHOWMINIMIZED と似ていますが､この値を指定した場合は､ウィンドウはアクティブ化されません｡
   SW_SHOWNA = 8           'ウィンドウを現在のサイズと位置で表示します。SW_SHOW と似ていますが､この値を指定した場合は､ウィンドウはアクティブ化されません｡
   SW_RESTORE = 9          'ウィンドウをアクティブにして表示します。
   SW_SHOWDEFAULT = 10     'アプリケーションを起動したプログラムが 関数に渡した 構造体で指定された SW_ フラグに従って表示状態を設定します。
End Enum

Option Explicit

Public Sub showFormIECapture(ByVal control As IRibbonControl)
    frmIECapture.Show
End Sub

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
Private 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)

Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Private Type BITMAPFILEHEADER
       bfType       As String * 2
       bfSize       As Long
       bfReserved1  As Integer
       bfReserved2  As Integer
       bfOffBits    As Long
End Type

Private 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

Private Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type

Private 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

Option Explicit

Const SH_NAME_MAX_LENGTH = 31    'ワークシート名最大長

'---------------------------------------------------------------------------------------------------
'【処 理 名】ワークシート追加
'【処理概要】ワークシートを追加し、指定があればシート名を設定する。
'【引    数】[I]Optional ByVal shName As String = "" シート名
'【返 却 値】ワークシートオブジェクト
'---------------------------------------------------------------------------------------------------
Public Function AddSheetAtLast(Optional ByVal shName As String = "") As Worksheet
    Dim sh As Worksheet
    Dim buf As String
    
    'シートを追加する
    Set sh = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    'シート名が指定されている場合、シート名を設定
    If shName <> "" Then
        buf = Left(shName, SH_NAME_MAX_LENGTH)
        sh.Name = shName
    End If
    Set AddSheetAtLast = sh
End Function

'---------------------------------------------------------------------------------------------------
'【処 理 名】ワークシート存在確認
'【処理概要】指定の名前のワークシートがあるか確認する
'【引    数】[I]Optional ByVal shName As String = "" シート名
'【返 却 値】ワークシートオブジェクト
'---------------------------------------------------------------------------------------------------
Public Function isExistSheet(ByVal shName As String) As Boolean
    Dim sh As Worksheet
    
    isExistSheet = False
    For Each sh In Worksheets
        If sh.Name = shName Then
            isExistSheet = True
            GoTo LBL_TERM
        End If
    Next sh
LBL_TERM:
End Function

Option Explicit

'---------------------------------------
'Win32Api
'---------------------------------------
Private Declare Function IsIconic Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function ShowWindowAsync Lib "user32.dll" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long

'---------------------------------------
' 変数
'---------------------------------------
Private objIE As InternetExplorer
Public locationUrl As String

'---------------------------------------------------------------------------------------------------
'【処 理 名】初期化
'【処理概要】初期処理を行う
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
    Set objIE = New InternetExplorer
    Call getIE
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】終期処理
'【処理概要】終期化を行う
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
    Set objIE = Nothing
End Sub

Public Sub captureIE()
    Dim captureIE As ClsCaptureIE
    
    Set captureIE = New ClsCaptureIE
    Call captureIE.IEShot4IE11(objIE)
    Set captureIE = Nothing
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】IE起動
'【処理概要】IEを起動する
'【引    数】[I]ByVal url As String URL
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Public Sub openUrl(ByVal url As String)
    'Internet Explorerを可視にする
    objIE.Visible = True
    objIE.Navigate url
    waitIE
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】起動済みIE取得
'【処理概要】起動済みのIEを取得する。複数起動されている場合は最後に取得したウィンドウとなる
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Public Sub getIE()
    Dim objShell As Shell
    Dim objWin As Object
    
    Set objShell = New Shell
    For Each objWin In objShell.Windows
        If objWin.Name = "Internet Explorer" And objWin.locationUrl <> "" Then
            Set objIE = objWin
            locationUrl = objIE.locationUrl
        End If
    Next
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】IE待機
'【処理概要】IEのBusyを待機する
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub waitIE()
    Do While objIE.Busy Or objIE.ReadyState < READYSTATE_COMPLETE
        DoEvents
    Loop
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】URLオープン
'【処理概要】指定したURLを開く
'【引    数】[I]ByVal url As String
'【返 却 値】
'---------------------------------------------------------------------------------------------------
Private Sub naviUrl(ByVal url As String)
    objIE.Navigate url
    waitIE
End Sub

'---------------------------------------------------------------------------------------------------
'【処 理 名】最前面に表示
'【処理概要】IEを最前面に表示する
'【引    数】なし
'【返 却 値】なし
'---------------------------------------------------------------------------------------------------
Private Sub foreGroundIE()
    If IsIconic(objIE.hWnd) Then
        ShowWindowAsync objIE.hWnd, eHWnd.SW_RESTORE
    End If
End Sub

アドイン化したものはこちら。
毎度の注意ですが、VBAはなかなか強力な言語なので、
無防備にダウンロードするのはｲｸﾅｲ。
上に書いたとおりの内容が入っているけどね。

IEキャプチャアドイン

1 ファイル 33.46 KB

ダウンロード

リボンに追加するXML
_rels > .rels

<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<Relationships xmlns="http://schemas.openxmlformats.org/package/2006/relationships">
<Relationship Id="rId3" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties" Target="docProps/app.xml"/>
<Relationship Id="Re92edffc4bcd442e" Type="http://schemas.microsoft.com/office/2007/relationships/ui/extensibility" Target="customUI/customUI14.xml"/>
<Relationship Id="rId2" Type="http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties" Target="docProps/core.xml"/>
<Relationship Id="rId1" Type="http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument" Target="xl/workbook.xml"/>
</Relationships>

customUI > customUI14.xml

<?xml version="1.0" encoding="shift_jis"?>
<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
	<ribbon startFromScratch="false">
		<tabs>
			<tab id="customTab" label="筆箱ツール">
				<group id="customGroup" label="Custom Group">
					<button id="customButton" label="IEキャプチャ" imageMso="AccessFormModalDialog" size="large" onAction="showFormIECapture" />
				</group>
			</tab>
		</tabs>
	</ribbon>
</customUI>

IEキャプチャアドイン

コメントを残す コメントをキャンセル

コメントを残すコメントをキャンセル