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