Option Explicit
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 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
Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
'GDI+ APIS.
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 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 Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Declare PtrSafe IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
'GDI+ APIS.
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, bitmap As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal FILENAME As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
#End If
Public Function XLObjectToJPG(ByVal Obj As Object, ByVal FILEPATH As String, ByVal FILENAME As String) As Boolean
#If VBA7 Then
Dim hPtr As LongPtr
#Else
Dim hPtr As Long
#End If
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Const CF_BITMAP = 2
On Error GoTo errHandler
Obj.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
OpenClipboard 0
If IsClipboardFormatAvailable(CF_BITMAP) Then
hPtr = GetClipboardData(CF_BITMAP)
hPtr = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
With CreateObject("VBScript.RegExp")
.Global = True
.IgnoreCase = True
.Pattern = "[\x00-\x1F""<>\|:\*\?\\/]"
FILENAME = .Replace(FILENAME, "")
.Pattern = ".jpg$|.jpeg$"
If .Test(FILENAME) And Len(Dir(FILEPATH & Application.PathSeparator, vbDirectory)) Then
XLObjectToJPG = PicHandleToJPGFile(hPtr, FILEPATH & Application.PathSeparator, FILENAME)
Else
MsgBox "Wrong File Path or File Extension.", vbCritical, "Error!"
End If
End With
End If
errHandler:
EmptyClipboard
CloseClipboard
If Err Then
MsgBox "Error: " & Err & vbNewLine & Err.Description, vbCritical, "Error!"
End If
End Function
#If VBA7 Then
Private Function PicHandleToJPGFile(ByVal PicHandle As LongPtr, ByVal FILEPATH As String, ByVal FILENAME As String, Optional ByVal Quality As Byte = 100) As Boolean
Dim lGDIP As LongPtr, lBitmap As LongPtr
#Else
Private Function PicHandleToJPGFile(ByVal PicHandle As Long, ByVal FILEPATH As String, ByVal FILENAME As String, Optional ByVal Quality As Byte = 100) As Boolean
Dim lGDIP As Long, lBitmap As Long
#End If
Dim tSI As GdiplusStartupInput, lRes As Long
Dim tJpgEncoder As GUID, tParams As EncoderParameters
tSI.GdiplusVersion = 1
lRes = GdiplusStartup(lGDIP, tSI)
If lRes = 0 Then
lRes = GdipCreateBitmapFromHBITMAP(PicHandle, 0, lBitmap)
If lRes = 0 Then
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
tParams.Count = 1
With tParams.Parameter
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
.NumberOfValues = 1
.Type = 4
#If VBA7 Then
.Value = VarPtr(Quality)
#Else
.Value = CLng(VarPtr(Quality))
#End If
End With
lRes = GdipSaveImageToFile(lBitmap, StrPtr(FILEPATH & FILENAME), tJpgEncoder, tParams)
GdipDisposeImage lBitmap
End If
GdiplusShutdown lGDIP
End If
If lRes Then
MsgBox "Cannot save the image. GDI+ Error:", vbCritical, "Error!"
Else
PicHandleToJPGFile = True
End If
End Function
