1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85
| Option Explicit
Private Declare Function OleCreatePictureIndirect Lib "olepro32" _
(pPictDesc As PICTDESC, riid As GUID, ByVal fOwn As Long, ppvObj As Any) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal Hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal Hwnd As Long, ByVal DC As Long) As Long
Private Declare Function CoCreateInstance Lib "ole32" (clsid As GUID, ByVal unkOuter As Long, _
ByVal dwClsContext As Long, iid As GUID, pv As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" _
(ByVal str As Long, id As GUID) As Long
Private Type PICTDESC
cbSizeOfStruct As Long
picType As Long
hbitmap As Long
hpal As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type APISIZE
cx As Long
cy As Long
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private CLASS_ShellImageDataFactory As GUID
Private IID_IUnknown As GUID
Private IID_IPicture As GUID
Private Function NewGdiPlusObj() As IShellImageDataFactory
If IID_IUnknown.Data4(7) = 0 Then
CLSIDFromString StrPtr("{66e4e4fb-f385-4dd0-8d74-a2efd1bc6178}"), CLASS_ShellImageDataFactory
CLSIDFromString StrPtr("{00000000-0000-0000-C000-000000000046}"), IID_IUnknown
CLSIDFromString StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture
End If
Call CoCreateInstance(CLASS_ShellImageDataFactory, 0, 5, IID_IUnknown, NewGdiPlusObj)
End Function
Public Function LoadPictureEx(Filename As String) As IPicture
Dim DC As Long, CDc As Long
Dim hbitmap As Long
Dim Disp As PICTDESC
Dim Sz As APISIZE
Dim Sh As IShellImageDataFactory
Dim ShImg As IShellImageData
Dim OldBmp As Long
Dim R As RECT
On Error GoTo ErrHandler
Set Sh = NewGdiPlusObj
Set ShImg = Sh.CreateImageFromFile(Filename)
Call ShImg.Decode(0, 0, 0)
ShImg.GetSize Sz
DC = GetDC(0)
hbitmap = CreateCompatibleBitmap(DC, Sz.cx, Sz.cy)
If hbitmap = 0 Then Exit Function
R.Right = Sz.cx
R.Bottom = Sz.cy
CDc = CreateCompatibleDC(DC)
OldBmp = SelectObject(CDc, hbitmap)
Call ShImg.Draw(CDc, R, R)
Disp.cbSizeOfStruct = Len(Disp)
Disp.picType = 1
Disp.hbitmap = hbitmap
Call SelectObject(CDc, OldBmp)
Call DeleteObject(CDc)
Call ReleaseDC(0, DC)
Call OleCreatePictureIndirect(Disp, IID_IPicture, 1, LoadPictureEx)
ErrHandler:
End Function |
Partager