Option Explicit
#If Win64 Then
Const NULL_PTR = 0^
#Else
Const NULL_PTR = 0&
#End If
#If VBA7 Then
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 CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function PrintWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal hdcBlt As LongPtr, ByVal nFlags As Long) As Long
Private Declare PtrSafe Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) 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 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 CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
Private Declare Function PrintWindow Lib "user32" (ByVal hWnd As LongPtr, ByVal hdcBlt As LongPtr, ByVal nFlags As Long) As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) 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 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
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 SaveUserFormToDisk( _
ByVal Form As UserForm, _
ByRef Path As String, _
ByVal Filename As String, _
Optional ByVal FullContent As Boolean = True _
) As Boolean
Const S_OK = &H0
Const PW_CLIENTONLY = &H1
Const PW_RENDERFULLCONTENT = &H2
Const INVALID_FILE_ATTRIBUTES = -1&
Dim hWnd As LongPtr, 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
If Right(Path, 1) <> Application.PathSeparator Then Path = Path & Application.PathSeparator
sPathFile = Path & Filename
sExt = Right(sPathFile, Len(sPathFile) - InStrRev(sPathFile, "."))
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
Call IUnknown_GetWindow(Form, VarPtr(hWnd))
hDC = GetDC(hWnd)
Call GetWindowRect(hWnd, tRect)
With tRect
hMemBmp = CreateCompatibleBitmap(hDC, .Right - .Left, .Bottom - .Top)
End With
hMemDC = CreateCompatibleDC(hDC)
hPrevBmp = SelectObject(hMemDC, hMemBmp)
Call PrintWindow(hWnd, hMemDC, IIf(FullContent, PW_RENDERFULLCONTENT, PW_CLIENTONLY))
tSI.GdiplusVersion = 1&
lRet = GdiplusStartup(GDIPToken, tSI)
If lRet = S_OK Then
lRet = GdipCreateBitmapFromHBITMAP(hMemBmp, NULL_PTR, hBitmap)
If lRet = S_OK Then
CLSIDFromString StrPtr(sFormatCLSID), tEncoder
TParams.Count = 1&
lRet = GdipSaveImageToFile(hBitmap, StrPtr(sPathFile), tEncoder, TParams)
If lRet = S_OK Then
If GetFileAttributes(sPathFile) <> INVALID_FILE_ATTRIBUTES Then
SaveUserFormToDisk = True
End If
End If
End If
End If
errHandler:
Call GdipDisposeImage(hBitmap)
Call GdiplusShutdown(GDIPToken)
Call SelectObject(hMemDC, hPrevBmp)
Call DeleteObject(hMemBmp)
Call DeleteDC(hMemDC)
Call ReleaseDC(hWnd, hDC)
End Function
