Option Explicit
#If Win64 Then
Const NULL_PTR = 0^
#Else
Const NULL_PTR = 0&
#End If
#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
#End If
Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
Private Declare PtrSafe Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long
Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hDC As LongPtr, ByVal crColor As Long) As Long
Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As LongPtr, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongPtr
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'GDIPlus
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, Bitmap As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As LongPtr
Private Declare PtrSafe Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As LongPtr, ByVal Filename As LongPtr, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal str As LongPtr, id As GUID) As Long
#Else
Private Enum LongPtr
[_]
End Enum
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPtr
Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As LongPtr, ByVal crColor As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongPtr
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'GDIPlus
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare Function GdiplusStartup Lib "gdiplus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, Bitmap As LongPtr) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As LongPtr) As LongPtr
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As LongPtr, ByVal Filename As LongPtr, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As LongPtr, id As GUID) As Long
#End If
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * 32
End Type
Private Type uPicDesc
Size As Long
Type As Long
hPic As LongPtr
hPal As LongPtr
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'GDIPlus
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As LongPtr
SuppressBackgroundThread As LongPtr
SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
Type As Long
Value As LongPtr
End Type
Private Type EncoderParameters
Count As Long
Parameter As EncoderParameter
End Type
Public Function SaveScrollableUserForm( _
ByVal UForm As UserForm, _
ByVal OutFilePathName As String, _
Optional ByVal ClientAreaOnly As Boolean = True, _
Optional ByVal PasteToNewSheetAsShape As Boolean _
) _
As StdPicture
' Takes a screen capture of the entire userform or the client area
' and saves the image file to disk.
' ====================================================
' Image file formats accepted : '
' BMP,DIB,RLE,JPEG,JPG,JPE,JFIF,GIF,TIFF,TIF,PNG '
' ====================================================
'Function Return : ole StdPicture Object.
Const SRCCOPY = &HCC0020
Const SM_CYDLGFRAME = 8&
Const SM_CYCAPTION = 4&
Const SM_CXVSCROLL = 2&
Dim hWnd As LongPtr, hDC As LongPtr, hMemDC As LongPtr, hBmp As LongPtr
Dim hScreenDc As LongPtr, hScreenMemDc As LongPtr
Dim tClientRect As RECT
Dim lWidth As Long, lHeight As Long, lInitScrollBarVal As Long
Dim sngVal As Single, sngPrevScrollTop As Single
Dim YOffset As Long
On Error GoTo errHandler
With UForm
.ScrollTop = 0&
lInitScrollBarVal = .ScrollBars
.ScrollBars = fmScrollBarsVertical
DoEvents
Call IUnknown_GetWindow(UForm, VarPtr(hWnd))
Call GetClientRect(hWnd, tClientRect)
sngVal = IIf(.ScrollHeight >= .InsideHeight, .ScrollHeight, .InsideHeight)
With tClientRect
If ClientAreaOnly Then
lWidth = .Right - .Left - GetSystemMetrics(SM_CXVSCROLL)
lHeight = PTtoPX(CDbl(sngVal), True, UForm.Zoom)
Else
lWidth = .Right - .Left: lHeight = PTtoPX(CDbl(sngVal), True, UForm.Zoom)
End If
End With
hDC = GetDC(hWnd)
hMemDC = CreateCompatibleDC(0&)
hBmp = CreateCompatibleBitmap(hDC, lWidth, lHeight)
Call DeleteObject(SelectObject(hMemDC, hBmp))
Call BitBlt(hMemDC, 0&, 0&, lWidth, lHeight, hDC, tClientRect.Left, _
tClientRect.Top - IIf(ClientAreaOnly, 0&, GetSystemMetrics(SM_CYCAPTION)), SRCCOPY)
DisableClientAreaUpdate(hWnd, hScreenDc, hScreenMemDc) = True
Call ShowProgress(hScreenMemDc, tClientRect)
DoEvents
sngPrevScrollTop = 0&
Do
DoEvents
sngPrevScrollTop = .ScrollTop
.Scroll 0&, fmScrollActionPageDown
.Repaint
YOffset = GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYDLGFRAME)
Call BitBlt(hMemDC, 0&, PTtoPX(.ScrollTop, True, UForm.Zoom) + YOffset, _
lWidth, lHeight, hDC, tClientRect.Left, tClientRect.Top + YOffset, SRCCOPY)
Call FreezeClientAreaNow(hWnd, hScreenDc, hScreenMemDc)
'Sleep 1000& '<== Edit for testing
Loop Until sngPrevScrollTop >= .ScrollTop
.ScrollBars = lInitScrollBarVal
.ScrollTop = 0&
End With
Set SaveScrollableUserForm = CreatePicture(hBmp, PasteToNewSheetAsShape, OutFilePathName)
errHandler:
DisableClientAreaUpdate(hWnd, hScreenDc, hScreenMemDc) = False
Call ReleaseDC(0, hDC)
Call DeleteObject(hMemDC)
Call DeleteObject(hBmp)
End Function
Private Sub ShowProgress(ByVal hDC As LongPtr, ByRef tRect As RECT)
Const SM_CYCAPTION = 4&
Const SM_CYDLGFRAME = 8&
Dim hNewFont As LongPtr
Dim tFont As LOGFONT, sCopying As String, YOffset As Long
sCopying = "Capturing UserForm Screen ... Please Wait"
With tFont
.lfHeight = 18&: .lfFaceName = "Arial" & Chr(0&): .lfWeight = 900&
End With
hNewFont = (CreateFontIndirect(tFont))
Call DeleteObject(SelectObject(hDC, hNewFont))
Call SetTextColor(hDC, vbRed)
Call SetBkMode(hDC, 1&)
YOffset = GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYDLGFRAME) + 10&
Call TextOut(hDC, tRect.Left + 20&, tRect.Top + YOffset, sCopying, Len(sCopying))
End Sub
Private Property Let DisableClientAreaUpdate( _
ByVal hWnd As LongPtr, _
ByRef hDC As LongPtr, _
ByRef hMemDC As LongPtr, _
Enable As Boolean _
)
Const SRCCOPY = &HCC0020
Const GWL_EXSTYLE = (-20&)
Const WS_EX_LAYERED = &H80000
Const LWA_ALPHA = &H2&
Static hBmp As LongPtr
Dim tWndRect As RECT
If Enable Then
With tWndRect
Call GetWindowRect(hWnd, tWndRect)
hDC = GetDC(0&)
hMemDC = CreateCompatibleDC(0&)
hBmp = CreateCompatibleBitmap(hDC, .Right - .Left, .Bottom - .Top)
Call DeleteObject(SelectObject(hMemDC, hBmp))
Call BitBlt(hMemDC, 0&, 0&, .Right - .Left, .Bottom - .Top, hDC, .Left, .Top, SRCCOPY)
End With
Else
Call ReleaseDC(0&, hDC)
Call DeleteObject(hMemDC)
Call DeleteObject(hBmp)
End If
Call SetWindowLong(hWnd, GWL_EXSTYLE, GetWindowLong(hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED)
Call SetLayeredWindowAttributes(hWnd, 0&, IIf(Enable, 0&, 255&), LWA_ALPHA)
End Property
Private Sub FreezeClientAreaNow(ByVal hWnd As LongPtr, ByVal hDC As LongPtr, hMemDC As LongPtr)
Const SRCCOPY = &HCC0020
Dim tWndRect As RECT
Call GetWindowRect(hWnd, tWndRect)
With tWndRect
If GetActiveWindow = hWnd Or GetActiveWindow = Application.hWnd Then
Call BitBlt(hDC, .Left, .Top, .Right - .Left, .Bottom - .Top, hMemDC, 0&, 0&, SRCCOPY)
End If
End With
End Sub
Private Function CreatePicture( _
ByVal BMP As LongPtr, _
Optional ByVal PasteToNewSheetAsShape As Boolean, _
Optional ByVal OutFilePathName As String _
) As StdPicture
Const IMAGE_BITMAP = 0&
Const PICTYPE_BITMAP = 1&
Const LR_COPYRETURNORG = &H4
Const CF_BITMAP = 2&
Const S_OK = 0&
Dim hCopy As LongPtr
Dim lRet As Long
Dim IID_IDispatch As GUID
Dim uPicinfo As uPicDesc
Dim oPic As StdPicture
hCopy = CopyImage(BMP, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
With IID_IDispatch
.Data1 = &H20400
.Data4(0&) = &HC0
.Data4(7&) = &H46
End With
With uPicinfo
.Size = Len(uPicinfo)
.Type = PICTYPE_BITMAP
.hPic = hCopy
.hPal = 0&
End With
lRet = OleCreatePictureIndirect(uPicinfo, IID_IDispatch, True, oPic)
If lRet = S_OK Then
Set CreatePicture = oPic
If PasteToNewSheetAsShape Then
If Not ThisWorkbook.ProtectStructure Then
Call OpenClipboard(0&)
Call EmptyClipboard
Call SetClipboardData(CF_BITMAP, hCopy)
Call CloseClipboard
ThisWorkbook.Worksheets.Add.Paste
End If
End If
If Len(OutFilePathName) Then
Call SaveUserFormToDisk(hCopy, OutFilePathName)
End If
End If
End Function
Private Function ScreenDPI(bVert As Boolean) As Long
Const LOGPIXELSY = 90&
Const LOGPIXELSX = 88&
Static lDPI(1), lDC
If lDPI(0&) = 0& Then
lDC = GetDC(0&)
lDPI(0&) = GetDeviceCaps(lDC, LOGPIXELSX)
lDPI(1&) = GetDeviceCaps(lDC, LOGPIXELSY)
lDC = ReleaseDC(0&, lDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function PTtoPX(Points As Double, bVert As Boolean, ByVal Zoom As Long) As Long
Const POINTS_PER_INCH = 72&
PTtoPX = (Zoom / 100&) * Points * ScreenDPI(bVert) / POINTS_PER_INCH
End Function
Private Function SaveUserFormToDisk( _
ByVal hBmp As LongPtr, _
ByVal FullFilename As String _
) As Boolean
Const S_OK = &H0
Const PW_CLIENTONLY = &H1
Const PW_RENDERFULLCONTENT = &H2
Const INVALID_FILE_ATTRIBUTES = -1&
Dim hDC As LongPtr, hMemDC As LongPtr
Dim hMemBmp As LongPtr, hPrevBmp As LongPtr
Dim tRect As RECT
'GDIPlus
Dim tEncoder As GUID, tSI As GdiplusStartupInput, TParams As EncoderParameters
Dim GDIPToken As LongPtr, hBitmap As LongPtr, lRet As Long
Dim sPathFile As String, sExt As String, sFormatCLSID As String
On Error GoTo errHandler
sExt = Right(FullFilename, Len(FullFilename) - InStrRev(FullFilename, "."))
Select Case UCase(sExt)
Case "BMP", "DIB", "RLE"
sFormatCLSID = "{557cf400-1a04-11d3-9a73-0000f81ef32e}"
Case "JPEG", "JPG", "JPE", "JFIF"
sFormatCLSID = "{557cf401-1a04-11d3-9a73-0000f81ef32e}"
Case "GIF"
sFormatCLSID = "{557cf402-1a04-11d3-9a73-0000f81ef32e}"
Case "TIFF", "TIF"
sFormatCLSID = "{557cf405-1a04-11d3-9a73-0000f81ef32e}"
Case "PNG"
sFormatCLSID = "{557cf406-1a04-11d3-9a73-0000f81ef32e}"
End Select
tSI.GdiplusVersion = 1&
lRet = GdiplusStartup(GDIPToken, tSI)
If lRet = S_OK Then
lRet = GdipCreateBitmapFromHBITMAP(hBmp, NULL_PTR, hBitmap)
If lRet = S_OK Then
CLSIDFromString StrPtr(sFormatCLSID), tEncoder
TParams.Count = 1&
lRet = GdipSaveImageToFile(hBitmap, StrPtr(FullFilename), tEncoder, TParams)
If lRet = S_OK Then
If GetFileAttributes(FullFilename) <> INVALID_FILE_ATTRIBUTES Then
SaveUserFormToDisk = True
End If
End If
End If
End If
errHandler:
Call GdipDisposeImage(hBitmap)
Call GdiplusShutdown(GDIPToken)
Call DeleteObject(hBmp)
End Function