Private Sub CommandButton1_Click()
Dim FilePath As String
FilePath = GetDesktop() & "\"
UserFormSnapshot FilePath & "5S Map Chart" & ".png"
Call MsgBox("Chart has been exported successfully to your Desktop at " _
& vbNewLine & vbNewLine & "" & FilePath, vbInformation, "Charts Export Result")
End Sub
Option Explicit
Private Type uPicDesc
Size As Long
Type As Long
#If VBA7 Then
hPic As LongPtr
hPal As LongPtr
#Else
hPic As Long
hPal As Long
#End If
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
#If VBA7 Then
DebugEventCallback As LongPtr
SuppressBackgroundThread As LongPtr
#Else
DebugEventCallback As Long
SuppressBackgroundThread As Long
#End If
SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
Type As Long
#If VBA7 Then
Value As LongPtr
#Else
Value As Long
#End If
End Type
Private Type EncoderParameters
Count As Long
Parameter As EncoderParameter
End Type
#If VBA7 Then
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (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 CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
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 Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (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 Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, Bitmap As Long) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare PtrSafe Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal Filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
#End If
Private Const IMAGE_BITMAP = 0
Private Const PICTYPE_BITMAP = 1
Private Const LR_COPYRETURNORG = &H4
Private Const CF_BITMAP = 2
Private Const S_OK = 0
Public Sub UserFormSnapshot(ByVal Filename As String)
#If VBA7 Then
Dim GDIPToken As LongPtr, hBitmap As LongPtr
#Else
Dim GDIPToken As Long, hBitmap As Long
#End If
Dim tSI As GdiplusStartupInput, Result As Long, iPic As IPicture
Dim tEncoder As GUID, TParams As EncoderParameters
Set iPic = CreatePicture
tSI.GdiplusVersion = 1
Result = GdiplusStartup(GDIPToken, tSI)
If Result = 0 Then
Result = GdipCreateBitmapFromHBITMAP(iPic.handle, 0, hBitmap)
If Result = 0 Then
CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), tEncoder
TParams.Count = 1
Result = GdipSaveImageToFile(hBitmap, StrPtr(Filename), tEncoder, TParams)
GdipDisposeImage hBitmap
End If
GdiplusShutdown GDIPToken
End If
If Result Then Err.Raise 5, , "Cannot save the image. GDI+ Error:" & Result
End Sub
Public Function CreatePicture() As IPicture
#If VBA7 Then
Dim hCopy As LongPtr, hPtr As LongPtr, hLib As LongPtr
#Else
Dim hCopy As Long, hPtr As Long, hLib As Long
#End If
Dim IID_IDispatch As GUID, uPicInfo As uPicDesc
Dim iPic As IPicture, Result As Long
On Error GoTo errHandler
keybd_event 44, 1, 0&, 0&
OpenClipboard 0
hPtr = GetClipboardData(CF_BITMAP)
hCopy = CopyImage(hPtr, 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
hLib = LoadLibrary("oleAut32.dll")
If hLib Then
Result = OleCreatePictureIndirectAut(uPicInfo, IID_IDispatch, True, iPic)
Else
Result = OleCreatePictureIndirectPro(uPicInfo, IID_IDispatch, True, iPic)
End If
FreeLibrary hLib
If Result = S_OK Then Set CreatePicture = iPic
errHandler:
EmptyClipboard
CloseClipboard
If Err Then Err.Raise 5, , "Cannot Create Picture."
End Function