Option Compare Database
Option Explicit
Public Const GUID_IPicture = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}" 'IPicture
Public Enum PicFileType
pictypeBMP = 1
pictypeGIF = 2
pictypePNG = 3
pictypeJPG = 4
End Enum
Public Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Public Type TSize
x As Double
y As Double
End Type
Public Type RECT
Bottom As Long
Left As Long
Right As Long
Top As Long
End Type
Private Type PICTDESC
cbSizeOfStruct As Long
PicType As Long
hImage As Long
xExt As Long
yExt As Long
End Type
Private Type GDIPStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
UUID As GUID
NumberOfValues As Long
type As Long
Value As Long
End Type
Private Type EncoderParameters
count As Long
Parameter As EncoderParameter
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PICTDESC, riid As GUID, ByVal fPictureOwnsHandle As Long, IPic As Object) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pCLSID As GUID) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalSize Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByRef Source As Byte, ByVal Length As Long)
Private Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function GetModuleHandle Lib "kernel32.dll" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ByRef ppstm As Any) As Long
Private Declare Function GetHGlobalFromStream Lib "ole32.dll" (ByVal pstm As Any, ByRef phglobal As Long) As Long
Private Declare Function GdiplusStartup Lib "ogl" (token As Long, inputbuf As GDIPStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "ogl" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "ogl" (ByVal FileName As Long, bitmap As Long) As Long
Private Declare Function GdipCreateFromHDC Lib "ogl" (ByVal hdc As Long, GpGraphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "ogl" (ByVal Graphics As Long) As Long
Private Declare Function GdipDrawImageRect Lib "ogl" (ByVal Graphics As Long, ByVal image As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As Long
Private Declare Function GdipDisposeImage Lib "ogl" (ByVal image As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "ogl" (ByVal bitmap As Long, hbmReturn As Long, ByVal background As Long) As Long
Public Declare Function GdipCreateHICONFromBitmap Lib "gdiplus" (ByVal bitmap As Long, hbmReturn As Long) As Long
Private Declare Function GdipGetImageThumbnail Lib "ogl" (ByVal image As Long, ByVal thumbWidth As Long, ByVal thumbHeight As Long, thumbImage As Long, Optional ByVal callback As Long = 0, Optional ByVal callbackData As Long = 0) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "ogl" (ByVal hbm As Long, ByVal hpal As Long, bitmap As Long) As Long
Private Declare Function GdipCreateBitmapFromHICON Lib "gdiplus" (ByVal hicon As Long, bitmap As Long) As Long
Private Declare Function GdipGetImageWidth Lib "ogl" (ByVal image As Long, Width As Long) As Long
Private Declare Function GdipGetImageHeight Lib "ogl" (ByVal image As Long, Height As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "ogl" (ByVal image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function GdipSaveImageToStream Lib "ogl" (ByVal image As Long, ByVal stream As IUnknown, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function GdipLoadImageFromStream Lib "ogl" (ByVal stream As IUnknown, image As Long) As Long
Private lGDIP As Long
Function InitGDIP() As Boolean
Dim TGDP As GDIPStartupInput
Dim hMod As Long
If lGDIP = 0 Then
If IsNull(TempVars("GDIPlusHandle")) Then
TGDP.GdiplusVersion = 1
hMod = GetModuleHandle("ogl.dll")
If hMod = 0 Then
hMod = LoadLibrary(Environ$("CommonProgramFiles") & "\Microsoft Shared\Office12\ogl.dll")
End If
GdiplusStartup lGDIP, TGDP
TempVars("GDIPlusHandle") = lGDIP
Else
lGDIP = TempVars("GDIPlusHandle")
End If
End If
InitGDIP = (lGDIP > 0)
AutoShutDown
End Function
Sub ShutDownGDIP()
If lGDIP <> 0 Then
GdiplusShutdown lGDIP
lGDIP = 0
TempVars("GDIPlusHandle") = Null
End If
End Sub
Private Sub AutoShutDown()
If lGDIP <> 0 Then
SetTimer 0&, 0&, 5000, AddressOf TimerProc
End If
End Sub
Private Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
Debug.Print "GDI+ AutoShutDown"
KillTimer 0&, idEvent
ShutDownGDIP
End Sub
Function LoadPictureGDIP(sFileName As String) As StdPicture
Dim hBmp As Long
Dim hPic As Long
If Not InitGDIP Then Exit Function
If GdipCreateBitmapFromFile(StrPtr(sFileName), hPic) = 0 Then
GdipCreateHBITMAPFromBitmap hPic, hBmp, 0&
If hBmp <> 0 Then
Set LoadPictureGDIP = BitmapToPicture(hBmp)
GdipDisposeImage hPic
End If
End If
End Function
Function ResampleGDIP(ByVal image As StdPicture, ByVal Width As Long, ByVal Height As Long, _
Optional bSharpen As Boolean = True) As StdPicture
Dim lRes As Long
Dim lBitmap As Long
If Not InitGDIP Then Exit Function
If image.type = 1 Then
lRes = GdipCreateBitmapFromHBITMAP(image.Handle, 0, lBitmap)
Else
lRes = GdipCreateBitmapFromHICON(image.Handle, lBitmap)
End If
If lRes = 0 Then
Dim lThumb As Long
Dim hBitmap As Long
lRes = GdipGetImageThumbnail(lBitmap, Width, Height, lThumb, 0, 0)
If lRes = 0 Then
If image.type = 3 Then
lRes = GdipCreateHICONFromBitmap(lThumb, hBitmap)
Set ResampleGDIP = BitmapToPicture(hBitmap, True)
Else
lRes = GdipCreateHBITMAPFromBitmap(lThumb, hBitmap, 0)
Set ResampleGDIP = BitmapToPicture(hBitmap)
End If
GdipDisposeImage lThumb
End If
GdipDisposeImage lBitmap
End If
End Function
Function GetDimensionsGDIP(ByVal image As StdPicture) As TSize
Dim lRes As Long
Dim lBitmap As Long
Dim x As Long, y As Long
If Not InitGDIP Then Exit Function
If image Is Nothing Then Exit Function
lRes = GdipCreateBitmapFromHBITMAP(image.Handle, 0, lBitmap)
If lRes = 0 Then
GdipGetImageHeight lBitmap, y
GdipGetImageWidth lBitmap, x
GetDimensionsGDIP.x = CDbl(x)
GetDimensionsGDIP.y = CDbl(y)
GdipDisposeImage lBitmap
End If
End Function
Function SavePicGDIPlus(ByVal image As StdPicture, sFile As String, _
PicType As PicFileType, Optional Quality As Long = 80) As Boolean
Dim lBitmap As Long
Dim TEncoder As GUID
Dim ret As Long
Dim TParams As EncoderParameters
Dim sType As String
If Not InitGDIP Then Exit Function
If GdipCreateBitmapFromHBITMAP(image.Handle, 0, lBitmap) = 0 Then
Select Case PicType
Case pictypeBMP: sType = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Case pictypeGIF: sType = "{557CF402-1A04-11D3-9A73-0000F81EF32E}"
Case pictypePNG: sType = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Case pictypeJPG: sType = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
End Select
CLSIDFromString StrPtr(sType), TEncoder
If PicType = pictypeJPG Then
TParams.count = 1
With TParams.Parameter
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .UUID
.NumberOfValues = 1
.type = 4
.Value = VarPtr(CLng(Quality))
End With
Else
If (PicType = pictypeGIF) Then TParams.count = 1 Else TParams.count = 0
End If
ret = GdipSaveImageToFile(lBitmap, StrPtr(sFile), TEncoder, TParams)
GdipDisposeImage lBitmap
DoEvents
SavePicGDIPlus = (dir(sFile) <> "")
End If
End Function
Function ArrayFromPicture(ByVal image As Object, PicType As PicFileType, Optional Quality As Long = 80) As Byte()
Dim lBitmap As Long
Dim TEncoder As GUID
Dim ret As Long
Dim TParams As EncoderParameters
Dim sType As String
Dim IStm As IUnknown
If Not InitGDIP Then Exit Function
If GdipCreateBitmapFromHBITMAP(image.Handle, 0, lBitmap) = 0 Then
Select Case PicType
Case pictypeBMP: sType = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Case pictypeGIF: sType = "{557CF402-1A04-11D3-9A73-0000F81EF32E}"
Case pictypePNG: sType = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Case pictypeJPG: sType = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
End Select
CLSIDFromString StrPtr(sType), TEncoder
If PicType = pictypeJPG Then
TParams.count = 1
With TParams.Parameter
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .UUID
.NumberOfValues = 1
.type = 4
.Value = VarPtr(CLng(Quality))
End With
Else
If (PicType = pictypeGIF) Then TParams.count = 1 Else TParams.count = 0
End If
ret = CreateStreamOnHGlobal(0&, 1, IStm)
ret = GdipSaveImageToStream(lBitmap, IStm, TEncoder, TParams)
If ret = 0 Then
Dim hMem As Long, LSize As Long, lpMem As Long
Dim abData() As Byte
ret = GetHGlobalFromStream(IStm, hMem)
If ret = 0 Then
LSize = GlobalSize(hMem)
lpMem = GlobalLock(hMem)
ReDim abData(LSize - 1)
CopyMemory abData(0), ByVal lpMem, LSize
GlobalUnlock hMem
ArrayFromPicture = abData
End If
Set IStm = Nothing
End If
GdipDisposeImage lBitmap
End If
End Function
Public Function AttachmentToPicture(strTable As String, strAttachmentField As String, strImage As String) As StdPicture
Dim strSQL As String
Dim bin() As Byte
Dim nOffset As Long
Dim nSize As Long
strSQL = "SELECT " & strTable & "." & strAttachmentField & ".FileData AS data " & _
"FROM " & strTable & _
" WHERE " & strTable & "." & strAttachmentField & ".FileName='" & strImage & "'"
On Error Resume Next
bin = DBEngine(0)(0).OpenRecordset(strSQL, dbOpenSnapshot)(0)
If Err.Number = 0 Then
Dim bin2() As Byte
nOffset = bin(0)
nSize = UBound(bin)
ReDim bin2(nSize - nOffset)
CopyMemory bin2(0), bin(nOffset), nSize - nOffset
Set AttachmentToPicture = ArrayToPicture(bin2)
Erase bin2
Erase bin
End If
End Function
Public Function ArrayToPicture(ByRef PicBin() As Byte) As StdPicture
Dim IStm As IUnknown
Dim lBitmap As Long
Dim hBmp As Long
Dim ret As Long
If Not InitGDIP Then Exit Function
ret = CreateStreamOnHGlobal(VarPtr(PicBin(0)), 0, IStm)
If ret = 0 Then
ret = GdipLoadImageFromStream(IStm, lBitmap)
If ret = 0 Then
GdipCreateHBITMAPFromBitmap lBitmap, hBmp, 0&
If hBmp <> 0 Then
Set ArrayToPicture = BitmapToPicture(hBmp)
End If
End If
GdipDisposeImage lBitmap
End If
End Function
Function BitmapToPicture(ByVal hBmp As Long, Optional bIsIcon As Boolean = False) As StdPicture
Dim TPicConv As PICTDESC, UID As GUID
With TPicConv
If bIsIcon Then
.cbSizeOfStruct = 16
.PicType = 3
Else
.cbSizeOfStruct = Len(TPicConv)
.PicType = 1
End If
.hImage = hBmp
End With
CLSIDFromString StrPtr(GUID_IPicture), UID
OleCreatePictureIndirect TPicConv, UID, True, BitmapToPicture
End Function
|