· 5 years ago · Aug 04, 2020, 04:58 AM
1'========================================================================================================
2' Class purpose and usage
3'========================================================================================================
4' The class is defined as predeclared. This means you do not create an instance of it. An instance is
5' created automatically when your project is run, similar to a .bas module. You do not unload it or set
6' it to Nothing. You can access its properties/methods directly by its name, i.e., StdPictureEx.LoadPicture
7
8' Requirements: This class requires GDI+ and XP operating system or higher. If the class fails to load
9' GDI+ or runs on a system lower than XP, then all functions may fail over to VB's standard picture
10' functions as if this class does not even exist. Unicode support may still be provided, but no
11' additional enhancements will be available. If you wish to code this for lower operating systems,
12' you will need to ensure CreateIconFromResourceEx API usage does not fail. 32bpp icons were introduced
13' with XP and will not be supported on lower operating systems. The GDI+ requirement remains.
14
15' Enhancements: These formats are supported: BMP,ICO,CUR,WMF,EMF,JPG,PNG,TIF,GIF.
16' Additionally, unicode support is provided for path and file names. Proper 32bpp icon rendering is
17' supported. PNG-encoded icons are supported. Caching of supported image formats can be performed and
18' saved to file. Navigation of TIF pages and GIF frames are supported. This means you can animate GIFs.
19' Depending on system settings, bitmap formats that include color management are supported. In any case,
20' bitmaps with both true and premultiplied alpha channels are supported. The LoadPicture and SavePicture
21' methods also will accept byte arrays and existing stdPicture objects, along with file names.
22
23' When to refresh picture's container object? When calling the SubImage() method to change the frame of
24' an animated GIF or page of a multipage TIF, the container may need to be refreshed. If the return
25' result from SubImage() is assigned to a VB image control, generally refresh otherwise not needed.
26' When in doubt, you can always refresh the container. If the SubImage() picture's Handle property
27' value is same as the picture passed to that method, refreshing is usually required. When this
28' class changes the frame/page of a picture, it attempts to re-use the previous frame/page and simply
29' update the pixel data. This may not trigger a change in picture to VB, thus refreshing may be needed.
30
31' The term 'managed', within this class, indicates that the class is rendering the image. This class will
32' render the 32bpp bitmaps it creates and also 32bpp icons since VB does not do these. When the picture
33' is eventually set to Nothing or replaced by another image, this class will be informed via the thunks
34' it created and will release any cached data at that time and dispose of any related GDI+ image.
35
36' In order to support alpha channel image formats, any returned stdPicture object may contain an
37' alpha-blended bitmap having its bits premultiplied for use with AlphaBlend API. That API is used to
38' render semi-transparency in bitmaps. When the class' IsManaged property returns true, then if the
39' Picture.Type value is vbPicTypeBitmap, the bitmap bits are premultiplied. Because of this bitmap
40' format, you should not pass the stdPicture outside of your project. The receiving end may not know
41' how to render the image. If needed, you can call the StdPictureEx.SavePicture method and convert
42' the bitmap to a standard bitmap. Any transparency in the bitmap will be rendered over a background
43' color you provided to SavePicture. That method, in that case, always produces a 24bpp bitmap.
44
45' When possible, the cached data is done so that VB also has access to it via the stdPicture itself.
46' This applies to non-CMYK JPGs, single-frame GIFs, many icons and most bitmaps. For all other cases,
47' the cached data is stored by this class and is not accessible by VB. The StdPictureEx.SavePicture
48' method can be used to save this cached data to file. Bitmap and metafile formats are not cached.
49' General rule of thumb. If caching original data is wanted and VB can load the image without color
50' loss, then the image will be loaded via GDI+ and data will be cached by VB/COM. If this cannot be
51' done, then this class will cache the data and manage the picture so the class will know when to
52' dispose of the cached data.
53
54' The class creates two assembly thunks (executable code in memory). These thunks are only used to
55' prevent crashes, during IDE, when subclassing VB picture objects. Their purposes are briefly
56' described next. By existing in memory unknown to VB, the thunks are not destroyed when your project
57' closes due to executing an End statement via code, IDE toolbar button or debug message box. Since
58' the thunk isn't released in that scenario, its code remains alive, crashes are prevented unlike
59' standard subclassing.
60'--------------------------------------------------------------------------------------------------------
61' Thunk #1: Management Window. This window is created the first time this class loads and remains alive
62' until the project or IDE completely unloads. The thunk is the window's subclassed window procedure.
63' When the window is destroyed (when project/VB closes), then it properly shuts down GDI+ after
64' first releasing any GDI+ image objects that may have been created. It releases Thunk#2 and the
65' copy of the COM IPicture/IPictureDisp virtual table. The closure of the project's thread releases
66' this thunk.
67
68' Thunk #2: IPicture/IPictureDisp subclasser. This is also only created once. Whenever pictures are
69' subclassed, just 4 of the many picture functions are subclassed, the others are untouched. The
70' thunk will do the drawing of any subclassed pictures. It also informs this class when a subclassed
71' picture is eventually destroyed. The four picture functions that are subclassed/tweaked are:
72' 1. IPictureDisp's IUnknown:Release. Tracks when picture is set to nothing or replaced
73' 2. IPicture's IUnknown:Release. Tracks when picture is set to nothing or replaced
74' 3. IPicture:Get_Attributes. Forces VB to see our subclassed image as transparent. Why?
75' VB will only refresh/redraw the area behind the image if it believes the image has
76' transparency. By default, only GIFs are recognized 'bitmap' formats that support
77' transparency. Subclassing this function/property ensures we can fool VB into believing
78' whatever we want has transparency.
79' 4. IPicture:Render. Uses AlphaBlend API to draw bitmaps and DrawIconEx API to draw
80' icons,cursors.
81' FYI: Reason both IUnknown:Release functions are subclassed is that when a picture is set to
82' nothing or is replaced or goes out of scope, COM does not expose the zero-reference count in
83' both interfaces. It does this in one or the other. So both are tracked to ensure we know when
84' it reaches zero.
85
86' VTable Copy: COM appears to handle all pictures via a single interface instance within the current
87' thread. All created pictures are processed by this single VTable. To subclass the VTable, this
88' class makes a copy of that VTable, then tweaks that copy. All subclassed pictures are rerouted
89' to this tweaked VTable. All other picture objects are left untouched. Reversing this can be done
90' via the UnManage method.
91'========================================================================================================
92
93Option Explicit
94'///// GDI functions
95Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hDC As Long, ByVal nIndex As Long) As Long
96Private Declare Function GetObjectA Lib "gdi32.dll" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
97Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
98Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hDC As Long) As Long
99Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
100Private Declare Function CreateDIBSection Lib "gdi32.dll" (ByVal hDC As Long, ByRef pBitmapInfo As Any, ByVal un As Long, ByRef lplpVoid As Long, ByVal Handle As Long, ByVal dw As Long) As Long
101Private Declare Function SetDIBits Lib "gdi32.dll" (ByVal hDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, ByRef lpBits As Any, ByRef lpBI As Any, ByVal wUsage As Long) As Long
102Private Declare Function GetDIBits Lib "gdi32.dll" (ByVal hDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, ByRef lpBits As Any, ByRef lpBI As Any, ByVal wUsage As Long) As Long
103Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hDC As Long) As Long
104Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
105Private Declare Function DeleteEnhMetaFile Lib "gdi32.dll" (ByVal hEMF As Long) As Long
106'///// User32 functions
107Private Declare Function GetIconInfo Lib "user32.dll" (ByVal hIcon As Long, ByRef piconinfo As Any) As Long
108Private Declare Function GetSysColor Lib "user32.dll" (ByVal nIndex As Long) As Long
109Private Declare Function FillRect Lib "user32.dll" (ByVal hDC As Long, ByRef lpRect As RECTI, ByVal hBrush As Long) As Long
110Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
111Private Declare Function GetWindowThreadProcessId Lib "user32.dll" (ByVal hWnd As Long, ByRef lpdwProcessId As Long) As Long
112Private Declare Function GetWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
113Private Declare Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
114Private Declare Function SetProp Lib "user32.dll" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
115Private Declare Function GetProp Lib "user32.dll" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
116Private Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
117Private Declare Function CopyImage Lib "user32.dll" (ByVal Handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
118Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
119Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
120Private Declare Function DestroyIcon Lib "user32.dll" (ByVal hIcon As Long) As Long
121Private Declare Function DestroyCursor Lib "user32.dll" (ByVal hCursor As Long) As Long
122Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
123Private Declare Function CreateIconFromResourceEx Lib "user32.dll" (ByRef presbits As Any, ByVal dwResSize As Long, ByVal fIcon As Long, ByVal dwVer As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal flags As Long) As Long
124Private Const LR_CREATEDIBSECTION As Long = &H2000
125'///// Kernel32 functions
126Private Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
127Private Declare Function VirtualFree Lib "kernel32.dll" (ByRef lpAddress As Any, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
128Private Declare Function VirtualQuery Lib "kernel32.dll" (ByRef lpAddress As Any, ByRef lpBuffer As Any, ByVal dwLength As Long) As Long
129Private Declare Sub FillMemory Lib "kernel32.dll" Alias "RtlFillMemory" (ByRef Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
130Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
131Private Declare Function GlobalFree Lib "kernel32.dll" (ByVal hMem As Long) As Long
132Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
133Private Declare Function GlobalSize Lib "kernel32.dll" (ByVal hMem As Long) As Long
134Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
135Private Declare Function ReadFile Lib "kernel32.dll" (ByVal hFile As Long, ByRef lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, ByRef lpNumberOfBytesRead As Long, ByRef lpOverlapped As Any) As Long
136Private Declare Function WriteFile Lib "kernel32.dll" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
137Private Declare Function CreateFileW Lib "kernel32.dll" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
138Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
139Private Declare Function SetFilePointer Lib "kernel32.dll" (ByVal hFile As Long, ByVal lDistanceToMove As Long, ByRef lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
140Private Declare Function GetFileSize Lib "kernel32.dll" (ByVal hFile As Long, ByRef lpFileSizeHigh As Long) As Long
141Private Declare Function IsBadCodePtr Lib "kernel32.dll" (ByVal lpfn As Long) As Long
142Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
143Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
144Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
145Private Declare Function GetModuleHandle Lib "kernel32.dll" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
146Private Declare Function VirtualAlloc Lib "kernel32.dll" (ByVal lpAddress As Any, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
147'///// GDI+ functions
148Private Declare Function GdiplusStartup Lib "GdiPlus.dll" (Token As Long, inputbuf As Any, Optional ByVal outputbuf As Long = 0) As Long
149Private Declare Sub GdiplusShutdown Lib "GdiPlus.dll" (ByVal Token As Long)
150Private Declare Function GdipGetImageType Lib "GdiPlus.dll" (ByVal Image As Long, pType As Long) As Long
151Private Declare Function GdipDisposeImage Lib "GdiPlus.dll" (ByVal Image As Long) As Long
152Private Declare Function GdipLoadImageFromStream Lib "GdiPlus.dll" (ByVal Stream As Long, Image As Long) As Long
153Private Declare Function GdipBitmapLockBits Lib "GdiPlus.dll" (ByVal mBitmap As Long, ByRef mRect As RECTI, ByVal mFlags As Long, ByVal mPixelFormat As Long, ByRef mLockedBitmapData As BitmapData) As Long
154Private Declare Function GdipBitmapUnlockBits Lib "GdiPlus.dll" (ByVal mBitmap As Long, ByRef mLockedBitmapData As BitmapData) As Long
155Private Declare Function GdipCreateBitmapFromScan0 Lib "GdiPlus.dll" (ByVal Width As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, BITMAP As Long) As Long
156Private Declare Function GdipGetImageBounds Lib "GdiPlus.dll" (ByVal nImage As Long, srcRect As RECTF, srcUnit As Long) As Long
157Private Declare Function GdipGetImagePixelFormat Lib "GdiPlus.dll" (ByVal hImage As Long, PixelFormat As Long) As Long
158Private Declare Function GdipImageSelectActiveFrame Lib "GdiPlus.dll" (ByVal Image As Long, ByRef dimensionID As Any, ByVal FrameIndex As Long) As Long
159Private Declare Function GdipImageGetFrameCount Lib "GdiPlus.dll" (ByVal Image As Long, ByRef dimensionID As Any, ByRef count As Long) As Long
160Private Declare Function GdipImageGetFrameDimensionsCount Lib "GdiPlus.dll" (ByVal pImage As Long, ByRef count As Long) As Long
161Private Declare Function GdipGetImageRawFormat Lib "GdiPlus.dll" (ByVal hImage As Long, ByVal GUID As Long) As Long
162Private Declare Function GdipImageGetFrameDimensionsList Lib "GdiPlus.dll" (ByVal pImage As Long, ByRef dimensionIDs As Any, ByVal count As Long) As Long
163Private Declare Function GdipEmfToWmfBits Lib "GdiPlus.dll" (ByVal hEMF As Long, ByVal cbData16 As Long, ByVal pData16 As Long, ByVal iMapMode As Long, ByVal eFlags As Long) As Long
164Private Declare Function GdipGetHemfFromMetafile Lib "GdiPlus.dll" (ByVal metafile As Long, ByRef hEMF As Long) As Long
165Private Declare Function GdipGetPropertyItemSize Lib "GdiPlus.dll" (ByVal pImage As Long, ByVal propId As Long, ByRef pSize As Long) As Long
166Private Declare Function GdipGetPropertyItem Lib "GdiPlus.dll" (ByVal pImage As Long, ByVal propId As Long, ByVal propSize As Long, ByRef buffer As Any) As Long
167Private Const ImageLockModeUserInputBuf As Long = &H4&
168Private Const ImageLockModeRead As Long = &H1&
169Private Const PixelFormat32bppPremultiplied As Long = &HE200B
170Private Const PixelFormat32bppAlpha As Long = &H26200A
171Private Const PixelFormat32bpp As Long = &H262000
172Private Const PixelFormat24bpp As Long = &H21808
173'///// Misc functions
174Private Declare Function OleLoadPicture Lib "OLEPRO32.DLL" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As Long, riid As Any, ppvObj As Any) As Long
175Private Declare Function OleCreatePictureIndirect Lib "OLEPRO32.DLL" (lpPictDesc As Any, riid As Any, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
176Private Declare Function CreateStreamOnHGlobal Lib "ole32.dll" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
177Private Declare Function StringFromGUID2 Lib "ole32.dll" (ByVal rguid As Long, ByVal lpsz As Long, ByVal cchMax As Long) As Long
178Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, ByRef lpiid As Any) As Long
179Private Declare Function GetHGlobalFromStream Lib "ole32.dll" (ByVal ppstm As Long, hGlobal As Long) As Long
180Private Declare Function CoTaskMemRealloc Lib "ole32.dll" (ByVal pv As Long, ByVal cb As Long) As Long
181Private Declare Function GetFileVersionInfo Lib "Version.dll" Alias "GetFileVersionInfoA" (ByVal lptstrFilename As String, ByVal dwhandle As Long, ByVal dwlen As Long, lpData As Any) As Long
182Private Declare Function GetFileVersionInfoSize Lib "Version.dll" Alias "GetFileVersionInfoSizeA" (ByVal lptstrFilename As String, lpdwHandle As Long) As Long
183Private Declare Function VerQueryValue Lib "Version.dll" Alias "VerQueryValueA" (pBlock As Any, ByVal lpSubBlock As String, lplpBuffer As Any, puLen As Long) As Long
184Private Declare Function ImageList_GetIconSize Lib "Comctl32.dll" (ByVal hIML As Long, Cx As Long, Cy As Long) As Long
185Private Declare Function SHGetImageListXP Lib "Shell32.dll" Alias "#727" (ByVal iImageList As Long, ByRef riid As Long, ByVal ppv As Long) As Long
186Private Declare Function DispCallFunc Lib "oleaut32.dll" (ByVal pvInstance As Long, ByVal offsetinVft As Long, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByVal paTypes As Long, ByVal paValues As Long, ByRef retVAR As Variant) As Long
187
188Private Type RECTF ' GDI+ rectangle w/Single vartypes
189 nLeft As Single
190 nTop As Single
191 nWidth As Single
192 nHeight As Single
193End Type
194Private Type RECTI ' GDI/GDI+ rectangle w/Long vartypes
195 nLeft As Long
196 nTop As Long
197 nWidth As Long
198 nHeight As Long
199End Type
200Private Type BitmapData ' GDI+ lock/unlock bits structure
201 Width As Long
202 Height As Long
203 stride As Long
204 PixelFormat As Long
205 Scan0Ptr As Long
206 ReservedPtr As Long
207End Type
208Private Type ICONDIR
209 idReserved As Integer ' per msdn: must be zero
210 idType As Integer ' per msdn: must be 1 or 2
211 idCount As Integer ' unsigned
212End Type
213Private Type ICONDIRENTRY
214 bWidth As Byte ' will be 0 when width > 255
215 bHeight As Byte ' will be 0 when height > 255
216 bColorCount As Byte ' not used in this class; not applicable if > 8bpp
217 bReserved As Byte
218 wPlanes As Integer
219 wBitCount As Integer ' not used in this class; extracted from image data instead
220 dwBytesInRes As Long ' how many bytes are used by the image data
221 dwImageOffset As Long ' where in icon resource, image data begins (bmp/png header)
222End Type
223Private Type BITMAPV5HEADER
224 biSize As Long
225 biWidth As Long
226 biHeight As Long
227 biPlanes As Integer
228 biBitCount As Integer
229 ' up to this point: BITMAPCOREHEADER 12 bytes (biWidth/biHeight INTEGER vs LONG, bitcount=1,4,8,24 only)
230 biCompression As Long
231 biSizeImage As Long
232 biXPelsPerMeter As Long
233 biYPelsPerMeter As Long
234 biClrUsed As Long
235 biClrImportant As Long
236 ' v2 starts next(52 bytes)
237 bV2RedMask As Long ' offset 40
238 bV2GreenMask As Long
239 bV2BlueMask As Long
240 ' v3 starts next (56 bytes)
241 bV3AlphaMask As Long ' offset 52
242 ' v4 starts next (108 bytes)
243 bV4CSType As Long
244 bV4Endpoints(0 To 8) As Long ' offset 60 << actually bv4Endpoints declared as CIEXYZTRIPLE
245 bV4GammaRed As Long
246 bV4GammaGreen As Long
247 bV4GammaBlue As Long
248 ' v5 starts next (124 bytes)
249 bV5Intent As Long ' offset 108
250 bV5ProfileData As Long ' offset 112
251 bV5ProfileSize As Long ' offset 116
252 bV5Reserved As Long
253End Type
254
255Private Type PICREF ' Used only to track GDI+ image creation/disposal
256 flags As Long
257 ' 0x0000000F ' PictureTypeConstantsEx value
258 ' 0x0000FFF0 ' current frame (GIF/TIF)
259 ' 0x0FFF0000 ' current frame count (GIF/TIF), max 4095
260 ' 0xF0000000 ' reserved
261 pIPicture As Long ' ObjPtr(IPicture)
262 pIPicDisp As Long ' ObjPtr(IPictureDisp)
263 pHandle As Long ' GDI+ image handle reference (multi-frame/page images only)
264 oStream As IUnknown ' Cached data (IStream). Optional
265End Type
266
267Public Enum PictureTypeConstantsEx ' Used as return value for PictureType property
268 ptcNone = vbPicTypeNone
269 ptcBitmap = vbPicTypeBitmap ' BMP & if original format not cached: converted TIF,JPG,PNG,GIF
270 ptcIcon = vbPicTypeIcon ' VB does not distinguish btwn icon and cursor
271 ptcMetafile = vbPicTypeMetafile
272 ptcEMetafile = vbPicTypeEMetafile
273 ptcJPEG = vbPicTypeEMetafile + 1&
274 ptcPNG = vbPicTypeEMetafile + 2&
275 ptcGIF = vbPicTypeEMetafile + 3& ' frame count/navigation available. See LoadPicture method
276 ptcTIF = vbPicTypeEMetafile + 4& ' page count/navigation available. See LoadPicture method
277End Enum
278Public Enum LoadPictureSizeConstantsEx
279 lpsSmall = vbLPSmall ' system small icon size, 16x16
280 lpsLarge = vbLPLarge ' system large icon size, usually 32x32
281 lpsSmallShell = vbLPSmallShell ' shell small icon size, usually 16x16 (DPI scalale)
282 lpsLargeShell = vbLPLargeShell ' shell large icon size, usually 32x32 (DPI scalable)
283 lpsCustom = vbLPCustom ' user-defined size. LoadPicture DesiredIconCx/Cy parameters apply
284 lpsDefault = -1& ' if just 1 icon exists, actual size else lpsLarge
285 lpsXtraLargeShell = -2& ' shell extra large size, usually 48x48 (DPI scalable) XP+
286 lpsJumboShell = -3& ' shell jump size, 256x256 (Vista+)
287End Enum ' note: if shell sizes fail to be retrieved, above sizes are used instead
288
289Private m_PageGUID(0 To 3, 0 To 1) As Long ' used to change frames/pages of GIF/TIF
290Private m_hDC As Long ' general usage. Is zero if class failed to initialize properly
291Private m_RefCount As Long ' number of m_PicRef() items
292Private m_PicRefs() As PICREF ' collection of managed picture data (-1 LBound)
293Private m_Primary As StdPictureEx ' subclassing class instance if not this class instance
294Private m_Hwnd As Long ' management window handle
295Private m_ThunkPtr As Long ' address of IPicture/IPictureDisp subclassing thunk
296Private m_VistaPlus As Boolean ' are we running in Vista or better?
297
298Public Function LoadPicture(Optional ImageSource As Variant, _
299 Optional ByVal IconSize As LoadPictureSizeConstantsEx = lpsDefault, _
300 Optional ByVal IconColorDepth As Long, _
301 Optional ByVal DesiredIconCx As Long, _
302 Optional ByVal DesiredIconCy As Long, _
303 Optional ByVal KeepOriginalFormat As Boolean = False, _
304 Optional ByVal RequiredFormat As PictureTypeConstants = vbPicTypeNone) As StdPicture
305
306'========================================================================================================
307' Key notes. Method replicates VB's LoadPicture function and adds more options
308'========================================================================================================
309' Returned Picture object is always a new object, never a reference to source, with one exception.
310' If ImageSource is a stdPicture object and this method fails, then it will return a reference to
311' the passed stdPicture vs. Nothing.
312' When assigning returned picture to image control, you should refresh image control.
313' Unicode file names are supported.
314' GDI+ is used to support TIF, PNG, CMYK JPGs, non-placeable WMF, and GIF.
315' note: Different versions of GDI+ support different TIF compression schemes. Therefore, a TIF loaded
316' on Win7 may fail to load on Vista or XP.
317'========================================================================================================
318
319'========================================================================================================
320' Parameters
321'========================================================================================================
322' ImageSource. One of the following can be provided. Anything else returns Nothing
323' Path/file name of image, as a String. Unicode supported
324' Byte array of complete image format/data, one dimensional only
325' Existing stdPicture/IPictureDisp object (basically any VB icon/picture property).
326' A copy of the passed Picture's data/format will be used. You should not pass that picture
327' unless there is a need to duplicate it, waste of system resources. Here are some reasons
328' to pass an existing Picture object:
329' 1. It is unmanaged and contains a 32bpp alpha bitmap and transparency is wanted
330' 2. You want to return the current frame/page of a mutli-frame/page GIF/TIF
331' 3. You want a copy of the passed Picture and its cached data
332' So, after what was just said, this is what you can expect if passing a stdPicture object:
333' - Managed, multi-Page/Frame GIF/TIF.
334' If KeepOriginalFormat=True then a copy else single frame/page
335' - Any other scenario returns a copy of image & cached data if KeepOriginalFormat=True
336'
337' IconSize. Applies if loading icons,cursors or if RequiredFormat is vbPicTypeIcon
338' lpsDefault. If only 1 icon exists in ImageSource, it is uses as-is else a lpsLarge is the size used.
339' lpsLarge. Uses the system's large icon size, usually 32x32 but can be larger
340' lpsSmall. Uses the system's small icon size, currently fixes at 16x16
341' lpsSmallShell. Windows shell small icon size, usually 16x16 (scales with DPI)
342' lpsLargeShell. Windows shell large icon size, usually 32x32 (scales with DPI)
343' lpsExtraLargeShell. Windows shell extra large icon size, usually 48x48 (scales with DPI) (XP or better)
344' lpsJumboShell. Windows shell jumbo icon size, currently fixed at 256x256 (Vista or better)
345' lpsCustom. The DesiredCx,DesiredCy parameters are used else always ignored
346'
347' IconColorDepth. Applies if loading icons,cursors or if RequiredFormat is vbPicTypeIcon
348' 0 = use best color depth that matches the system's color depth
349' 1,4,8,16,24,32 = specific color depth. Next highest is used if no match is found
350'
351' DesiredIconCx,DesireIconCy. Applies if IconSize is lpsCustom and if ImageSource is icon,cursor
352' 0 = use system's large icon size
353' anything else will result in the icon matching the size being used else resized as needed
354'
355' KeepOriginalFormat. Applies to all image formats except BMP, WMF, EMF
356' Setting to True requires more memory to cache the format. Cached data is always the bits.
357' Caching original format data allows StdPictureEx.SavePicture to save the original data
358' Tip: do not set this to true if loading from a resource file unless animating a GIF
359' or navigating multipage TIF. You have it cached in resource file, no need to re-cache.
360' If needed, you can remove the cached data by calling this method again & set this parameter to false
361' WMF,EMF,BMP: Ignored. VB/COM can save to these formats without caching original format
362' ICO,CUR: VB can save to icon format, but reduces to 4bpp, degrading quality, therefore parameter applies.
363' If more than 1 icon/cursor exists in passed data, only the selected image data is cached, not all.
364' GIF,TIF: If multiple frames/pages exists, setting parameter to true allows selection of the frames/pages
365' If this parameter is False, the only image formats returned are: BMP,ICO,WMF,EMF
366' If this parameter is True, then PictureProperty of this class can return: BMP,ICO,WMF,EMF,JPG,PNG,TIF,GIF
367'
368' RequiredFormat. This option forces the returned picture to one of two formats
369' Only vbPicTypeBitmap and vbPicTypeIcon are accepted. KeepOriginalFormat does not apply if bitmap
370' is chosen. All parameters apply if icon is chosen This can be useful to force any loaded image to
371' icon and simultaneously resize the result by supplying the icon-related size parameters. Most VB
372' image properties accept icons but most icon properties do not accept bitmaps
373'========================================================================================================
374
375 Dim pPicRef As PICREF, newPic As IPictureDisp, bKeepData As Boolean
376
377 Call pvVerifyInitialization
378 ' note:if above call fails, then this class cannot be used. Actions default to VB methods only
379 ' if failure, then these variables will contain following values & may be tested elsewhere:
380 ' m_Primary is Nothing, m_hDC = 0, m_ThunkPtr = 0 or -1
381 If m_Primary Is Nothing Then
382 Select Case RequiredFormat
383 Case vbPicTypeIcon ' prevent caching original data until icon is created
384 bKeepData = KeepOriginalFormat: KeepOriginalFormat = False
385 Case vbPicTypeBitmap ' bitmaps do not cache original data
386 KeepOriginalFormat = False
387 Case vbPicTypeNone
388 Case Else: RequiredFormat = vbPicTypeNone
389 End Select
390 If DesiredIconCx < 0& Then DesiredIconCx = 0& Else DesiredIconCx = DesiredIconCx And &HFFF&
391 If DesiredIconCy < 0& Then DesiredIconCy = 0& Else DesiredIconCy = DesiredIconCy And &HFFF&
392 If IconColorDepth < 0& Then IconColorDepth = 0&
393
394 If IsMissing(ImageSource) = False Then
395 If IsEmpty(ImageSource) = False Then
396 If IsObject(ImageSource) Then
397 If Not ImageSource Is Nothing Then
398 If TypeOf ImageSource Is StdPicture Then
399 If Not ImageSource.Handle = 0& Then ' send off to be processed
400 Set newPic = ImageSource
401 Set newPic = pvLoadStdPicture(newPic, IconSize, DesiredIconCx, DesiredIconCy, _
402 KeepOriginalFormat, pPicRef)
403 If newPic Is Nothing Then Set newPic = ImageSource
404 End If
405 End If
406 End If
407 ElseIf VarType(ImageSource) = vbString Then
408 If Not ImageSource = vbNullString Then ' send off to be processed
409 Set newPic = pvLoadFile(CStr(ImageSource), IconSize, IconColorDepth, DesiredIconCx, DesiredIconCy, _
410 KeepOriginalFormat, pPicRef)
411 End If
412 ElseIf VarType(ImageSource) = (vbArray Or vbByte) Then
413 Dim iData() As Byte
414 On Error Resume Next
415 pPicRef.flags = LBound(ImageSource, 2)
416 If Err Then ' not multi-dimensional array
417 Err.Clear ' check for uninitialized/invalid arrays
418 If UBound(ImageSource) > LBound(ImageSource) Then
419 If Err.Number = 0& Then ' send off to be processed
420 On Error GoTo 0
421 iData() = ImageSource
422 Set newPic = pvLoadPicture(iData(), IconSize, IconColorDepth, DesiredIconCx, DesiredIconCy, _
423 KeepOriginalFormat, pPicRef)
424 End If
425 End If
426 End If
427 End If
428 End If
429 End If
430 Else
431 Set LoadPicture = m_Primary.LoadPicture(ImageSource)
432 End If
433
434 If Not newPic Is Nothing Then
435 If RequiredFormat = vbPicTypeBitmap Then
436 Set newPic = pvCvAnytoBMP(newPic, pPicRef)
437 ElseIf RequiredFormat = vbPicTypeIcon Then
438 Set newPic = pvCvAnyToICO(newPic, pPicRef, bKeepData, IconSize, DesiredIconCx, DesiredIconCy)
439 End If
440 ' when above pvLoad[xxx] calls return, the pPicRef.Flags is non-null if class will manage it
441 If pPicRef.flags Then
442 Dim nPic As IPicture
443 Set nPic = newPic: pPicRef.pIPicture = ObjPtr(nPic): Set nPic = Nothing
444 pPicRef.pIPicDisp = ObjPtr(newPic)
445 Call pvAddGDIpItem(pPicRef)
446 CopyMemory ByVal pPicRef.pIPicDisp, GetProp(m_Hwnd, "IPicDispAddr"), 4&
447 CopyMemory ByVal pPicRef.pIPicture, GetProp(m_Hwnd, "IPicAddr"), 4&
448 End If
449 Set LoadPicture = newPic
450 End If
451
452End Function
453
454Public Sub SavePicture(Picture As StdPicture, Destination As Variant, _
455 Optional ByVal AlwaysSaveAsBitmap As Boolean = False, _
456 Optional ByVal KeepPremultipliedBits As Boolean, _
457 Optional ByVal BitmapBkgColor As OLE_COLOR = vbWindowBackground)
458
459'========================================================================================================
460' Key notes. Method replicates VB's SavePicture function and adds more options
461' Unicode file names are supported
462' This function does no conversion between image formats, other than converting to bitmap as needed
463' If class is not initialized completely, results will be no worse than VB's SavePicture method
464'========================================================================================================
465
466'========================================================================================================
467' Parameters
468'========================================================================================================
469' Picture: Image to save
470
471' Destination can be one of these. Anything else cause routine to abort/fail
472' 1) Full path/filename to save to. Unicode supported.
473' You should call this class' PictureType property to determine image format for file extension
474' 2) A byte array. The entire image format would be returned in that array
475' When method returns successfully, array can be passed to LoadPicture if desired
476' 3) A stdPicture object, i.e., Dim myPic As New stdPicture. Copy is always returned
477
478' AlwaysSaveAsBitmap will force image format to 24 or 32 bit bitmap
479
480' KeepPremultipliedBits will save to 32bpp bitmap if the passed Picture
481' contains a 32bpp premultiplied bitmap
482
483' BitmapBkgColor is used if saving images with transparency to bitmap format.
484' VB system color constants are accepted, i.e., vbWindowBackground
485'========================================================================================================
486
487 Call pvVerifyInitialization
488 If m_Primary Is Nothing Then
489
490 If Picture Is Nothing Then Exit Sub
491 If Picture.Handle = 0& Then Exit Sub
492
493 Dim dFormat As Long, hFile As Long, icData() As Byte
494 Dim hDIB As Long, hBits As Long, lSize As Long, lErr As Long
495 Dim BIH As BITMAPV5HEADER, brRect As RECTI, p As PICREF
496 Dim Index As Long, lWritten As Long, oIPic As IPicture
497 Const FILE_ATTRIBUTE_NORMAL = &H80&
498 Const GENERIC_READ As Long = &H80000000
499 Const GENERIC_WRITE As Long = &H40000000
500 Const CREATE_ALWAYS As Long = 2&
501
502 If VarType(Destination) = vbString Then ' sanity checks
503 If Destination = vbNullString Then Exit Sub ' attempt to open new file
504 hFile = CreateFileW(StrPtr(CStr(Destination)), GENERIC_READ Or GENERIC_WRITE, 0&, 0&, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0&)
505 If hFile = -1& Then GoTo ExitRoutine
506 p.flags = 1&
507 ElseIf VarType(Destination) = (vbByte Or vbArray) Then
508 p.flags = 2&
509 ElseIf IsObject(Destination) Then
510 If TypeOf Destination Is StdPicture Then p.flags = 3&
511 End If
512 If p.flags = 0& Then lErr = 17&: GoTo ExitRoutine
513 dFormat = Me.PictureType(Picture) ' get format of Picture
514 Set oIPic = Picture
515 If AlwaysSaveAsBitmap Or (dFormat = ptcBitmap And Not oIPic.KeepOriginalFormat) Then
516 Index = pvPictureToIndex(Picture) ' convert/save to bitmap
517 With BIH
518 If Index > -1& And KeepPremultipliedBits = True Then ' managed, keep premultiplied bits?
519 If Picture.Type = ptcBitmap Then .biBitCount = 32 Else .biBitCount = 24
520 Else
521 .biBitCount = 24
522 End If
523 .biPlanes = 1: .biSize = 40
524 .biWidth = (1440! / Screen.TwipsPerPixelX) * Picture.Width / 2540!
525 .biHeight = (1440! / Screen.TwipsPerPixelY) * Picture.Height / 2540!
526 .biSizeImage = pvDWordAlign(.biBitCount, .biWidth, .biHeight)
527 End With ' create bitmap & bail on error
528 hDIB = CreateDIBSection(m_hDC, BIH, 0&, hBits, 0&, 0&)
529 If hDIB = 0& Then lErr = 7&: GoTo ExitRoutine
530 hDIB = SelectObject(m_hDC, hDIB)
531 If BIH.biBitCount = 24 Then ' fill with bkg color as needed
532 If BitmapBkgColor < 0& Then BitmapBkgColor = GetSysColor(BitmapBkgColor And &HFF)
533 p.pHandle = CreateSolidBrush(BitmapBkgColor)
534 brRect.nHeight = BIH.biHeight: brRect.nWidth = BIH.biWidth
535 FillRect m_hDC, brRect, p.pHandle: DeleteObject p.pHandle
536 End If
537 With Picture ' render to the bitmap
538 .Render (m_hDC), 0&, 0&, (BIH.biWidth), (BIH.biHeight), 0&, (.Height - 1&), .Width, -.Height, ByVal 0&
539 End With
540 hDIB = SelectObject(m_hDC, hDIB)
541
542 If p.flags = 3& Then
543 Set Destination = pvHandleToStdPicture(hDIB, vbPicTypeBitmap)
544 If Not Destination Is Nothing Then hDIB = 0& ' prevent destruction at end of routine
545 ElseIf p.flags = 2& Then
546 ReDim icData(0 To 53& + BIH.biSizeImage)
547 icData(0) = &H42: icData(1) = &H4D ' build bmp header
548 CopyMemory icData(2), CLng(BIH.biSizeImage + 54&), 4&
549 icData(10) = 54
550 CopyMemory icData(14), BIH, 40& ' copy bitmap
551 CopyMemory icData(54), ByVal hBits, BIH.biSizeImage
552 Else ' bail if error, likely out of disk space
553 WriteFile hFile, &H4D42, 2&, lWritten, ByVal 0& ' build bmp header
554 If Not lWritten = 2& Then GoTo ExitRoutine
555 WriteFile hFile, CLng(BIH.biSizeImage + 54&), 4&, lWritten, ByVal 0&
556 If Not lWritten = BIH.biSizeImage + 54& Then GoTo ExitRoutine
557 WriteFile hFile, 0&, 4&, lWritten, ByVal 0&
558 If Not lWritten = 4& Then GoTo ExitRoutine
559 WriteFile hFile, 54&, 4&, lWritten, ByVal 0&
560 If Not lWritten = 54& Then GoTo ExitRoutine
561 WriteFile hFile, BIH, 40&, lWritten, ByVal 0& ' write bitmap
562 If Not lWritten = 40& Then GoTo ExitRoutine
563 WriteFile hFile, ByVal hBits, BIH.biSizeImage, lWritten, ByVal 0&
564 If Not lWritten = BIH.biSizeImage Then GoTo ExitRoutine
565 End If
566
567 ElseIf p.flags = 3& Then
568 Set Destination = Me.LoadPicture(Picture, , , , True)
569 Else
570 dFormat = p.flags ' cache; pvLoadStdPicture resets the value
571 Call pvLoadStdPicture(Picture, 0&, 0&, 0&, True, p, True)
572 p.flags = dFormat
573 If p.oStream Is Nothing Then lErr = 5: GoTo ExitRoutine ' should not happen
574 GetHGlobalFromStream ObjPtr(p.oStream), p.pHandle
575 lSize = GlobalSize(p.pHandle)
576 If lSize = 0& Then lErr = 5: GoTo ExitRoutine
577 p.pIPicDisp = GlobalLock(p.pHandle)
578 If p.flags = 2& Then ' save to array
579 ReDim icData(0 To lSize - 1&)
580 CopyMemory icData(0), ByVal p.pIPicDisp, lSize
581 Else ' save to file
582 WriteFile hFile, ByVal p.pIPicDisp, lSize, lWritten, ByVal 0&
583 lErr = Err.LastDllError
584 GlobalUnlock p.pHandle
585 Set p.oStream = Nothing
586 End If
587 End If
588 Else
589 Call m_Primary.SavePicture(Picture, Destination, AlwaysSaveAsBitmap, KeepPremultipliedBits, BitmapBkgColor)
590 Exit Sub
591 End If
592
593ExitRoutine:
594 If lErr = 0& Then lErr = Err.LastDllError
595 Set oIPic = Nothing
596 If hDIB Then DeleteObject hDIB
597 If Not (hFile = 0& Or hFile = -1&) Then CloseHandle hFile
598 If lErr Then
599 Err.Raise lErr, "SavePicture"
600 ElseIf p.flags = 2& Then
601 Destination = icData()
602 End If
603End Sub
604
605Public Property Get SubImageCount(Picture As StdPicture) As Long
606 ' return number of pages/frames of multi-frame/page GIF/TIF
607 If pvVerifyInitialization Then
608 If m_Primary Is Nothing Then
609 SubImageCount = (m_PicRefs(pvPictureToIndex(Picture)).flags And &HFFF0000) \ &H10000
610 Else
611 SubImageCount = m_Primary.SubImageCount(Picture)
612 End If
613 End If
614End Property
615
616Public Property Get SubImageIndex(Picture As StdPicture) As Long
617 ' return current frame/page index of multi-frame/page GIF/TIF
618 If pvVerifyInitialization Then
619 If m_Primary Is Nothing Then
620 SubImageIndex = (m_PicRefs(pvPictureToIndex(Picture)).flags And &HFFF0&) \ &H10
621 Else
622 SubImageIndex = m_Primary.SubImageIndex(Picture)
623 End If
624 End If
625End Property
626
627Public Function SubImage(Picture As StdPicture, ByVal NewIndex As Long) As StdPicture
628 ' return a different frame/page
629 ' NewIndex must be between 1 and SubImageCount
630 ' Upon return, you should refresh the control the picture is assigned to
631
632 If pvVerifyInitialization Then
633 If m_Primary Is Nothing Then
634 If Not Picture Is Nothing Then
635 If Picture.Handle = 0& Or NewIndex < 1& Then
636 Set SubImage = Picture
637 Else
638 Dim lValue As Long, Index As Long
639 Index = pvPictureToIndex(Picture)
640 If Index > -1& Then
641 lValue = (m_PicRefs(Index).flags And &HFFF0000) \ &H10000
642 If Not (lValue < 2& Or NewIndex > lValue) Then
643 m_PicRefs(Index).flags = (m_PicRefs(Index).flags And &HFFFF000F) Or NewIndex * &H10&
644 If (m_PicRefs(Index).flags And &HF) = ptcTIF Then
645 Set SubImage = pvSetPage(Picture, Index)
646 Else
647 Call pvSetFrame(Picture, Index)
648 End If
649 End If
650 End If
651 If SubImage Is Nothing Then Set SubImage = Picture
652 End If
653 End If
654 Else
655 Set SubImage = m_Primary.SubImage(Picture, NewIndex)
656 End If
657 End If
658
659End Function
660
661Public Sub UnManage(Picture As StdPicture)
662 ' provided for troubleshooting/debugging.
663 ' Normally you would not want to call this method. The image will not be rendered correctly
664
665 Dim nIPic As IPicture
666 Dim pTable As Long, vTable As Long, tThunk As Long
667
668 If pvVerifyInitialization Then
669 If m_Primary Is Nothing Then
670 If Not Picture Is Nothing Then
671 If Not Picture.Handle = 0& Then
672 CopyMemory tThunk, ByVal pvSafePointerAdd(m_ThunkPtr, 8&), 4& ' get pointer to VTable thunk
673 CopyMemory vTable, ByVal pvSafePointerAdd(tThunk, 4&), 4& ' get original VTable address
674 CopyMemory pTable, ByVal ObjPtr(Picture), 4& ' VTable address for Picture object
675 If Not (pTable = vTable) Then
676 CopyMemory ByVal ObjPtr(Picture), vTable, 4&
677 Set nIPic = Picture
678 CopyMemory vTable, ByVal pvSafePointerAdd(tThunk, 8&), 4& ' get original VTable address
679 CopyMemory ByVal ObjPtr(nIPic), vTable, 4&
680 Set nIPic = Nothing
681 Call pvReleased(ObjPtr(Picture))
682 End If
683 End If
684 End If
685 Else
686 Call m_Primary.UnManage(Picture)
687 End If
688 End If
689
690End Sub
691
692Public Property Get IsManaged(Picture As StdPicture) As Boolean
693 ' returns whether VB or this class is rendering/managing the passed Picture
694 If pvVerifyInitialization Then
695 If m_Primary Is Nothing Then
696 If Not Picture Is Nothing Then
697 If pvPictureToIndex(Picture) > -1& Then
698 Dim pTable As Long, vTable As Long
699 CopyMemory pTable, ByVal pvSafePointerAdd(m_ThunkPtr, 8&), 4& ' get pointer to VTable thunk
700 CopyMemory vTable, ByVal pvSafePointerAdd(pTable, 4&), 4& ' get original VTable address
701 CopyMemory pTable, ByVal ObjPtr(Picture), 4& ' VTable address for Picture object
702 IsManaged = Not (pTable = vTable)
703 End If
704 End If
705 Else
706 IsManaged = m_Primary.IsManaged(Picture)
707 End If
708 End If
709End Property
710
711Public Property Get PictureType(Picture As StdPicture) As PictureTypeConstantsEx
712 ' replacement for VB's Picture.Type property
713 ' managed images can return GIF, JPG, TIF, PNG as picture types
714 If pvVerifyInitialization Then
715 If m_Primary Is Nothing Then
716 If Not Picture Is Nothing Then
717 Dim lSize As Long, oPic As IPicture, oStream As IUnknown
718 Dim hMem As Long, hLock As Long
719
720 With m_PicRefs(pvPictureToIndex(Picture))
721 If .flags = 0 Then ' passed unmanaged Picture
722 PictureType = Picture.Type ' set default return value
723 Set oPic = Picture
724 If oPic.KeepOriginalFormat Then ' can peek to see if GIF or JPG
725 hMem = GlobalAlloc(&H2&, 0&)
726 If hMem Then
727 Call CreateStreamOnHGlobal(hMem, 1&, oStream)
728 Else
729 GlobalFree hMem
730 End If
731 If Not oStream Is Nothing Then
732 oPic.SaveAsFile ByVal ObjPtr(oStream), 0&, lSize
733 If lSize < 4& Then
734 Set oStream = Nothing
735 Else
736 hLock = GlobalLock(hMem)
737 If hLock Then
738 CopyMemory lSize, ByVal hLock, 4&
739 GlobalUnlock hMem
740 Else
741 lSize = 0&
742 End If
743 If (lSize And &HFFFFFF) = &H464947 Then
744 PictureType = ptcGIF
745 ElseIf Not (lSize And &HFFFF&) = &H4D42& Then
746 PictureType = ptcJPEG
747 End If
748 End If
749 Set oStream = Nothing
750 End If
751 End If
752 Else
753 PictureType = .flags And &HF
754 End If
755 End With
756 End If
757 Else
758 PictureType = m_Primary.PictureType(Picture)
759 End If
760 End If
761End Property
762
763Public Function GetGIFAnimationInfo(Picture As StdPicture, Durations() As Long, _
764 Optional ByVal ZeroDurationAdjustment As Long = 50) As Boolean
765
766 ' Returns Animated GIF frame durations and suggested loop count
767 ' If the function returns false then Durations() array is undefined
768 ' The returned Durations() array will be zero-bound and contain each frame's duration
769 ' Durations(0) = suggested loop count. Infinite, undefined counts are values < 1
770 ' Durations(1 to frameCount) are values scaled back by 0.1, so multiply them by 10
771 ' ZeroDurationAdjustment is user-defined duration if the GIF reports zero for any frame.
772 ' This value cannot be less than 10ms. And setting less than 10 will default to 10
773
774 If pvVerifyInitialization = False Then Exit Function
775 If m_Primary Is Nothing Then
776 Const PropertyTagFrameDelay As Long = &H5100
777 Const PropertyTagLoopCount As Long = &H5101
778 Dim Index As Long, hImage As Long
779 Dim pData() As Byte, pSize As Long, pPointer As Long
780
781 Index = pvPictureToIndex(Picture)
782 If Index < 0& Then Exit Function
783 If Not (m_PicRefs(Index).flags And &HF) = ptcGIF Then Exit Function ' not GIF
784 hImage = m_PicRefs(Index).pHandle
785
786 If GdipGetPropertyItemSize(hImage, PropertyTagFrameDelay, pSize) Then Exit Function
787 ReDim pData(0 To pSize - 1&)
788 If GdipGetPropertyItem(hImage, PropertyTagFrameDelay, pSize, pData(0)) Then Exit Function
789 CopyMemory pSize, pData(4), 4&
790
791 ReDim Durations(0 To (m_PicRefs(Index).flags And &HFFF0000) \ &H10000)
792 CopyMemory pPointer, pData(12), 4&
793 CopyMemory Durations(1), ByVal pPointer, pSize
794 If GdipGetPropertyItemSize(hImage, PropertyTagLoopCount, pSize) = 0& Then
795 If pSize < UBound(pData) Then
796 If GdipGetPropertyItem(hImage, PropertyTagLoopCount, pSize, pData(0)) = 0& Then
797 CopyMemory pSize, pData(4), 4&
798 If pSize < 5& Then
799 CopyMemory pPointer, pData(12), 4&
800 CopyMemory Durations(0), ByVal pPointer, pSize
801 End If
802 End If
803 End If
804 End If
805 If ZeroDurationAdjustment < 10& Then ZeroDurationAdjustment = 10&
806 ZeroDurationAdjustment = ZeroDurationAdjustment \ 10&
807 For pSize = 1& To UBound(Durations)
808 If Durations(pSize) < 1& Then Durations(pSize) = ZeroDurationAdjustment
809 Next
810 GetGIFAnimationInfo = True
811 Else
812 GetGIFAnimationInfo = m_Primary.GetGIFAnimationInfo(Picture, Durations(), ZeroDurationAdjustment)
813 End If
814
815End Function
816
817Public Property Get HasOriginalFormat(Picture As StdPicture) As Boolean
818
819 ' returns whether original image format/data is maintained. If maintained and not needed,
820 ' you can call this class LoadPicture and pass the KeepOriginalFormat parameter as false to
821 ' reload image without caching the data, reducing memory usage, i.e.,
822 ' Set Image1.Picture = StdPictureEx.LoadPicture(Image1.Picture)
823 ' Note: When your project is uncompiled, VB ensures loaded pictures cache original data/format.
824 ' But when compiled, those same Pictures no longer have their data cached. In other words do
825 ' not assume that this property will return the same result for design-time loaded images
826 ' when your project is compiled vs. uncompiled. If original format is needed, highly recommend
827 ' you store your images in a resource file and load them from there.
828
829 Dim oIPic As IPicture
830 Call pvVerifyInitialization
831 If m_Primary Is Nothing Then
832 With m_PicRefs(pvPictureToIndex(Picture))
833 If .oStream Is Nothing Then
834 Set oIPic = Picture
835 HasOriginalFormat = CBool(oIPic.KeepOriginalFormat)
836 Else
837 HasOriginalFormat = True
838 End If
839 End With
840 Else
841 HasOriginalFormat = m_Primary.HasOriginalFormat(Picture)
842 End If
843
844End Property
845
846Private Function pvSetPage(Picture As StdPicture, Index As Long) As StdPicture
847
848 ' changes the page of a multi-page TIF
849
850 Dim goBMP(0 To 5) As Long ' equivalent to Windows BITMAP structure
851 Dim rBounds As RECTI, uBMP As BitmapData, nIPic As IPicture
852 Dim hImage As Long, pBounds As RECTF, BIH As BITMAPV5HEADER
853 Dim hDIB As Long, hBits As Long
854
855 With m_PicRefs(Index)
856 If GdipImageSelectActiveFrame(.pHandle, m_PageGUID(0, 1), (.flags And &HFFF0&) \ &H10 - 1&) Then Exit Function
857 hImage = .pHandle
858 End With
859 GdipGetImageBounds hImage, pBounds, 2& ' 2=UnitPixel
860 GetObjectA Picture.Handle, 24&, goBMP(0)
861 With BIH
862 .biWidth = pBounds.nWidth: .biHeight = pBounds.nHeight
863 .biBitCount = 32&: .biPlanes = 1: .biSize = 40&
864 End With
865 If goBMP(1) = BIH.biWidth And Abs(goBMP(2)) = BIH.biHeight And hBits <> 0& Then
866 ' can reuse the same bitmap?
867 If goBMP(5) = 0& Then
868 hDIB = CreateDIBSection(m_hDC, BIH, 0&, hBits, 0&, 0&)
869 Else
870 hBits = goBMP(5)
871 End If
872 Else
873 hDIB = CreateDIBSection(m_hDC, BIH, 0&, hBits, 0&, 0&)
874 End If
875 If hBits Then
876 With uBMP
877 .Width = BIH.biWidth: .Height = BIH.biHeight
878 rBounds.nHeight = .Height: rBounds.nWidth = .Width
879 .PixelFormat = PixelFormat32bppPremultiplied
880 .stride = -.Width * 4&
881 .Scan0Ptr = pvSafePointerAdd(hBits, (.Height - 1&) * -.stride)
882 End With
883 If GdipBitmapLockBits(hImage, rBounds, ImageLockModeRead Or ImageLockModeUserInputBuf, uBMP.PixelFormat, uBMP) Then
884 If GdipBitmapLockBits(hImage, rBounds, ImageLockModeRead Or ImageLockModeUserInputBuf, uBMP.PixelFormat, uBMP) Then uBMP.Scan0Ptr = 0&
885 End If
886 If uBMP.Scan0Ptr = 0& Then
887 If hDIB Then DeleteObject hDIB
888 Else
889 GdipBitmapUnlockBits hImage, uBMP
890 If hDIB Then ' not using the same image handle, prevent clearing of cached info & GDI+ handle
891 Set pvSetPage = pvHandleToStdPicture(hDIB, vbPicTypeBitmap)
892 If pvSetPage Is Nothing Then
893 DeleteObject hDIB
894 Else
895 Set nIPic = pvSetPage
896 m_PicRefs(Index).pIPicDisp = ObjPtr(pvSetPage)
897 m_PicRefs(Index).pIPicture = ObjPtr(nIPic)
898 End If
899 End If
900 End If
901 End If
902
903End Function
904
905Private Sub pvSetFrame(Picture As StdPicture, Index As Long)
906
907 ' changes the frame of an animated GIF
908
909 Dim goBMP(0 To 5) As Long ' equivalent to Windows BITMAP structure
910 Dim rBounds As RECTI, uBMP As BitmapData
911 Dim hImage As Long
912
913 With m_PicRefs(Index)
914 If GdipImageSelectActiveFrame(.pHandle, m_PageGUID(0, 0), (.flags And &HFFF0&) \ &H10 - 1&) Then Exit Sub
915 hImage = .pHandle
916 End With
917 GetObjectA Picture.Handle, 24&, goBMP(0)
918 If Not goBMP(5) = 0& Then ' else no bits pointer
919 ' to change the frame, we simply render over the existing GIF frame
920 With uBMP
921 .Width = goBMP(1): .Height = goBMP(2)
922 .stride = .Width * -4& ' ensure pixels are extracted bottom-up vs. GDI+ top-down
923 .Scan0Ptr = pvSafePointerAdd(goBMP(5), (.Height - 1&) * -.stride)
924 .PixelFormat = PixelFormat32bppPremultiplied
925 rBounds.nHeight = .Height: rBounds.nWidth = .Width
926 End With
927 If GdipBitmapLockBits(hImage, rBounds, ImageLockModeRead Or ImageLockModeUserInputBuf, uBMP.PixelFormat, uBMP) Then
928 If GdipBitmapLockBits(hImage, rBounds, ImageLockModeRead Or ImageLockModeUserInputBuf, uBMP.PixelFormat, uBMP) Then uBMP.Scan0Ptr = 0&
929 End If
930 If uBMP.Scan0Ptr Then GdipBitmapUnlockBits hImage, uBMP
931 End If
932
933End Sub
934
935Private Function pvPictureToIndex(Picture As IPictureDisp) As Long
936 ' returns index for passed managed picture
937 Dim pObj As Long
938 If Picture Is Nothing Then
939 pvPictureToIndex = -1&
940 Else
941 pObj = ObjPtr(Picture)
942 For pvPictureToIndex = m_RefCount - 1& To 0& Step -1&
943 If m_PicRefs(pvPictureToIndex).pIPicDisp = pObj Then Exit For
944 Next
945 End If
946
947End Function
948
949Private Function pvVerifyInitialization() As Boolean
950 ' helper function that ensures a) thunks created and/or b) primary subclasser identified
951 If Not m_ThunkPtr = -1& Then
952 If m_ThunkPtr = 0& Then
953 If pvCreateThunks() = True Then
954 If m_Primary Is Nothing Then
955 m_hDC = CreateCompatibleDC(0&)
956 ReDim m_PicRefs(-1 To -1)
957 End If
958 pvVerifyInitialization = True
959 End If
960 Else
961 pvVerifyInitialization = True
962 End If
963 End If
964End Function
965
966Private Function pvLoadPicture(SourceData() As Byte, Size As Long, IconColorDepth As Long, _
967 DesiredIconCx As Long, DesiredIconCy As Long, _
968 KeepFormat As Boolean, _
969 pPicRef As PICREF) As StdPicture
970
971 ' workhorse for the class
972
973 Dim hBmp As Long, lRead As Long, lFlags As Long
974 Dim hBits As Long, hImage As Long, hToken As Long, LB As Long
975 Dim BIH As BITMAPV5HEADER, uBMP As BitmapData, rBounds As RECTI
976 Dim IStream As IUnknown
977 Const ImageLockModeWrite = &H2
978
979 LB = LBound(SourceData)
980 If m_hDC Then ' else class not initialized
981 CopyMemory lFlags, SourceData(LB), 4&
982 If (lFlags And &HFFFF&) = &H4D42& Then ' bitmaps handled separately to support 32bpp
983 KeepFormat = False ' and also to support v4 & v5 of the bitmap info header
984 CopyMemory BIH.biSize, SourceData(LB + 14&), 4& ' size of header
985 If Not (BIH.biSize < 40& Or BIH.biSize > 124&) Then ' quick validation
986 CopyMemory BIH.biWidth, SourceData(LB + 18&), 36& ' get next 36 bytes of header
987 If BIH.biBitCount > 0 And BIH.biCompression < 4& Then ' else likely BI_PNG,BI_JPG & not supported
988 hBmp = CreateDIBSection(m_hDC, SourceData(LB + 14&), 0&, hBits, 0&, 0&) ' use GDI to parse bitmap header & create DIB
989 If hBmp Then
990 lRead = BIH.biSize ' determine where pixel data starts
991 If BIH.biCompression = 3& And BIH.biSize = 40& Then ' BI_BITFIELDS
992 If (BIH.biBitCount = 16 Or BIH.biBitCount = 32) Then lRead = lRead + 12&
993 End If
994 If BIH.biClrUsed Then
995 lRead = lRead + 4& * BIH.biClrUsed
996 ElseIf BIH.biBitCount <= 8& Then
997 lRead = lRead + 4& * 2 ^ BIH.biBitCount
998 End If
999 If SetDIBits(m_hDC, hBmp, 0&, Abs(BIH.biHeight), SourceData(LB + 14& + lRead), SourceData(LB + 14&), 0&) = 0& Then
1000 DeleteObject hBmp: hBmp = 0&
1001 ElseIf BIH.biBitCount = 32& Then ' othewise, we'll let VB deal with it
1002 lFlags = pvValidateAlphaChannel(hBits, BIH.biWidth, Abs(BIH.biHeight)) ' test alpha-usage
1003 If lFlags = PixelFormat32bppAlpha Then ' create GDI+ image for conversion
1004 With uBMP ' will be destroying DIB, need to upload its bits
1005 .Height = Abs(BIH.biHeight)
1006 .Width = BIH.biWidth
1007 .PixelFormat = lFlags
1008 .stride = -.Width * 4&
1009 .Scan0Ptr = pvSafePointerAdd(hBits, -.stride * (.Height - 1&))
1010 rBounds.nHeight = .Height: rBounds.nWidth = .Width
1011 End With ' create GDI+ bitmap & upload DIB bits
1012 GdipCreateBitmapFromScan0 BIH.biWidth, uBMP.Height, uBMP.stride, uBMP.PixelFormat, ByVal 0&, hImage
1013 If hImage Then
1014 If GdipBitmapLockBits(hImage, rBounds, ImageLockModeUserInputBuf Or ImageLockModeWrite, uBMP.PixelFormat, uBMP) Then
1015 If GdipBitmapLockBits(hImage, rBounds, ImageLockModeUserInputBuf Or ImageLockModeWrite, uBMP.PixelFormat, uBMP) Then uBMP.Scan0Ptr = 0&
1016 End If
1017 If uBMP.Scan0Ptr Then
1018 GdipBitmapUnlockBits hImage, uBMP
1019 DeleteObject hBmp: hBmp = 0&
1020 pPicRef.flags = ptcBitmap: lFlags = 0&
1021 Set pvLoadPicture = pvConvertFromGDIplus(hImage, IStream, KeepFormat, pPicRef)
1022 Else
1023 GdipDisposeImage hImage: hImage = 0&
1024 End If
1025 End If
1026 ElseIf lFlags = PixelFormat32bppPremultiplied Then ' if premultiplied, then managed
1027 pPicRef.flags = ptcBitmap
1028 End If
1029 End If
1030 End If
1031 End If
1032 End If
1033 If hBmp Then
1034 Set pvLoadPicture = pvHandleToStdPicture(hBmp, vbPicTypeBitmap)
1035 If pvLoadPicture Is Nothing Then DeleteObject hBmp: lFlags = 0&
1036 Else
1037 lFlags = 0& ' flag for default load
1038 End If
1039 ElseIf (lFlags And &HFFFFFF) = &H464947 Then ' test for GIF
1040 If KeepFormat = False Then lFlags = 0&
1041 ElseIf Not lFlags = &H474E5089 Then ' test for PNG
1042 If Not (lFlags And &HFFFF&) = &H4949& Then ' test for Tiff two ways
1043 If Not (lFlags And &HFFFF&) = &H4D4D& Then
1044 ' test for icons; they are handled separately
1045 If (lFlags And &HFFFF&) = 0& Then ' this may want to be relaxed? Per MSDN must be zero
1046 If ((lFlags And &HFFFF0000) = &H10000 Or (lFlags And &HFFFF0000) = &H20000) Then
1047 Set pvLoadPicture = pvLoadhIcon(SourceData(), DesiredIconCx, DesiredIconCy, Size, IconColorDepth, KeepFormat, pPicRef)
1048 End If
1049 End If
1050 lFlags = 0&
1051 End If
1052 End If
1053 End If
1054 End If
1055
1056 ' when we get here, lFlags=0 if attempting to load using just VB
1057 If pvLoadPicture Is Nothing Then
1058 lRead = Abs(UBound(SourceData) - LB) + 1&
1059 hBits = 0&: Call pvIStreamFromPointer(0&, lRead, hBits)
1060 If hBits Then
1061 CopyMemory ByVal hBits, SourceData(LB), lRead
1062 Set IStream = pvIStreamFromPointer(0&, 0&, hBits)
1063 End If
1064 On Error Resume Next
1065 If lFlags = 0& Then
1066 Set pvLoadPicture = pvIStreamToPicture(IStream, KeepFormat)
1067 If pvLoadPicture Is Nothing Then
1068 If m_hDC = 0& Then Exit Function ' else re-load stream & try GDI+
1069 ' Note: if failed to load some formats, OLE does something to the stream that
1070 ' prevents GDI+ from loading the image (guessing locking). So to get past
1071 ' that potential problem, we simply reload the stream
1072 Set IStream = Nothing
1073 hBits = 0&: Call pvIStreamFromPointer(0&, lRead, hBits)
1074 CopyMemory ByVal hBits, SourceData(LB), lRead
1075 Set IStream = pvIStreamFromPointer(0&, 0&, hBits)
1076 End If
1077 End If
1078 On Error GoTo 0
1079 If pvLoadPicture Is Nothing Then ' failed, try GDI+ (CMYK JPGs supported)
1080 If m_hDC Then Set pvLoadPicture = pvConvertFromGDIplus(0&, IStream, KeepFormat, pPicRef)
1081 End If
1082 End If
1083
1084End Function
1085
1086Private Function pvLoadFile(FileName As String, Size As Long, IconColorDepth As Long, _
1087 DesiredIconCx As Long, DesiredIconCy As Long, _
1088 KeepFormat As Boolean, _
1089 pPicRef As PICREF) As StdPicture
1090
1091 ' nothing is loaded by file, everything loaded by array
1092 Dim lRead As Long, lSize As Long, hFile As Long
1093 Dim aPix() As Byte
1094
1095 Const GENERIC_READ As Long = &H80000000
1096 Const OPEN_EXISTING = &H3
1097 Const FILE_SHARE_READ = &H1
1098 Const FILE_ATTRIBUTE_ARCHIVE As Long = &H20
1099 Const FILE_ATTRIBUTE_HIDDEN As Long = &H2
1100 Const FILE_ATTRIBUTE_READONLY As Long = &H1
1101 Const FILE_ATTRIBUTE_SYSTEM As Long = &H4
1102 Const FILE_ATTRIBUTE_NORMAL = &H80&
1103 Const LR_LOADFROMFILE As Long = &H10
1104
1105 lRead = FILE_ATTRIBUTE_ARCHIVE Or FILE_ATTRIBUTE_HIDDEN Or FILE_ATTRIBUTE_NORMAL _
1106 Or FILE_ATTRIBUTE_READONLY Or FILE_ATTRIBUTE_SYSTEM
1107 hFile = CreateFileW(StrPtr(FileName), GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, lRead, 0&)
1108 If Not hFile = -1& Then
1109 lSize = GetFileSize(hFile, ByVal 0&) ' load via array
1110 If lSize > 0& Then ' else > 2GB & not dealing with it
1111 SetFilePointer hFile, 0&, ByVal 0&, 0&
1112 ReDim aPix(0 To lSize - 1&)
1113 ReadFile hFile, aPix(0), lSize, lRead, ByVal 0&
1114 CloseHandle hFile
1115 If lSize = lRead Then ' pass off to array handler
1116 Set pvLoadFile = pvLoadPicture(aPix(), Size, IconColorDepth, DesiredIconCx, DesiredIconCy, KeepFormat, pPicRef)
1117 End If
1118 Else
1119 CloseHandle hFile
1120 End If
1121 End If
1122
1123End Function
1124
1125Private Function pvLoadStdPicture(Picture As StdPicture, IconSize As Long, _
1126 DesiredIconCx As Long, DesiredIconCy As Long, _
1127 KeepFormat As Boolean, pPicRef As PICREF, _
1128 Optional ReturnDataOnly As Boolean) As StdPicture
1129
1130 ' Note: ReturnDataOnly is True when this is called from the SavePicture method only
1131 ' and in that case, bitmap is the only format this method will not return pPicRef.oStream
1132
1133 ' method copies the passed picture object to a new stdPicture object (duplicates handle/data)
1134 ' kind of lengthy routine, but source data can exist in more than one place or may not exist at all
1135 ' 1. If COM cached source data for picture, use that source data; may or may not be managed
1136 ' 2. If managed and source data cached locally, use that data & manage
1137 ' 3. If no source data at all, depending on the image type, create source data one of a few ways
1138 ' GIF will be processed uniquely to preserve any transparency, will be managed
1139 ' ICO,BMP,JPG: copy the handle and use that as the new source, may or may not be managed
1140 ' For any other formats, have VB create source similar to SavePicture, not managed
1141 Dim hGlobal As Long, lSize As Long, hLock As Long
1142 Dim pUDT() As Long, icData() As Byte, Index As Long
1143 Dim BIH As BITMAPV5HEADER, pRECT As RECTI, oIPic As IPicture
1144 Dim transColor As Long, lColor As Long, hImage As Long
1145 ' pPicRef.flags:
1146 ' > 0 managed returned picture
1147 ' 0 unmanaged returned Picture
1148 ' < 0 flags for this routine, changed to 0+ on exit
1149 ' -1 source not yet determined
1150 ' -2 Stream from COM cached data
1151 ' -3 Stream from COM created data
1152 ' -4 Stream from locally cached data
1153 ' -5 Handle source (gif)
1154 ' -6 Handle source (icon)
1155 ' -7 Handle source (bitmap)
1156 pPicRef.flags = -1&
1157 Set oIPic = Picture
1158
1159 '/// Step 1: Determine where source info is coming from
1160 If oIPic.KeepOriginalFormat Then ' has original data cached by COM, retrieve it
1161 pPicRef.flags = -2&
1162 ElseIf m_hDC = 0& Then ' class was never initialized properly
1163 pPicRef.flags = -3&
1164 Else
1165 Index = pvPictureToIndex(Picture)
1166 If Index < 0& Then ' unmanaged
1167 Select Case Picture.Type
1168 Case vbPicTypeMetafile, vbPicTypeEMetafile
1169 pPicRef.flags = -3&
1170 Case vbPicTypeBitmap
1171 If (oIPic.Attributes And 2&) Then ' GIF without source data
1172 pPicRef.flags = -5&
1173 Else ' bmp or jpg
1174 pPicRef.flags = -7&
1175 End If
1176 Case Else ' icon
1177 If ReturnDataOnly Then pPicRef.flags = -3& Else pPicRef.flags = -6&
1178 End Select
1179 KeepFormat = False
1180
1181 Else ' managed picture objects... PNG,TIF,GIF,CMYK-JPEG,32bpp ICO/BMP & possibly 8+bpp icons/cursors
1182 If Picture.Type = vbPicTypeIcon Then
1183 If ReturnDataOnly Then pPicRef.flags = -3& Else pPicRef.flags = -6&
1184 Else
1185 pPicRef.flags = -7&
1186 End If
1187 If Not m_PicRefs(Index).oStream Is Nothing Then
1188 If KeepFormat = True Then pPicRef.flags = -4&
1189 End If
1190 End If
1191 End If
1192
1193 '/// Step 2: Process the source info
1194 Select Case pPicRef.flags
1195 Case -2&, -3&, -4& ' stream sources
1196 If pPicRef.flags = -4& Then ' use locally cached data
1197 pPicRef.flags = 0&
1198 If ReturnDataOnly Then
1199 Set pPicRef.oStream = m_PicRefs(Index).oStream: Exit Function
1200 End If
1201 Call GetHGlobalFromStream(ObjPtr(m_PicRefs(Index).oStream), hGlobal)
1202 If hGlobal Then lSize = GlobalSize(hGlobal)
1203 Else ' have COM save it to stream
1204 hGlobal = GlobalAlloc(&H2&, 0&): Call CreateStreamOnHGlobal(hGlobal, 1&, pPicRef.oStream)
1205 If pPicRef.oStream Is Nothing Then GlobalFree hGlobal: GoTo ExitRoutine
1206 If pPicRef.flags = -2& Then ' from COM-cached data
1207 oIPic.SaveAsFile ByVal ObjPtr(pPicRef.oStream), 0&, lSize
1208 Else ' from COM-created data
1209 oIPic.SaveAsFile ByVal ObjPtr(pPicRef.oStream), 1&, lSize
1210 End If
1211 pPicRef.flags = 0&
1212 If ReturnDataOnly Then Exit Function
1213 End If
1214 If lSize = 0& Then GoTo ExitRoutine
1215
1216 hLock = GlobalLock(hGlobal) ' transfer stream to byte array
1217 If hLock = 0& Then GoTo ExitRoutine ' then process byte array
1218 ReDim icData(0 To lSize - 1&)
1219 CopyMemory icData(0), ByVal hLock, lSize
1220 GlobalUnlock hGlobal
1221 pPicRef.flags = 0&: Set pPicRef.oStream = Nothing
1222 Set pvLoadStdPicture = pvLoadPicture(icData(), IconSize, 0&, DesiredIconCx, DesiredIconCy, KeepFormat, pPicRef)
1223
1224 Case -6& ' icon,cursor
1225 If ReturnDataOnly Then Exit Function
1226 pPicRef.flags = 0&: ReDim pUDT(0 To 4) ' determine if 32bpp blended icon or not
1227 GetIconInfo Picture.Handle, pUDT(0) ' blended icons are managed others aren't unless caching data
1228 If pUDT(3) Then DeleteObject pUDT(3) ' destroy any mask bitmap
1229 If pUDT(4) Then ' color bitmap handle
1230 BIH.biSize = 40&: hImage = pUDT(4)
1231 GetDIBits m_hDC, hImage, 0&, 0&, ByVal 0&, BIH, 0&
1232 If BIH.biBitCount = 32 Then ' manage if not simple transparency
1233 If BIH.biSizeImage = 0& Then BIH.biSizeImage = pvDWordAlign(BIH.biBitCount, BIH.biWidth, BIH.biHeight)
1234 ReDim pUDT(0 To BIH.biSizeImage \ 4 - 1) ' simple transparency: all alpha values are zero
1235 GetDIBits m_hDC, hImage, 0&, Abs(BIH.biHeight), pUDT(0), BIH, 0&
1236 If pvValidateAlphaChannel(VarPtr(pUDT(0)), BIH.biWidth, Abs(BIH.biHeight)) Then
1237 pPicRef.flags = vbPicTypeIcon
1238 End If
1239 End If
1240 DeleteObject hImage
1241 End If
1242 Erase pUDT()
1243 Call pvSetIconSize(IconSize, DesiredIconCx, DesiredIconCy, 1&)
1244 hImage = CopyImage(Picture.Handle, 1&, DesiredIconCx, DesiredIconCy, 0&)
1245 Set pvLoadStdPicture = pvHandleToStdPicture(hImage, vbPicTypeIcon)
1246 If pvLoadStdPicture Is Nothing Then DestroyIcon hImage
1247 KeepFormat = False
1248
1249 Case -7& ' bitmap
1250 pPicRef.flags = 0&: If ReturnDataOnly Then Exit Function
1251 hImage = CopyImage(Picture.Handle, 0&, 0&, 0&, LR_CREATEDIBSECTION)
1252 Set pvLoadStdPicture = pvLoadhBitmap(hImage, pPicRef)
1253 If pvLoadStdPicture Is Nothing Then DeleteObject hImage
1254 KeepFormat = False
1255
1256 Case -5& ' GIF frame without source
1257 pPicRef.flags = 0&: If ReturnDataOnly Then Exit Function
1258 BIH.biSize = 40&: GetDIBits m_hDC, Picture.Handle, 0&, 0&, ByVal 0&, BIH, 0&
1259 If BIH.biBitCount <= 8 Then ' preserve transparency
1260 ReDim pUDT(0 To 265) ' size large enough for header + 256 palette
1261 CopyMemory pUDT(0), BIH, 40& ' then call again to fill in the palette
1262 GetDIBits m_hDC, Picture.Handle, 0&, 0&, ByVal 0&, pUDT(0), 0&
1263 For transColor = 1& To 258&
1264 For lSize = 10& To 265& ' header is 40 bytes & 40 bytes = 10 Longs
1265 If pUDT(lSize) = transColor Then Exit For ' see if transColor in palette
1266 Next
1267 If lSize = 266& Then Exit For ' if transColor not in palette, we're done
1268 Next
1269 Erase pUDT()
1270 With BIH
1271 .biBitCount = 32: .biClrUsed = 0: .biClrImportant = 0: .biCompression = 0
1272 .biHeight = Abs(.biHeight): .biSizeImage = pvDWordAlign(.biBitCount, .biWidth, .biHeight)
1273 End With
1274 hImage = CreateDIBSection(m_hDC, BIH, 0&, hLock, 0&, 0&)
1275 If hImage Then ' render GIF over our transColor
1276 hImage = SelectObject(m_hDC, hImage) ' create brush from BGR vs RGB format
1277 lColor = CreateSolidBrush((transColor And &HFF00&) Or (transColor And &HFF) * &H10000)
1278 pRECT.nWidth = BIH.biWidth: pRECT.nHeight = BIH.biHeight
1279 FillRect m_hDC, pRECT, lColor: DeleteObject lColor
1280 With Picture
1281 .Render (m_hDC), 0&, 0&, (BIH.biWidth), (BIH.biHeight), 0&, (.Height - 1&), .Width, -.Height, ByVal 0&
1282 End With
1283 hImage = SelectObject(m_hDC, hImage)
1284 For lSize = 0& To BIH.biSizeImage - 1& Step 4&
1285 hGlobal = pvSafePointerAdd(hLock, lSize) ' now any color that is transColor is 100%
1286 CopyMemory lColor, ByVal hGlobal, 4& ' transparent, else it is 100% opaque
1287 If lColor = transColor Then lColor = 0& Else lColor = lColor Or &HFF000000
1288 CopyMemory ByVal hGlobal, lColor, 4&
1289 Next
1290 Set pvLoadStdPicture = pvHandleToStdPicture(hImage, vbPicTypeBitmap)
1291 If pvLoadStdPicture Is Nothing Then
1292 DeleteObject hImage
1293 Else
1294 pPicRef.flags = vbPicTypeBitmap
1295 End If
1296 End If
1297 End If
1298 If pvLoadStdPicture Is Nothing Then
1299 hImage = CopyImage(Picture.Handle, 0&, 0&, 0&, 0&)
1300 Set pvLoadStdPicture = pvHandleToStdPicture(hImage, vbPicTypeBitmap)
1301 If pvLoadStdPicture Is Nothing Then DeleteObject hImage
1302 pPicRef.flags = 0&: KeepFormat = False
1303 End If
1304 End Select
1305
1306ExitRoutine:
1307 '/// Step 3: Clean up
1308 Set oIPic = Nothing
1309 If pvLoadStdPicture Is Nothing Then
1310 Set pvLoadStdPicture = Picture
1311 Set pPicRef.oStream = Nothing
1312 pPicRef.flags = 0&
1313 ElseIf KeepFormat = False Then
1314 Set pPicRef.oStream = Nothing
1315 End If
1316
1317End Function
1318
1319Private Function pvLoadhBitmap(hBitmap As Long, pPicRef As PICREF) As StdPicture
1320
1321 ' Determines if passed image is 32bpp or not. If it is, a new version (premultiplied RGB) is returned
1322 ' Source will be a stdPicture object passed from LoadPicture or a bitmap handle passed from pvLoadFromFile
1323
1324 Dim BIH As BITMAPV5HEADER, tPic As StdPicture
1325 Dim hImage As Long, lFlags As Long, aPix() As Byte
1326
1327 If m_hDC Then ' else class not initialized correctly
1328 BIH.biSize = 40&
1329 GetDIBits m_hDC, hBitmap, 0&, 0&, ByVal 0&, BIH, 0& ' get bit count
1330 If BIH.biBitCount = 32 Then
1331 ReDim aPix(0 To BIH.biSizeImage - 1) ' get pixel data
1332 BIH.biHeight = -BIH.biHeight ' want bits in top-down vs bottom-up order
1333 If GetDIBits(m_hDC, hBitmap, 0&, Abs(BIH.biHeight), aPix(0), BIH, 0&) Then
1334 lFlags = pvValidateAlphaChannel(VarPtr(aPix(0)), BIH.biWidth, Abs(BIH.biHeight))
1335 If lFlags = PixelFormat32bppAlpha Then
1336 ' taking easy way out, load bitmap in GDI+ then convert to premultiplied
1337 ' else we'd have to test whether passed handle is DIB and if not (is DDB) then create
1338 ' DIB & copy bits; then we can loop thru the pixels and premultiply them
1339 GdipCreateBitmapFromScan0 BIH.biWidth, Abs(BIH.biHeight), BIH.biWidth * 4&, PixelFormat32bppAlpha, aPix(0), hImage
1340 If hImage Then Set tPic = pvConvertFromGDIplus(hImage, Nothing, False, pPicRef)
1341 ElseIf lFlags = PixelFormat32bppPremultiplied Or lFlags = PixelFormat32bpp Then ' premultiplied already
1342 Set tPic = pvHandleToStdPicture(hBitmap, vbPicTypeBitmap)
1343 If Not tPic Is Nothing Then pPicRef.flags = ptcBitmap
1344 Else
1345 Set tPic = pvHandleToStdPicture(hBitmap, vbPicTypeBitmap)
1346 pPicRef.flags = 0&
1347 End If
1348 Set pvLoadhBitmap = tPic
1349 End If
1350 Erase aPix()
1351 End If
1352 End If
1353 If pvLoadhBitmap Is Nothing Then
1354 Set pvLoadhBitmap = pvHandleToStdPicture(hBitmap, vbPicTypeBitmap)
1355 pPicRef.flags = 0&
1356 End If
1357
1358End Function
1359
1360Private Function pvLoadhIcon(icData() As Byte, dCx As Long, dCy As Long, _
1361 Size As LoadPictureSizeConstantsEx, dDepth As Long, _
1362 KeepFormat As Boolean, pPicRef As PICREF) As StdPicture
1363
1364 ' method returns stdPicture containing a GDI icon. If the icon is 32bpp then the class will render it
1365 ' the icon data can contain 32bpp and PNG-encoded icons
1366
1367 Dim LB As Long, lMax As Long, lVal As Long
1368 Dim Index As Long, lFlags As Long, hHandle As Long
1369 Dim icSorted() As Long, lSize As Long
1370 Dim ICD As ICONDIR, ICDE As ICONDIRENTRY
1371 Dim xDepth As Long, xCx As Long, xCy As Long
1372 Const png_Signature1 As Long = 1196314761
1373
1374 LB = LBound(icData)
1375 lMax = Abs(UBound(icData) - LB) + 1&
1376 If lMax < 62& Then Exit Function ' can't be icon data
1377
1378 '/// VALIDATE INTEGRITY OF THE FORMAT
1379 On Error GoTo ExitRoutine
1380 CopyMemory ICD, icData(LB), 6& ' sanity checks
1381 If (ICD.idCount < 1& Or ICD.idType < 1& Or ICD.idType > 2&) Then Exit Function
1382 lSize = ICD.idCount * 16& + 6&
1383 ICD.idCount = (ICD.idCount And &H7FF&)
1384 If lSize > lMax Then Exit Function
1385
1386 ReDim icSorted(0 To ICD.idCount - 1&)
1387 ' validate array has enough bytes, sort by size & depth
1388 For ICD.idCount = 0& To ICD.idCount - 1&
1389 CopyMemory ICDE, icData(LB + ICD.idCount * 16& + 6&), 16&
1390 If ICDE.dwBytesInRes < 1& Or ICDE.dwBytesInRes < 1& Then Exit Function ' corrupt or not icon data
1391 If ICDE.dwBytesInRes + ICDE.dwImageOffset > lMax Then Exit Function
1392 lSize = lSize + ICDE.dwBytesInRes
1393 If lSize > lMax Then Exit Function ' corrupt or not icon data
1394 CopyMemory lFlags, icData(LB + ICDE.dwImageOffset), 4&
1395 If lFlags = png_Signature1 Then
1396 ' Offset + 16& is PNG width, big endian
1397 ' Offset + 20& is PNG height, big endian
1398 ' Offset + 24& is PNG bit depth
1399 ' Offset + 25& is PNG color type
1400 CopyMemory lFlags, icData(LB + ICDE.dwImageOffset + 16&), 4&
1401 lVal = (pvReverseLong(lFlags) And &H7FF)
1402 CopyMemory lFlags, icData(LB + ICDE.dwImageOffset + 20&), 4&
1403 lVal = (((pvReverseLong(lFlags) And &H7FF) + lVal) \ 2) * &H100&
1404 lFlags = icData(LB + ICDE.dwImageOffset + 24&)
1405 Select Case icData(LB + ICDE.dwImageOffset + 25&)
1406 Case 2&: lFlags = 24& ' RGB format
1407 Case 4&: lFlags = 9& ' Alpha grayscale (fudge 8bit so this 8bit better than normal 8bit)
1408 Case 6&: lFlags = 32& ' Alpha RGB
1409 Case 0&: If lFlags = 16& Then lFlags = 8&
1410 Case Else ' use reported depth
1411 End Select
1412 lVal = lVal Or lFlags Or &H80000000 Or ICD.idCount * &H100000
1413 Else ' non-PNG
1414 CopyMemory lVal, icData(LB + ICDE.dwImageOffset + 4&), 4&
1415 CopyMemory lFlags, icData(LB + ICDE.dwImageOffset + 8&), 4&
1416 lVal = (((lVal And &H7FF) + (Abs(lFlags \ 2) And &H7FF)) \ 2) * &H100&
1417 CopyMemory lFlags, icData(LB + ICDE.dwImageOffset + 14), 2&
1418 lVal = lVal Or (lFlags And &HFF) Or ICD.idCount * &H100000
1419 End If
1420 For Index = 0& To ICD.idCount - 1&
1421 ' we sort icon metrics for a best pick strategy, icons are sorted by size & depth
1422 ' not a perfect algo, but since most icons in same resource are same shape, should be ok
1423 ' 0x000000FF bit depth
1424 ' 0x0007FF00 (width+height)\2
1425 ' 0x7FF00000 index into the icon directory
1426 ' 0x80000000 PNG resource
1427 If (lVal And &H7FF00) < (icSorted(Index) And &H7FF00) Then
1428 CopyMemory icSorted(Index + 1&), icSorted(Index), (ICD.idCount - Index) * 4&
1429 Exit For
1430 End If
1431 Next
1432 icSorted(Index) = lVal
1433 Next
1434
1435 '/// DETERMINE SIZE OF ICON TO RETURN
1436 Call pvSetIconSize(Size, dCx, dCy, (ICD.idCount))
1437
1438 '/// GET BEST MATCH FOR RETURNED ICON SIZE & DEPTH
1439 If ICD.idCount > 1& Then
1440 If dDepth < 1& Then dDepth = GetDeviceCaps(m_hDC, 12&) ' 12 = constant BITSPERPIXEL
1441 lMax = (((dCx And &H7FF) + (dCy And &H7FF)) \ 2) * &H100& ' desired value
1442 For Index = 0& To ICD.idCount - 1&
1443 If (icSorted(Index) And &H7FF00) >= lMax Then ' size-match found
1444 lMax = icSorted(Index) And &H7FF00 ' find best-match for depth (sorted descending)
1445 For lVal = Index + 1& To ICD.idCount - 1&
1446 If (icSorted(lVal) And &H7FF00) > lMax Then ' landed on a different size, use previous entry
1447 lVal = lVal - 1&
1448 Exit For
1449 ElseIf dDepth < (icSorted(lVal) And &HFF) Then ' use this size & depth
1450 Exit For
1451 End If
1452 Next
1453 Index = lVal: Exit For ' algo is done
1454 End If
1455 Next
1456 If Index = ICD.idCount Then Index = Index - 1& ' adjust if Index out of bounds, uses largest size/depth
1457 CopyMemory ICDE, icData(LB + 6& + 16& * (icSorted(Index) And &H7FF00000) \ &H100000), 16& ' get chosen ICDE
1458 End If
1459
1460 '/// CREATE HICON WHETHER PNG-ENCODED OR NOT
1461 If (m_VistaPlus Or icSorted(Index) > -1&) Then ' If PNG, then icSorted(n) high bit is set
1462 ' we can't use this on lower than Vista if PNG
1463 If ICD.idType = 1 Then ' icon
1464 hHandle = CreateIconFromResourceEx(icData(LB + ICDE.dwImageOffset), ICDE.dwBytesInRes, 1&, &H30000, dCx, dCy, 0&)
1465 Else ' Cursors are a bit different...
1466 CopyMemory lVal, icData(LB + ICDE.dwImageOffset - 4&), 4& ' back up those 4 bytes in source data
1467 CopyMemory icData(LB + ICDE.dwBytesInRes - 4&), ICDE.wPlanes, 4& ' copy the X/Y hotspot to that location
1468 hHandle = CreateIconFromResourceEx(icData(LB + ICDE.dwImageOffset - 4&), ICDE.dwBytesInRes + 4&, 0&, &H30000, dCx, dCy, 0&)
1469 CopyMemory icData(LB + ICDE.dwImageOffset - 4&), lVal, 4& ' restore those 4 bytes to source data
1470 End If
1471
1472 '/// CREATE ICON FROM PNG ON XP AND LOWER
1473 Else
1474 Dim rBounds As RECTI, sBounds As RECTF ' variables for creating PNG, icon/cursor and mask
1475 Dim uBMP As BitmapData, BIH As BITMAPV5HEADER
1476 Dim IStream As IUnknown, pngData() As Byte
1477 Dim mskShift As Long, mskScanWidth As Long
1478 Dim clrPtr As Long, mskPtr As Long
1479 Dim clrPtrBase As Long, mskPtrBase As Long
1480
1481 Set IStream = pvIStreamFromPointer(VarPtr(icData(LB + ICDE.dwImageOffset)), ICDE.dwBytesInRes, 0&)
1482 If Not IStream Is Nothing Then ' get PNG loaded via GDI+
1483 GdipLoadImageFromStream ObjPtr(IStream), hHandle
1484 If hHandle Then
1485 GdipGetImageBounds hHandle, sBounds, 2& ' 2=UnitPixel
1486 With uBMP ' set variables for extracting PNG data, creating icon mask
1487 .Height = sBounds.nHeight: .Width = sBounds.nWidth
1488 rBounds.nHeight = .Height: rBounds.nWidth = .Width
1489 GdipGetImagePixelFormat hHandle, .PixelFormat
1490 Select Case .PixelFormat
1491 Case PixelFormat32bppAlpha, PixelFormat32bppPremultiplied, &H61007, &H34400D, &H1C400E ' all known GDI+ alpha formats
1492 .PixelFormat = PixelFormat32bppAlpha ' return 32bpp Alpha
1493 icSorted(Index) = 32&
1494 Case Else
1495 .PixelFormat = PixelFormat24bpp ' return 24bpp format
1496 icSorted(Index) = 24&
1497 End Select
1498 If ICD.idType = 1 Then LB = 0& Else LB = 4& ' Cursor has 4 more bytes
1499 BIH.biBitCount = (.PixelFormat And &HFF00&) \ &H100
1500 .stride = -pvDWordAlign(BIH.biBitCount, .Width) ' color pixel scanwidth
1501 mskScanWidth = pvDWordAlign(1, .Width) ' mask scanwidth
1502 clrPtrBase = 40& + LB: mskPtrBase = -.stride * .Height + clrPtrBase ' offsets for pixel/mask data
1503 lSize = mskPtrBase + mskScanWidth * .Height ' want GDI+ to give us pixels in bottom-up order
1504 ReDim pngData(0 To lSize - 1&) ' resize array & set position where
1505 .Scan0Ptr = VarPtr(pngData(mskPtrBase + .stride)) ' GDI+ will cache the pixel data
1506 End With
1507 If GdipBitmapLockBits(hHandle, rBounds, ImageLockModeRead Or ImageLockModeUserInputBuf, uBMP.PixelFormat, uBMP) Then
1508 If GdipBitmapLockBits(hHandle, rBounds, ImageLockModeRead Or ImageLockModeUserInputBuf, uBMP.PixelFormat, uBMP) Then lSize = 0&
1509 End If
1510 If lSize Then GdipBitmapUnlockBits hHandle, uBMP ' done with GDI+ PNG, destroy it
1511 GdipDisposeImage hHandle: Set IStream = Nothing: hHandle = 0&
1512 If lSize Then ' create the bitmap info header
1513 With BIH
1514 .biHeight = uBMP.Height * 2&
1515 .biWidth = uBMP.Width
1516 .biSize = 40&: .biPlanes = 1
1517 .biSizeImage = lSize - .biSize - LB ' image size minus header & cursor XY hotspot
1518 End With: CopyMemory pngData(LB), BIH, BIH.biSize ' copy header to array, offset for cusory XY hotspot as needed
1519 If BIH.biBitCount = 32 Then ' otherwise, mask is all zeroes, fully opaque
1520 ' build a true mask. Though not used by Windows, it could be used by whoever
1521 ' called this routine. Just a matter of doing it right vs. doing it quick
1522 mskPtr = mskPtrBase: clrPtr = clrPtrBase + 3&: xDepth = 0&
1523 mskShift = 128&: xCy = Abs(uBMP.Height): xCx = -uBMP.stride
1524 For xCy = 0& To uBMP.Height - 1&
1525 For clrPtr = clrPtr To clrPtr + xCx - 4& Step 4&
1526 ' mask bits: 0=opaque, 1=transparent
1527 If pngData(clrPtr) < 128 Then xDepth = xDepth Or mskShift
1528 If mskShift = 1& Then ' filled mask byte; write it, reset it
1529 pngData(mskPtr) = xDepth: mskPtr = mskPtr + 1&
1530 xDepth = 0&: mskShift = 128&
1531 Else ' set next shift position
1532 mskShift = mskShift \ 2&
1533 End If
1534 Next
1535 If mskShift < 128& Then ' 99% of time, won't test true. Most icons are DWord aligned
1536 ' write remainder, last mask bit. Set up for next scanline
1537 pngData(mskPtr) = xDepth: xDepth = 0&: mskShift = 128&
1538 mskPtr = xCy * mskScanWidth + mskScanWidth + mskPtrBase
1539 clrPtr = xCy * xCx + xCx + clrPtrBase + 3&
1540 End If
1541 Next
1542 End If ' create icon from bitmap data & then create stdPicture from it
1543 ' Cursors are a bit different... transfer XY hotspot to array as needed
1544 If Not ICD.idType = 1 Then CopyMemory pngData(0), ICDE.wPlanes, 4&
1545 hHandle = CreateIconFromResourceEx(pngData(0), lSize, ICD.idType And 1&, &H30000, dCx, dCy, 0&)
1546 Erase pngData()
1547 End If
1548 End If
1549 End If
1550 End If
1551
1552 '/// CLEAN UP & CACHE ORIGINAL DATA IF REQUESTED
1553 If hHandle Then
1554 Set pvLoadhIcon = pvHandleToStdPicture(hHandle, vbPicTypeIcon)
1555 If pvLoadhIcon Is Nothing Then
1556 If ICD.idType = 1& Then DestroyIcon hHandle Else DestroyCursor hHandle
1557 ElseIf m_hDC Then ' else class not initialized correctly
1558 If KeepFormat = True Then
1559 hHandle = 0&: Call pvIStreamFromPointer(0&, 22& + ICDE.dwBytesInRes, hHandle)
1560 If hHandle Then
1561 CopyMemory ByVal pvSafePointerAdd(hHandle, 22&), icData(LBound(icData) + ICDE.dwImageOffset), ICDE.dwBytesInRes
1562 ICDE.dwImageOffset = 22&: CopyMemory ByVal pvSafePointerAdd(hHandle, 6&), ICDE, 16&
1563 ICD.idCount = 1: CopyMemory ByVal hHandle, ICD, 6&
1564 Set pPicRef.oStream = pvIStreamFromPointer(0&, 0&, hHandle)
1565 pPicRef.flags = ptcIcon ' manage if caching original format
1566 End If
1567 End If
1568 If (icSorted(Index) And &HFF) = 32& Then pPicRef.flags = ptcIcon ' always manage 32bpp
1569 End If
1570 End If
1571
1572ExitRoutine:
1573End Function
1574
1575Private Function pvCvAnyToICO(Picture As StdPicture, pPicRef As PICREF, KeepFormat As Boolean, IconSize As Long, DesiredIconCx As Long, DesiredIconCy As Long) As StdPicture
1576
1577 ' called to convert bitmap, wmf, emf to icon
1578 ' if the loaded image was some other type (gif,tif,png), the LoadPicture method ensured that
1579 ' a bitmap would be returned before getting here. See LoadPicture
1580
1581 Dim BHI As BITMAPV5HEADER, icData() As Byte, icHdr() As Long, x As Long
1582 Dim mskShift As Long, mskPtr As Long, mskBits As Long, lAlpha As Long
1583
1584 If Picture.Handle = 0& Then
1585 Set pvCvAnyToICO = Picture
1586
1587 ElseIf Picture.Type = vbPicTypeIcon Then
1588 Set pvCvAnyToICO = Picture
1589
1590 ElseIf Picture.Type = vbPicTypeBitmap Then
1591 ReDim icHdr(0 To 265) ' includes 256 color table
1592 icHdr(0) = 40&: GetDIBits m_hDC, Picture.Handle, 0&, 0&, ByVal 0&, icHdr(0), 0&
1593 CopyMemory BHI, icHdr(0), 40&: Erase icHdr() ' copy the header & release the array
1594 With BHI
1595 If .biBitCount = 0& Then
1596 Set pvCvAnyToICO = Picture
1597 Exit Function
1598 End If ' begin calculating icon format size
1599 mskShift = pvDWordAlign(1, .biWidth)
1600 .biCompression = 0&: .biClrImportant = 0&: .biClrUsed = 0&
1601 If .biBitCount < 32 Then
1602 If Not .biBitCount = 24 Then .biBitCount = 24: .biSizeImage = 0&
1603 End If
1604 If .biSizeImage = 0& Then .biSizeImage = pvDWordAlign(.biBitCount, .biWidth, .biHeight)
1605 ReDim icData(0 To .biSizeImage + Abs(.biHeight) * mskShift + 61&)
1606 End With
1607 GetDIBits m_hDC, Picture.Handle, 0&, Abs(BHI.biHeight), icData(62), BHI, 0&
1608 BHI.biHeight = Abs(BHI.biHeight)
1609 If BHI.biBitCount = 32 Then
1610 If pvValidateAlphaChannel(VarPtr(icData(62)), BHI.biWidth, BHI.biHeight) = PixelFormat32bppPremultiplied Then
1611 mskShift = 128: mskPtr = 62& + BHI.biSizeImage
1612 For x = 65& To mskPtr - 1& Step 4&
1613 lAlpha = icData(x)
1614 If lAlpha = 0& Then
1615 mskBits = mskBits Or mskShift
1616 ElseIf lAlpha < 255& Then
1617 icData(x - 1&) = (icData(x - 1&) * lAlpha) \ 255
1618 icData(x - 2&) = (icData(x - 2&) * lAlpha) \ 255
1619 icData(x - 3&) = (icData(x - 2&) * lAlpha) \ 255
1620 End If
1621 If mskShift = 1& Then
1622 icData(mskPtr) = mskBits
1623 mskBits = 0&: mskShift = 128: mskPtr = mskPtr + 1&
1624 Else
1625 mskShift = mskShift \ 2&
1626 End If
1627 Next
1628 End If
1629 End If
1630 With BHI
1631 icData(2) = 1: icData(4) = 1 ' set icon directory type & count
1632 If .biWidth < 256& Then icData(6) = .biWidth
1633 If .biHeight < 256& Then icData(7) = .biHeight
1634 CopyMemory icData(14), CLng(UBound(icData) - 21&), 4&
1635 icData(10) = 1: icData(12) = BHI.biBitCount: icData(18) = 22 ' planes, bitcount & offset to where icon begins
1636 .biHeight = .biHeight + .biHeight
1637 End With
1638 CopyMemory icData(22), BHI, 40& ' copy header
1639 Set pvCvAnyToICO = pvLoadhIcon(icData(), DesiredIconCx, DesiredIconCy, lpsDefault, 0&, KeepFormat, pPicRef)
1640 Else
1641 Set pvCvAnyToICO = pvCvMetaFileToAny(Picture, pPicRef, vbPicTypeIcon, KeepFormat, IconSize, DesiredIconCx, DesiredIconCy)
1642 End If
1643
1644 If pvCvAnyToICO Is Nothing Then Set pvCvAnyToICO = Picture
1645
1646End Function
1647
1648Private Function pvCvAnytoBMP(Picture As StdPicture, pPicRef As PICREF) As StdPicture
1649
1650 ' convert bmp, wmf, emf, png, tiff, etc to bitmap
1651
1652 Dim ICI() As Long, aMask() As Byte, hDIB As Long, hBits As Long
1653 Dim x As Long, y As Long, dPtr As Long, hMask As Long
1654 Dim BIH As BITMAPV5HEADER, mScanWidth As Long
1655
1656 If Picture.Handle = 0& Then
1657 Set pvCvAnytoBMP = Picture
1658
1659 ElseIf Picture.Type = vbPicTypeBitmap Then
1660 If pPicRef.flags Then pPicRef.flags = vbPicTypeBitmap
1661 Set pvCvAnytoBMP = Picture
1662
1663 ElseIf Picture.Type = vbPicTypeIcon Then
1664 ' icons are a bit of a pain to convert to bmp while maintaining transparency
1665
1666 ReDim ICI(0 To 4) ' equivalent to ICONINFO structure; (3)=mask,(4)=color
1667 GetIconInfo Picture.Handle, ICI(0)
1668 If ICI(4) Then ' has color bitmap else B&W only
1669 BIH.biSize = 40&: GetDIBits m_hDC, ICI(4), 0&, 0&, ByVal 0&, BIH, 0&
1670 With BIH ' prepare a 32bpp format for DIB creation
1671 If .biBitCount Then
1672 .biBitCount = 32: .biCompression = 0
1673 hDIB = CreateDIBSection(m_hDC, BIH, 0&, hBits, 0&, 0&)
1674 End If
1675 End With
1676 If hDIB = 0& Then GoTo ExitRoutine ' create DIB, abort on failure
1677 ' transfer bitmap to our DIB
1678 GetDIBits m_hDC, ICI(4), 0&, BIH.biHeight, ByVal hBits, BIH, 0&
1679 DeleteObject ICI(4): ICI(4) = 0& ' test for complex transparency
1680 Select Case pvValidateAlphaChannel(hBits, BIH.biWidth, BIH.biHeight)
1681 Case PixelFormat32bppAlpha ' need to convert to premultiplied alpha
1682 Set pvCvAnytoBMP = pvLoadhBitmap(hDIB, pPicRef)
1683 GoTo ExitRoutine
1684 Case PixelFormat32bpp, PixelFormat32bppPremultiplied
1685 Set pvCvAnytoBMP = pvHandleToStdPicture(hDIB, vbPicTypeBitmap)
1686 pPicRef.flags = vbPicTypeBitmap
1687 GoTo ExitRoutine
1688 End Select ' otherwise, process the mask bits
1689 End If
1690
1691 If ICI(3) Then ' has mask bits else oops
1692 hMask = ICI(3) ' cash mask bitmap
1693 ReDim ICI(0 To 265) ' BitmapInfoHeader + 256 color palette
1694 With BIH
1695 If .biBitCount = 0& Then ' no color bitmap; therefore, this is B&W icon
1696 .biSize = 40: GetDIBits m_hDC, hMask, 0&, 0&, ByVal 0&, BIH, 0&
1697 If .biBitCount = 0 Then GoTo ExitRoutine
1698 y = .biHeight \ 2& ' prepare a 32bpp format for DIB creation
1699 .biBitCount = 32: .biClrImportant = 0: .biClrUsed = 0&
1700 .biSizeImage = 0&: .biCompression = 0: .biHeight = y
1701 hDIB = CreateDIBSection(m_hDC, BIH, 0&, hBits, 0&, 0&)
1702 If hDIB = 0& Then GoTo ExitRoutine ' create the DIB
1703 .biHeight = y + y: x = y ' transfer top 1/2 of mask to our DIB
1704 GetDIBits m_hDC, hMask, 0&, y, ByVal hBits, BIH, 0&
1705 Else
1706 y = .biHeight: x = 0&
1707 End If ' get the mask bits
1708 .biBitCount = 8: .biClrImportant = 0: .biClrUsed = 256: .biSizeImage = 0
1709 mScanWidth = pvDWordAlign(.biBitCount, .biWidth)
1710 ReDim aMask(0 To mScanWidth * y - 1&)
1711 CopyMemory ICI(0), BIH, 40&: ICI(11) = vbWhite
1712 GetDIBits m_hDC, hMask, x, y, aMask(0), ICI(0), 0&
1713 Erase ICI()
1714 End With
1715 DeleteObject hMask: ICI(3) = 0&
1716 dPtr = 3&: For y = 0& To y - 1& ' apply the mask to our bitmap
1717 x = y * mScanWidth
1718 For x = x To x + BIH.biWidth - 1&
1719 If aMask(x) = 0& Then
1720 CopyMemory ByVal pvSafePointerAdd(hBits, dPtr), 255, 1&
1721 Else
1722 hMask = 0& ' contains simple transparency
1723 End If
1724 dPtr = dPtr + 4&
1725 Next
1726 Next
1727 Set pvCvAnytoBMP = pvHandleToStdPicture(hDIB, vbPicTypeBitmap)
1728 If hMask Then pPicRef.flags = vbPicTypeBitmap Else pPicRef.flags = hMask
1729 End If
1730
1731 Else ' metafile conversion to bitmap
1732 Set pvCvAnytoBMP = pvCvMetaFileToAny(Picture, pPicRef, vbPicTypeBitmap, False)
1733 End If
1734
1735ExitRoutine:
1736 If Picture.Type = vbPicTypeIcon Then
1737 If ICI(4) Then DeleteObject ICI(4)
1738 If ICI(3) Then DeleteObject ICI(3)
1739 End If
1740 If pvCvAnytoBMP Is Nothing Then Set pvCvAnytoBMP = Picture
1741
1742End Function
1743
1744Private Function pvCvMetaFileToAny(Picture As StdPicture, pPicRef As PICREF, _
1745 PicType As Long, KeepFormat As Boolean, _
1746 Optional IconSize As Long, _
1747 Optional IconCx As Long, Optional IconCy As Long) As StdPicture
1748
1749 ' convert wmf, emf to icon or bitmap
1750
1751 Dim BIH As BITMAPV5HEADER, nPic As IPicture
1752 Dim hDIB As Long, hBits As Long, x As Long
1753 Dim bAlpha As Byte, dPtr As Long, hIcon As Long, icData() As Byte
1754 Dim mskPtr As Long, mskShift As Long, mskBits As Long
1755
1756 With BIH ' create DIB to work on
1757 Set nPic = Picture
1758 If (nPic.Attributes And 2&) Then .biBitCount = 32 Else .biBitCount = 24
1759 Set nPic = Nothing ' determine target size, metafiles scale exceptionally well
1760 .biWidth = (1440! / Screen.TwipsPerPixelX) * Picture.Width / 2540!
1761 .biHeight = (1440! / Screen.TwipsPerPixelY) * Picture.Height / 2540!
1762 If PicType = vbPicTypeIcon Then
1763 Call pvSetIconSize(IconSize, IconCx, IconCy, 1&)
1764 If IconCx Then .biWidth = IconCx
1765 If IconCy Then .biHeight = IconCy
1766 Else
1767 End If
1768 .biPlanes = 1: .biSize = 40 ' finish the header
1769 .biSizeImage = pvDWordAlign(.biBitCount, .biWidth, .biHeight)
1770 End With ' create DIB & abort on error
1771 hDIB = CreateDIBSection(m_hDC, BIH, 0&, hBits, 0&, 0&)
1772 If hDIB = 0& Then Exit Function
1773
1774 ' WMF/EMF can be difficult to determine transparent areas. When Picture.Render is called,
1775 ' each pixel the metafile touches, clears the alpha byte. So, if we preset the entire
1776 ' image's bits to 255, then any that remain after rendering will be determined transparent
1777 ' because the metafile didn't touch those bits.
1778 If BIH.biBitCount = 32& Then FillMemory ByVal hBits, BIH.biSizeImage, 255
1779 hDIB = SelectObject(m_hDC, hDIB)
1780 With Picture
1781 .Render (m_hDC), 0&, 0&, (BIH.biWidth), (BIH.biHeight), 0&, (.Height - 1&), .Width, -.Height, ByVal 0&
1782 End With
1783 hDIB = SelectObject(m_hDC, hDIB)
1784
1785 If PicType = vbPicTypeBitmap Then ' loop thru alpha bytes & toggle them
1786 If BIH.biBitCount = 32& Then
1787 For x = 3& To BIH.biSizeImage - 1& Step 4
1788 dPtr = pvSafePointerAdd(hBits, x)
1789 CopyMemory bAlpha, ByVal dPtr, 1
1790 bAlpha = bAlpha Xor 255
1791 If bAlpha = 255 Then
1792 CopyMemory ByVal dPtr, bAlpha, 1
1793 Else
1794 CopyMemory ByVal pvSafePointerAdd(hBits, x - 3&), 0&, 4&
1795 End If
1796 Next
1797 pPicRef.flags = PicType
1798 Else
1799 pPicRef.flags = 0&
1800 End If
1801 Set pvCvMetaFileToAny = pvHandleToStdPicture(hDIB, vbPicTypeBitmap)
1802 If pvCvMetaFileToAny Is Nothing Then
1803 DeleteObject hDIB: pPicRef.flags = 0&
1804 End If
1805 Else
1806 With BIH ' prepare array to hold icon format
1807 mskShift = pvDWordAlign(1, .biWidth)
1808 ReDim icData(0 To .biSizeImage + mskShift * .biHeight + 21&)
1809 icData(2) = 1: icData(4) = 1 ' set icon directory type & count
1810 If .biWidth < 256& Then icData(6) = .biWidth
1811 If .biHeight < 256& Then icData(7) = .biHeight
1812 CopyMemory icData(14), CLng(UBound(icData) - 21&), 4&
1813 icData(10) = 1: icData(12) = 32: icData(18) = 22 ' planes, bitcount & offset to where icon begins
1814 .biHeight = .biHeight + .biHeight
1815 End With
1816 CopyMemory icData(22), BIH, 40& ' copy header
1817 CopyMemory icData(62), ByVal hBits, BIH.biSizeImage ' copy bits
1818 DeleteObject hDIB
1819 If BIH.biBitCount = 32& Then ' loop and toggle alpha + build icon mask
1820 mskPtr = BIH.biSizeImage + 62&: mskShift = 128&
1821 For x = 65& To mskPtr - 1& Step 4&
1822 icData(x) = icData(x) Xor 255
1823 If icData(x) = 0 Then mskBits = mskBits Or mskShift
1824 If mskShift = 1& Then
1825 icData(mskPtr) = mskBits
1826 mskBits = 0&: mskShift = 128&
1827 mskPtr = mskPtr + 1&
1828 Else
1829 mskShift = mskShift \ 2&
1830 End If
1831 Next
1832 End If
1833 Set pvCvMetaFileToAny = pvLoadhIcon(icData(), 0&, 0&, lpsDefault, 0&, KeepFormat, pPicRef)
1834 End If
1835
1836End Function
1837
1838Private Sub pvSetIconSize(Size As Long, dCx As Long, dCy As Long, iconCount As Long)
1839
1840 ' determine icons size from passed options
1841
1842 Dim hIML As IUnknown, GUID(0 To 3) As Long
1843 Const IID_IImageList As String = "{46EB5926-582E-4017-9FDF-E8998DAA0950}"
1844
1845 If Size = lpsCustom Then ' DesiredCx,Cy should not be zero
1846 If dCx < 1& And dCy < 1& Then
1847 Size = lpsDefault ' if they are, use Default
1848 Else
1849 If dCx < 1& Then dCx = dCy
1850 If dCy < 1& Then dCy = dCx
1851 Exit Sub ' done
1852 End If
1853 End If
1854 If Size = lpsDefault Then ' if only 1 icon, use actual size
1855 If iconCount > 1& Then
1856 Size = lpsLarge
1857 Else
1858 dCx = 0&: dCy = dCx
1859 Exit Sub ' done
1860 End If
1861 ElseIf Abs(Size) = lpsSmallShell Or Abs(Size) = lpsLargeShell Then
1862 If Size = lpsJumboShell Then ' Jumbo available on Vista+ only
1863 If m_VistaPlus = False Then
1864 dCx = 256&: dCy = dCx
1865 Exit Sub ' done
1866 End If
1867 End If
1868 IIDFromString StrPtr(IID_IImageList), GUID(0)
1869 End If
1870 On Error Resume Next
1871 Select Case Size
1872 Case lpsLarge ' generally 32x32 can be 48x48
1873 dCx = GetSystemMetrics(11): dCy = GetSystemMetrics(12)
1874 Case lpsSmall ' always 16x16 as of Win10
1875 dCx = GetSystemMetrics(49): dCy = GetSystemMetrics(50)
1876 Case lpsSmallShell ' 16x16 but can scale due to DPI
1877 SHGetImageListXP 1&, GUID(0), VarPtr(hIML)
1878 Case lpsLargeShell ' 32x32 but can scale due to DPI
1879 SHGetImageListXP 0&, GUID(0), VarPtr(hIML)
1880 Case lpsXtraLargeShell ' 48x48 but can scale due to DPI
1881 SHGetImageListXP 2&, GUID(0), VarPtr(hIML)
1882 Case lpsJumboShell ' always 256x256 as of Win10
1883 SHGetImageListXP 4&, GUID(0), VarPtr(hIML)
1884 End Select
1885 If Not hIML Is Nothing Then ImageList_GetIconSize ObjPtr(hIML), dCx, dCy
1886 If Err Then
1887 Select Case Size
1888 Case lpsLarge: dCx = 32&: dCy = dCx
1889 Case lpsSmall: dCx = 16&: dCy = dCx
1890 Case lpsSmallShell
1891 dCx = GetSystemMetrics(49): dCy = GetSystemMetrics(50)
1892 Case lpsLargeShell
1893 dCx = GetSystemMetrics(11): dCy = GetSystemMetrics(12)
1894 Case lpsXtraLargeShell: dCx = 48&: dCy = dCx
1895 Case lpsJumboShell: dCx = 256&: dCy = dCx
1896 End Select
1897 End If
1898
1899End Sub
1900
1901Private Function pvConvertFromGDIplus(hImage As Long, IStream As IUnknown, ByVal KeepFormat As Boolean, pPicRef As PICREF) As StdPicture
1902
1903 ' takes a GDI+ image (bitmap, PNG, TIFF, etc) and converts it to a GDI image then to a stdPicture
1904 ' the GDI+ image is only ever kept under 2 conditions
1905 ' 1) It is a multi-frame GIF or multi-page TIFF and
1906 ' 2) Navigation is desired
1907
1908 Dim uBMP As BitmapData, srcRect As RECTF, rBounds As RECTI
1909 Dim BIH As BITMAPV5HEADER, hLock As Long, gStream As IUnknown
1910 Dim vParamPtr() As Long, vParamType() As Integer
1911 Dim vParams() As Variant, paramCount As Long, hHandle As Long
1912
1913 If hImage = 0& Then
1914 GdipLoadImageFromStream ObjPtr(IStream), hImage
1915 If hImage = 0& Then Exit Function
1916 End If
1917 pPicRef.flags = pvQueryFormat(hImage)
1918 Select Case pPicRef.flags
1919 Case ptcBitmap: KeepFormat = False
1920 Case ptcPNG, ptcJPEG
1921 Case ptcGIF
1922 pPicRef.flags = pPicRef.flags Or pvGetFrameCount(hImage, pPicRef.flags) * &H10000 Or 1&
1923 If (pPicRef.flags And &HFFF0000) > &H10000 And KeepFormat = True Then
1924 pPicRef.pHandle = hImage ' allow GDI+ to manage this for frame navigation
1925 Else ' if single frame or not caching format, let VB manage it
1926 GdipDisposeImage hImage: hImage = 0&
1927 ' specifically set the stream seek pointer to 0, otherwise pvIStreamToPicture fails here.
1928 ' IStream:Seek is VTable offset of 20, params are bytesToMove@,origin&,*newPosition@
1929 paramCount = 3&
1930 ReDim vParams(0 To paramCount)
1931 ReDim vParamPtr(0 To paramCount)
1932 ReDim vParamType(0 To paramCount)
1933 vParams(0) = 0@: vParams(1) = 0&: vParams(2) = 0&
1934 For paramCount = 0& To paramCount - 1&
1935 vParamPtr(paramCount) = VarPtr(vParams(paramCount))
1936 vParamType(paramCount) = VarType(vParams(paramCount))
1937 Next
1938 Call DispCallFunc(ObjPtr(IStream), 20&, 4&, vbLong, paramCount, _
1939 VarPtr(vParamType(0)), VarPtr(vParamPtr(0)), vParams(paramCount))
1940 Set pvConvertFromGDIplus = pvIStreamToPicture(IStream, KeepFormat)
1941 pPicRef.flags = 0&
1942 Exit Function
1943 End If
1944 Case ptcTIF ' if keeping format, allow GDI+ to manage this for page navigation
1945 If KeepFormat Then
1946 pPicRef.flags = pPicRef.flags Or pvGetFrameCount(hImage, pPicRef.flags) * &H10000 Or 1&
1947 If (pPicRef.flags And &HFFF0000) > &H10000 And KeepFormat = True Then
1948 pPicRef.pHandle = hImage
1949 End If
1950 End If
1951 Case ptcEMetafile ' likely only reason we got here is non-placeable WMF was loaded
1952 GdipGetHemfFromMetafile hImage, hHandle ' convert to GDI WMF
1953 GdipDisposeImage hImage: hImage = 0&: pPicRef.flags = 0&
1954 paramCount = GdipEmfToWmfBits(hHandle, 0&, 0&, 8&, 0&) ' 8& = MM_ANISOTROPIC; get size of bits
1955 If paramCount Then
1956 Call pvIStreamFromPointer(0&, paramCount + 22&, hLock)
1957 If hLock Then ' transfer bits, offsetting for placeable header
1958 If GdipEmfToWmfBits(hHandle, paramCount, pvSafePointerAdd(hLock, 22&), 8&, 0&) Then
1959 DeleteEnhMetaFile hHandle: hHandle = 0&
1960 If Screen.Width > Screen.Height Then
1961 rBounds.nWidth = 256& * Screen.TwipsPerPixelX
1962 rBounds.nHeight = (Screen.Height / Screen.Width) * rBounds.nWidth
1963 Else
1964 rBounds.nHeight = 256& * Screen.TwipsPerPixelY
1965 rBounds.nWidth = (Screen.Width / Screen.Height) * rBounds.nHeight
1966 End If ' add placeable header
1967 CopyMemory ByVal hLock, &H9AC6CDD7, 4& ' WMF magic number
1968 CopyMemory ByVal pvSafePointerAdd(hLock, 4&), 0@, 6& ' Handle, Left, Top
1969 CopyMemory ByVal pvSafePointerAdd(hLock, 10&), rBounds.nWidth, 2& ' Right
1970 CopyMemory ByVal pvSafePointerAdd(hLock, 12&), rBounds.nHeight, 2& ' Bottom
1971 CopyMemory ByVal pvSafePointerAdd(hLock, 14&), 1440, 2& ' units per inch
1972 CopyMemory ByVal pvSafePointerAdd(hLock, 16&), 0&, 4& ' reserved
1973 paramCount = 22289& Xor rBounds.nWidth Xor rBounds.nHeight Xor 1440&
1974 ' ^^ 22289 = 0 Xor &HCDD7& Xor &H9AC6&
1975 CopyMemory ByVal pvSafePointerAdd(hLock, 20&), paramCount, 2& ' checksum
1976 Set gStream = pvIStreamFromPointer(0&, 0&, hLock): hLock = 0&
1977 Set pvConvertFromGDIplus = pvIStreamToPicture(gStream, False)
1978 End If
1979 If hLock Then Set gStream = pvIStreamFromPointer(0&, 0&, hLock)
1980 Set gStream = Nothing
1981 End If
1982 End If
1983 If hHandle Then DeleteEnhMetaFile hHandle
1984 Exit Function
1985 Case Else
1986 GdipDisposeImage hImage: hImage = 0&
1987 Exit Function
1988 End Select
1989
1990 GdipGetImageBounds hImage, srcRect, 2& ' 2 = UnitPixel
1991 With uBMP
1992 .Height = srcRect.nHeight: .Width = srcRect.nWidth
1993 rBounds.nHeight = .Height: rBounds.nWidth = .Width
1994 If KeepFormat Then
1995 .PixelFormat = PixelFormat32bppPremultiplied ' return premultiplied RGB
1996 Else
1997 GdipGetImagePixelFormat hImage, .PixelFormat
1998 Select Case .PixelFormat
1999 Case PixelFormat32bppAlpha, PixelFormat32bppPremultiplied, &H61007, &H34400D, &H1C400E ' all known GDI+ alpha formats
2000 .PixelFormat = PixelFormat32bppPremultiplied ' return premultiplied RGB
2001 pPicRef.flags = ptcBitmap
2002 Case Else
2003 .PixelFormat = PixelFormat24bpp ' return 24bpp format
2004 End Select
2005 End If
2006 End With
2007
2008 If GdipBitmapLockBits(hImage, rBounds, ImageLockModeRead, uBMP.PixelFormat, uBMP) Then
2009 Call GdipBitmapLockBits(hImage, rBounds, ImageLockModeRead, uBMP.PixelFormat, uBMP)
2010 End If
2011 If uBMP.Scan0Ptr Then
2012 With BIH ' build a bitmap info header structure
2013 .biHeight = -uBMP.Height
2014 .biWidth = uBMP.Width
2015 .biPlanes = 1: .biSize = 40
2016 If uBMP.PixelFormat = PixelFormat32bppPremultiplied Then .biBitCount = 32 Else .biBitCount = 24
2017 .biSizeImage = Abs(uBMP.stride * .biHeight)
2018 End With
2019 hLock = 0&: Call pvIStreamFromPointer(0&, 54& + BIH.biSizeImage, hLock)
2020 If hLock Then ' wrap pixel data in bitmap file & info headers
2021 CopyMemory ByVal hLock, &H4D42, 2&
2022 CopyMemory ByVal pvSafePointerAdd(hLock, 2), CLng(54& + BIH.biSizeImage), 4&
2023 CopyMemory ByVal pvSafePointerAdd(hLock, 6), 0&, 4&
2024 CopyMemory ByVal pvSafePointerAdd(hLock, 10), 54&, 4&
2025 CopyMemory ByVal pvSafePointerAdd(hLock, 14), BIH, 40&
2026 CopyMemory ByVal pvSafePointerAdd(hLock, 54), ByVal uBMP.Scan0Ptr, BIH.biSizeImage
2027 GdipBitmapUnlockBits hImage, uBMP
2028 Set gStream = pvIStreamFromPointer(0&, 0&, hLock)
2029 Set pvConvertFromGDIplus = pvIStreamToPicture(gStream, False)
2030 Else
2031 GdipBitmapUnlockBits hImage, uBMP
2032 End If
2033 End If
2034
2035 If pvConvertFromGDIplus Is Nothing Then
2036 If hImage Then GdipDisposeImage hImage
2037 Set pPicRef.oStream = Nothing
2038 pPicRef.flags = 0&
2039 Else
2040 If pPicRef.pHandle = 0& Then GdipDisposeImage hImage
2041 If KeepFormat Then Set pPicRef.oStream = IStream
2042 End If
2043
2044End Function
2045
2046Private Function pvIStreamToPicture(IStream As IUnknown, KeepFormat As Boolean) As IPicture
2047
2048 ' function creates a stdPicture from the passed array
2049 ' Note: The array was already validated as not empty before this was called
2050
2051 Dim aGUID(0 To 3) As Long
2052 On Error Resume Next
2053 If Not IStream Is Nothing Then
2054 aGUID(0) = &H7BF80980 ' GUID for IPICTURE
2055 aGUID(1) = &H101ABF32
2056 aGUID(2) = &HAA00BB8B
2057 aGUID(3) = &HAB0C3000
2058 Call OleLoadPicture(ByVal ObjPtr(IStream), 0&, Abs(Not KeepFormat), aGUID(0), pvIStreamToPicture)
2059 End If
2060End Function
2061
2062Private Function pvHandleToStdPicture(ByVal hImage As Long, PicType As PictureTypeConstants) As IPicture
2063
2064 ' function creates a stdPicture object from an image handle (bitmap or icon)
2065
2066 Dim lpPictDesc(0 To 3) As Long, aGUID(0 To 3) As Long
2067
2068 lpPictDesc(0) = 16&
2069 lpPictDesc(1) = PicType
2070 lpPictDesc(2) = hImage
2071 ' IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
2072 aGUID(0) = &H7BF80980
2073 aGUID(1) = &H101ABF32
2074 aGUID(2) = &HAA00BB8B
2075 aGUID(3) = &HAB0C3000
2076 ' create stdPicture
2077 Call OleCreatePictureIndirect(lpPictDesc(0), aGUID(0), True, pvHandleToStdPicture)
2078
2079End Function
2080
2081Private Function pvIStreamFromPointer(MemoryPtr As Long, Length As Long, hLock As Long) As stdole.IUnknown
2082
2083 ' Purpose: Create an IStream-compatible IUnknown interface containing the
2084 ' passed byte aray. This IUnknown interface can be passed to GDI+ functions
2085 ' that expect an IStream interface -- neat hack
2086
2087 ' Can be called either once or twice
2088 ' If calling once: MemoryPtr cannot be null, hLock must be null
2089 ' If calling twice:
2090 ' 1st call: pass MemoryPtr as zero, valid Length of data, hLock as null
2091 ' 2nd call: pass MemoryPtr & Length as zero, hLock as value returned from 1st call
2092
2093 On Error GoTo HandleError
2094 Dim o_lpMem As Long, tUnk As IUnknown
2095 Static o_hMem As Long
2096 If hLock Then
2097 Call GlobalUnlock(o_hMem)
2098 Call CreateStreamOnHGlobal(o_hMem, 1&, pvIStreamFromPointer)
2099 Else
2100 hLock = 0&
2101 If Length > 0& Then
2102 o_hMem = GlobalAlloc(&H2&, Length)
2103 If o_hMem Then
2104 o_lpMem = GlobalLock(o_hMem)
2105 If o_lpMem Then
2106 If MemoryPtr Then
2107 CopyMemory ByVal o_lpMem, ByVal MemoryPtr, Length
2108 Call GlobalUnlock(o_hMem)
2109 Call CreateStreamOnHGlobal(o_hMem, 1&, pvIStreamFromPointer)
2110 Else
2111 hLock = o_lpMem
2112 End If
2113 Else
2114 GlobalFree o_hMem: o_hMem = 0&
2115 End If
2116 End If
2117 End If
2118 End If
2119
2120HandleError:
2121End Function
2122
2123Private Function pvQueryFormat(hImage As Long) As Long
2124 ' function returns: 0, 1=gif, 2=tif
2125
2126 Dim GUID(0 To 3) As Long
2127 If GdipGetImageRawFormat(hImage, VarPtr(GUID(0))) = 0& Then
2128 Select Case GUID(0)
2129 Case &HB96B3CB0: pvQueryFormat = ptcGIF
2130 Case &HB96B3CB1: pvQueryFormat = ptcTIF
2131 Case &HB96B3CAB: pvQueryFormat = ptcBitmap ' bitmap file
2132 Case &HB96B3CAA: pvQueryFormat = ptcBitmap ' memory bitmap (Scan0)
2133 Case &HB96B3CAE: pvQueryFormat = ptcJPEG
2134 Case &HB96B3CAF: pvQueryFormat = ptcPNG
2135 Case &HB96B3CAC: pvQueryFormat = ptcEMetafile
2136 End Select
2137 End If
2138End Function
2139
2140Private Function pvGetFrameCount(hImage As Long, PicType As Long) As Long
2141 ' returns the number of frames/pages of the passed GIF/TIF
2142 If PicType = ptcGIF Then
2143 Dim lSize As Long
2144 If m_PageGUID(0, 0) = 0& Then
2145 GdipImageGetFrameDimensionsCount hImage, lSize
2146 If lSize > 0& Then GdipImageGetFrameDimensionsList hImage, m_PageGUID(0, 0), 1&
2147 End If
2148 GdipImageGetFrameCount hImage, m_PageGUID(0, 0), pvGetFrameCount
2149 ElseIf PicType = ptcTIF Then
2150 Const FrameDimensionPage As String = "{7462DC86-6180-4C7E-8E3F-EE7333A7A483}"
2151 If m_PageGUID(0, 1) = 0& Then IIDFromString StrPtr(FrameDimensionPage), m_PageGUID(0, 1)
2152 GdipImageGetFrameCount hImage, m_PageGUID(0, 1), pvGetFrameCount
2153 End If
2154
2155End Function
2156
2157Private Sub pvDisposeGDIpImages()
2158 ' can be called during both Class_Initialize & Class_Terminate
2159 ' clears any cached GDI+ images
2160 Dim lCount As Long, pImages As Long, hImage As Long
2161
2162 If m_ThunkPtr Then
2163 CopyMemory pImages, ByVal pvSafePointerAdd(m_ThunkPtr, 12&), 4&
2164 If pImages Then ' If we have an array, walk it
2165 CopyMemory lCount, ByVal pImages, 4&
2166 For lCount = 0& To lCount - 1&
2167 CopyMemory hImage, pvSafePointerAdd(pImages, lCount * 4& + 8&), 4&
2168 If hImage Then GdipDisposeImage hImage ' destroy any handle in the array
2169 Next ' release the array & update pointer on thunk
2170 CopyMemory ByVal pvSafePointerAdd(m_ThunkPtr, 12&), 0&, 4&
2171 CoTaskMemRealloc pImages, 0&
2172 End If
2173 End If
2174
2175End Sub
2176
2177Private Function pvReverseLong(ByVal inLong As Long) As Long
2178
2179 ' fast function to reverse a long value from big endian to little endian
2180 ' PNG files contain reversed longs, as do ID3 v3,4 tags
2181 pvReverseLong = _
2182 (((inLong And &HFF000000) \ &H1000000) And &HFF&) Or _
2183 ((inLong And &HFF0000) \ &H100&) Or _
2184 ((inLong And &HFF00&) * &H100&) Or _
2185 ((inLong And &H7F&) * &H1000000)
2186 If (inLong And &H80&) Then pvReverseLong = pvReverseLong Or &H80000000
2187End Function
2188
2189Private Function pvValidateAlphaChannel(ByVal PixelPointer As Long, ByVal Width As Long, _
2190 ByVal Height As Long) As Long
2191
2192 ' Method determines if the alhpa channel is used and how it is used
2193 ' Only supports 32 bpp pixel data. Passing any other format will result in a crash
2194 ' Assumption is that you will only call this routine to test 32 bpp data
2195 ' Speedy? For complex transparency, should exit routine very fast. For anything else, all
2196 ' pixels will be scanned unfortuntely. Just can't exit until format is known for sure.
2197
2198 Dim bAlpha As Long, lFormat As Long
2199 Dim lColor As Long, lPrevColor As Long
2200 Dim bScanLine() As Long, y As Long, x As Long
2201 Const ZEROES As Long = 256&
2202
2203 ' lFormat will contain one or more of these
2204 ' acuAllBlack = 0 ' image can be interpreted as 100% black or 100% transparent
2205 ' acuOpaqueAssumed = 1 ' all alpha values are zero, assuming image is not meant to be 100% transparent
2206 ' acuOpaque = 2 ' alpha channel is used, but all alpha values are 255
2207 ' acuSimpleTransparency = 4 ' alpha channel is used and contains simple transparency only
2208 ' acuComplexTransparency = 8 ' alpha channel is used and contains complex transparency
2209 ' acuPremultipliedRGB = 16 ' R,G,B components are multiplied against the alpha channel
2210 On Error GoTo ExitRoutine
2211
2212 ' ///// test the alpha channel. Loop aborts early if it can
2213 ReDim bScanLine(0 To Width - 1&)
2214 CopyMemory lPrevColor, ByVal PixelPointer, 4&
2215 lPrevColor = lPrevColor Xor 1&
2216
2217 For y = 0& To Height - 1&
2218 x = Width * 4&
2219 CopyMemory bScanLine(0), ByVal pvSafePointerAdd(PixelPointer, x * y), x
2220 For x = 0& To Width - 1&
2221 lColor = bScanLine(x) ' get 32bit color
2222 If Not lColor = lPrevColor Then ' and extact the alpha byte
2223 If lColor = 0& Then
2224 lFormat = lFormat Or ZEROES ' entire value is zero
2225 ' all zeroes indicates 100% transparent or 100% black image
2226 ' mix of zero & non-zero alpha values indicates transparency
2227 Else
2228 bAlpha = (lColor And &HFF000000) \ &H1000000 And &HFF
2229 If bAlpha = 0& Then
2230 If (lColor And &HFFFFFF) Then ' RGB value is non-zero
2231 If (lFormat And Not ZEROES) > 2& Then
2232 ' at least one other alpha value was > 0 and < 255
2233 ' since this alpha is zero & RGB non-zero. Done:
2234 lFormat = 8&: y = Height: Exit For
2235 End If
2236 lFormat = lFormat Or 1& ' keep going, maybe all alphas are zero
2237 End If
2238 ElseIf bAlpha = 255& Then
2239 If (lFormat And 1&) Then
2240 ' already seen alpha zero & non-zero RGB. Here we have 255 alpha. Done:
2241 lFormat = 8&: y = Height: Exit For
2242 End If
2243 lFormat = lFormat Or 2&
2244
2245 ' else if any RGB values > alpha then not-premultiplied
2246 ElseIf bAlpha < (lColor And &HFF&) Then
2247 lFormat = 8&: y = Height: Exit For ' definitly ARGB
2248 ElseIf bAlpha < (lColor And &HFF00&) \ &H100& Then
2249 lFormat = 8&: y = Height: Exit For ' definitly ARGB
2250 ElseIf bAlpha < (lColor And &HFF0000) \ &H10000 Then
2251 lFormat = 8&: y = Height: Exit For ' definitly ARGB
2252 Else
2253 lFormat = lFormat Or 16& ' likely pARGB, but not sure yet
2254 End If
2255 End If
2256 lPrevColor = lColor
2257 End If
2258 Next
2259 Next
2260 ' ///// Step 4: Analyze result
2261 If (lFormat And Not ZEROES) = 8& Then ' alpha, not premultiplied
2262 pvValidateAlphaChannel = PixelFormat32bppAlpha
2263 ElseIf lFormat = (ZEROES Or 2&) Then ' simple transparency
2264 pvValidateAlphaChannel = PixelFormat32bpp
2265 ElseIf (lFormat And 16&) Then ' premultiplied RGB
2266 pvValidateAlphaChannel = PixelFormat32bppPremultiplied
2267 End If ' else assume alpha channel not used
2268
2269ExitRoutine:
2270End Function
2271
2272Private Sub pvAddGDIpItem(pPicRef As PICREF)
2273
2274 ' called when the class will be managing a picture object
2275
2276 Dim pNew As Long, pImages As Long
2277 Dim lCount As Long, lSize As Long
2278
2279 If pPicRef.pHandle Then
2280 CopyMemory pImages, ByVal pvSafePointerAdd(m_ThunkPtr, 12&), 4&
2281 If pImages Then ' get size of array & count of handles
2282 CopyMemory lSize, ByVal pvSafePointerAdd(pImages, 4&), 4&
2283 CopyMemory lCount, ByVal pImages, 4&
2284 If lCount = lSize Then ' array is full
2285 lSize = lSize + 3& ' increase array with buffer of 2 spare slots
2286 Else
2287 lSize = 0& ' array does not need to be resized
2288 End If
2289 lCount = lCount + 1& ' increment count
2290 Else
2291 lSize = 3&: lCount = 1& ' new array, init size for 3 handle slots
2292 End If
2293 If lSize Then ' resizing.... attempt it
2294 pNew = CoTaskMemRealloc(pImages, lSize * 4& + 8&)
2295 If pNew = 0& Then Exit Sub ' if failure, we can't add it
2296 pImages = pNew ' otherwise...
2297 CopyMemory ByVal pvSafePointerAdd(pImages, 4&), lSize, 4& ' update the array size
2298 CopyMemory ByVal pvSafePointerAdd(m_ThunkPtr, 12&), pImages, 4& ' update the array pointer
2299 End If
2300 CopyMemory ByVal pImages, lCount, 4& ' update the handle count, add new handle
2301 CopyMemory ByVal pvSafePointerAdd(pImages, lCount * 4& + 4&), pPicRef.pHandle, 4&
2302 End If
2303 If m_RefCount = 0& Then ' resize local array as needed
2304 ReDim m_PicRefs(-1 To 2) ' FYI: local array is lookup & IStream cache
2305 ElseIf m_RefCount > UBound(m_PicRefs) Then
2306 ReDim Preserve m_PicRefs(-1 To m_RefCount + 2&)
2307 End If
2308 m_PicRefs(m_RefCount) = pPicRef ' add to our local array
2309 m_RefCount = m_RefCount + 1& ' increment local array count
2310
2311End Sub
2312
2313Private Function pvCreateThunks() As Boolean
2314
2315 ' This class method is only ever called once
2316 ' It will set the m_ThunkPtr to one of these values:
2317 ' -1: indicating class failed to create thunk or some other error prevented it
2318 ' non-zero: The thunk address created by this class or existing in another instance of this class
2319
2320 Const THUNK_LONGS As Long = 110&
2321 Const PAGE_RWX As Long = &H40&
2322 Const MEM_COMMIT As Long = &H1000&
2323 Const MEM_RELEASE As Long = &H8000&
2324 Const GWL_WNDPROC As Long = -4&
2325 Const WS_CHILD As Long = &H40000000
2326
2327 Dim z_Code(0 To THUNK_LONGS) As Long
2328 Dim hMod As Long, vThunks(0 To 2) As Long
2329 Dim MEM_LEN As Long, MBI() As Long
2330 Dim hGDIplus As Long, hMsImg As Long, hToken As Long
2331 Dim tPic As StdPicture, nIPic As IPicture
2332 Dim vIPic As Long, vIPicDisp As Long, Index As Long
2333 Dim hWnd As Long, tObj As Object
2334
2335 If m_Hwnd = 0& Then ' complete failure. Could not locate the VB owner window
2336 m_ThunkPtr = -1&
2337 Exit Function
2338 End If
2339
2340 hWnd = m_Hwnd: m_Hwnd = 0& ' look for a child window we created on the owner window
2341 m_Hwnd = FindWindowEx(hWnd, 0&, "Static", "IPIC+Thunker")
2342 If m_Hwnd = 0& Then ' if not found, create it now & abort if failure
2343 m_Hwnd = CreateWindowEx(0&, "Static", "IPIC+Thunker", WS_CHILD, 0&, 0&, 0&, 0&, hWnd, 0&, 0&, ByVal 0&)
2344 If m_Hwnd = 0& Then m_ThunkPtr = -1&: Exit Function
2345 ' thunks will now be created below
2346 Else ' otherwise, get the thunk pointer and other info
2347 m_ThunkPtr = GetProp(m_Hwnd, "ThunkAddr")
2348 If m_ThunkPtr = -1& Then Exit Function
2349 CopyMemory hToken, ByVal m_ThunkPtr, 4&
2350 If hToken Then ' is there an active thunk class out there?
2351 CopyMemory tObj, hToken, 4& ' if so, create a reference to it
2352 Set m_Primary = tObj ' and if it's this class, clear the extra reference
2353 CopyMemory tObj, 0&, 4&
2354 If m_Primary Is Me Then Set m_Primary = Nothing
2355 Else ' else this class will be the active one. Update thunk variables
2356 CopyMemory ByVal m_ThunkPtr, ObjPtr(Me), 4&
2357 CopyMemory ByVal pvSafePointerAdd(m_ThunkPtr, 4&), zAddressOf(Me, 1), 4&
2358 End If
2359 pvCreateThunks = True
2360 Exit Function
2361 End If
2362
2363 '/////////////////////////////////////////////////////////////////////////////////////////////////////
2364 ' Thunk #1: Management Window's new window procedure (Subclass.asm file included with project)
2365 '/////////////////////////////////////////////////////////////////////////////////////////////////////
2366 ' Thunk starts @ 15*4 bytes after vThunks(0)
2367 MEM_LEN = 4& * 65& ' 65 = last filled z_Code() member plus 1
2368 vThunks(0) = VirtualAlloc(0&, MEM_LEN, MEM_COMMIT, PAGE_RWX)
2369 If vThunks(0) = 0& Then GoTo ExitRoutine
2370
2371 z_Code(15) = &HD231C031: z_Code(16) = &HBBE58960: z_Code(18) = &HFF90F631: z_Code(19) = &H75FF3075: z_Code(20) = &H2875FF2C: z_Code(21) = &H682475FF
2372 z_Code(23) = &H891C53FF: z_Code(24) = &H1FB81C45: z_Code(25) = &H39000000: z_Code(26) = &H31752845: z_Code(27) = &H1F307D83: z_Code(28) = &H8A850F
2373 z_Code(29) = &H33390000: z_Code(30) = &H82840F: z_Code(31) = &H73390000: z_Code(32) = &HFF107410: z_Code(33) = &HF8831053: z_Code(34) = &H85087401
2374 z_Code(35) = &H897175C0: z_Code(36) = &HFF6DEB33: z_Code(37) = &H33FF2C75: z_Code(38) = &HEB0453FF: z_Code(39) = &H287D8363: z_Code(40) = &H8B5D7502
2375 z_Code(41) = &H78B087B: z_Code(42) = &H2453FF50: z_Code(43) = &H680C478B: z_Code(44) = &H8000&: z_Code(45) = &H53FF5056: z_Code(46) = &H80006814
2376 z_Code(47) = &HFF560000: z_Code(48) = &H53FF0873: z_Code(49) = &HC733914: z_Code(50) = &H7B8B1F74: z_Code(51) = &H390F8B0C: z_Code(52) = &H8B0E74F1
2377 z_Code(53) = &H39048F44: z_Code(54) = &H510674F0: z_Code(55) = &H2853FF50: z_Code(56) = &HFFF0E259: z_Code(57) = &H53FF0C73: z_Code(58) = &H30733920
2378 z_Code(59) = &H73FF0674: z_Code(60) = &H2C53FF30: z_Code(61) = &HFF3473FF: z_Code(62) = &H73FF1853: z_Code(63) = &H1853FF38: z_Code(64) = &H10C261
2379
2380 z_Code(0) = ObjPtr(Me)
2381 z_Code(1) = zAddressOf(Me, 1)
2382 'z_Code(2) Thunk#2 address, to be filled in later
2383 'z_Code(3) filled in dynamically, as needed: gdi+ image handle table
2384 On Error Resume Next
2385 Debug.Print 1 / 0 ' when in IDE, prevent calling back to this class
2386 If Err Then ' when the IDE is stopped, paused, or ended
2387 Err.Clear ' any VB5 users still out there? If so, change vba6 below to vba5
2388 z_Code(4) = GetProcAddress(GetModuleHandle("vba6"), "EbMode")
2389 End If
2390 On Error GoTo 0
2391 hMod = GetModuleHandle("Kernel32.dll") ' function pointers used by the thunk
2392 z_Code(5) = GetProcAddress(hMod, "VirtualFree")
2393 z_Code(6) = GetProcAddress(hMod, "FreeLibrary")
2394 z_Code(7) = GetProcAddress(GetModuleHandle("User32.dll"), "CallWindowProcA")
2395 z_Code(8) = GetProcAddress(GetModuleHandle("ole32.dll"), "CoTaskMemFree")
2396 z_Code(9) = GetProcAddress(GetModuleHandle("gdi32.dll"), "DeleteDC")
2397 ReDim MBI(0 To 3): MBI(0) = 1& ' MBI() equivalent to GDI+ Startup structure
2398 Call GdiplusStartup(hToken, MBI(0))
2399 If hToken Then
2400 hGDIplus = LoadLibrary("GdiPlus.dll") ' Load GDI+ into process & cache its instance
2401 z_Code(10) = GetProcAddress(hGDIplus, "GdipDisposeImage")
2402 z_Code(11) = GetProcAddress(hGDIplus, "GdiplusShutdown")
2403 z_Code(12) = hToken
2404 z_Code(13) = hGDIplus
2405 End If
2406 hMsImg = LoadLibrary("msimg32.dll") ' Load msimg32 into process and cache its instance
2407 z_Code(14) = hMsImg
2408 z_Code(17) = vThunks(0)
2409 z_Code(22) = GetWindowLong(m_Hwnd, GWL_WNDPROC)
2410
2411 ' sanity checks
2412 For Index = 0& To 14&
2413 If z_Code(Index) = 0& Then
2414 If Index < 2& Or Index > 4& Then ' z_Code(2)(3) done later, z_Code(4) applies to IDE only
2415 VirtualFree vThunks(0), 0&, MEM_RELEASE
2416 vThunks(0) = 0&
2417 GoTo ExitRoutine
2418 End If
2419 End If
2420 Next
2421 CopyMemory ByVal vThunks(0), z_Code(0), MEM_LEN
2422
2423 '/////////////////////////////////////////////////////////////////////////////////////////////////////
2424 ' Thunk #2: IPicture & IPictureDisp thunks (Vtable.asm file included with project)
2425 '/////////////////////////////////////////////////////////////////////////////////////////////////////
2426 MEM_LEN = 4& * 105& ' 105 = last filled z_Code() member plus 1
2427 vThunks(1) = VirtualAlloc(0&, MEM_LEN, MEM_COMMIT, PAGE_RWX)
2428 If vThunks(1) = 0& Then GoTo ExitRoutine
2429
2430 Erase z_Code()
2431 ' IPictureDisp IUnknown:Release thunk. Starts @ 14*4 bytes after vThunks(1)
2432 z_Code(14) = &HD231C031: z_Code(15) = &HBBE58960: z_Code(17) = &H7B8BF631: z_Code(18) = &H2475FF04: z_Code(19) = &H890857FF
2433 z_Code(20) = &H75391C45: z_Code(21) = &H6A0D751C: z_Code(22) = &H2475FF1F: z_Code(23) = &H73FF1F6A: z_Code(24) = &H1C53FF10: z_Code(25) = &H4C261
2434 ' IPicture IUnknown:Release thunk. Starts @ 26*4 bytes after vThunks(1)
2435 z_Code(26) = &HD231C031: z_Code(27) = &HBBE58960: z_Code(29) = &H7B8BF631: z_Code(30) = &H90CEEB08
2436 ' IPicture:GetAttributes thunk. Starts @ 31*4 bytes after vThunks(1)
2437 z_Code(31) = &HD231C031: z_Code(32) = &HBBE58960: z_Code(34) = &H7539F631: z_Code(35) = &H8B0B7428: z_Code(36) = &H7C7287D
2438 z_Code(37) = &H2&: z_Code(38) = &H45C707EB: z_Code(39) = &H700571C: z_Code(40) = &H8C26180: z_Code(41) = &H90909000
2439 ' IPicture:Render thunk. Starts @ 42*4 bytes after vThunks(1)
2440 z_Code(42) = &HD231C031: z_Code(43) = &HBBE58960: z_Code(45) = &H738BF631: z_Code(46) = &H2C7B8D08: z_Code(47) = &H2475FF57: z_Code(48) = &H830C56FF
2441 z_Code(49) = &HF002C7B: z_Code(50) = &HD484&: z_Code(51) = &H347B8D00: z_Code(52) = &H2475FF57: z_Code(53) = &H8D1C56FF: z_Code(54) = &HFF57307B
2442 z_Code(55) = &H56FF2475: z_Code(56) = &H30638314: z_Code(57) = &H307B8307: z_Code(58) = &H97840F03: z_Code(59) = &H83000000: z_Code(60) = &HF01307B
2443 z_Code(61) = &HA885&: z_Code(62) = &H75FF5700: z_Code(63) = &H2856FF24: z_Code(64) = &H7339F631: z_Code(65) = &H8B117530: z_Code(66) = &H30438903
2444 z_Code(67) = &HFF2C73FF: z_Code(68) = &H53FF3073: z_Code(69) = &H2C438924: z_Code(70) = &HFF000068: z_Code(71) = &H2BC03101: z_Code(72) = &H52E84845
2445 z_Code(73) = &H50000000: z_Code(74) = &HE844458B: z_Code(75) = &H49&: z_Code(76) = &H34438B50: z_Code(77) = &H29404D8B: z_Code(78) = &H3BE8C8
2446 z_Code(79) = &H39500000: z_Code(80) = &H5753C75: z_Code(81) = &HEB3C75FF: z_Code(82) = &H3C458B09: z_Code(83) = &H28E8&: z_Code(84) = &H73FF5000
2447 z_Code(85) = &H3875FF30: z_Code(86) = &HFF3475FF: z_Code(87) = &H75FF3075: z_Code(88) = &H2875FF2C: z_Code(89) = &H8B1853FF: z_Code(90) = &H30433903
2448 z_Code(91) = &H73FF3375: z_Code(92) = &H3073FF2C: z_Code(93) = &HEB2453FF: z_Code(94) = &H9EC6828: z_Code(95) = &H73FF0000: z_Code(96) = &H53FF5014
2449 z_Code(97) = &HF631C328: z_Code(98) = &H5656036A: z_Code(99) = &HFF3875FF: z_Code(100) = &H73FF3475: z_Code(101) = &H3075FF2C: z_Code(102) = &HFF2C75FF
2450 z_Code(103) = &H53FF2875: z_Code(104) = &H2CC26120
2451
2452 ' fill in thunk constants/variables
2453 z_Code(0) = CreateCompatibleDC(0&) ' Render's DC
2454 Set tPic = New StdPicture: Set nIPic = tPic
2455 CopyMemory vIPicDisp, ByVal ObjPtr(tPic), 4& ' Original IPictureDisp vTable
2456 CopyMemory vIPic, ByVal ObjPtr(nIPic), 4& ' Original IPicture vTable
2457 Set nIPic = Nothing: Set tPic = Nothing
2458 z_Code(1) = vIPicDisp ' COM's IPictureDisp used for all stdPictures
2459 z_Code(2) = vIPic ' COM's IPicture used for all stdPictures
2460 'z_Code(3) to be filled in a little later. Address for copy of COM Vtable
2461 z_Code(4) = m_Hwnd ' management window's handle
2462 z_Code(5) = 1440 / Screen.TwipsPerPixelX ' VB's DPI, virutalized or not. Used in MulDiv call
2463 z_Code(6) = GetProcAddress(hMsImg, "AlphaBlend") ' function pointers used in the thunks
2464 hMod = GetModuleHandle("User32.dll")
2465 z_Code(7) = GetProcAddress(hMod, "PostMessageA")
2466 z_Code(8) = GetProcAddress(hMod, "DrawIconEx")
2467 z_Code(9) = GetProcAddress(GetModuleHandle("gdi32.dll"), "SelectObject")
2468 z_Code(10) = GetProcAddress(GetModuleHandle("kernel32.dll"), "MulDiv")
2469 ' address of constants/variables for each of the 4 subclassed functions above
2470 z_Code(16) = vThunks(1): z_Code(28) = vThunks(1): z_Code(33) = vThunks(1): z_Code(44) = vThunks(1)
2471
2472 ' sanity checks
2473 For Index = 0& To 10& ' z_Code(11) & (12) are always zero; thunk use only
2474 If z_Code(Index) = 0& Then
2475 If Not Index = 3& Then
2476 VirtualFree vThunks(1), 0&, MEM_RELEASE
2477 vThunks(1) = 0&
2478 GoTo ExitRoutine
2479 End If
2480 End If
2481 Next
2482 CopyMemory ByVal vThunks(1), z_Code(0), MEM_LEN
2483 CopyMemory ByVal pvSafePointerAdd(vThunks(0), 8&), vThunks(1), 4& ' place thunk address in management window's thunk
2484
2485 '/////////////////////////////////////////////////////////////////////////////////////////////////////
2486 ' Copy of COM's VTable for IPicture & IPictureDisp
2487 '/////////////////////////////////////////////////////////////////////////////////////////////////////
2488 ReDim MBI(0 To 6) ' get memory used by COM for IPicture/IPictureDisp
2489 VirtualQuery ByVal vIPic, MBI(0), 28& ' MBI() equivalent to MEMORY_BASIC_INFORMATION udt
2490 vThunks(2) = VirtualAlloc(0&, MBI(3), MEM_COMMIT, PAGE_RWX) ' reserve memory for same size
2491 If vThunks(2) = 0& Then GoTo ExitRoutine
2492
2493 CopyMemory ByVal vThunks(2), ByVal MBI(0), MBI(3) ' copy VTable memory and we will hack this copy only
2494 CopyMemory ByVal pvSafePointerAdd(vThunks(1), 12&), vThunks(2), 4& ' update thunk #2 with address of this copy
2495
2496 vIPicDisp = pvSafePointerAdd(vThunks(2), vIPicDisp - MBI(0))
2497 ' subclass IPictureDisp IUnknown:Release
2498 CopyMemory ByVal pvSafePointerAdd(vIPicDisp, 8&), pvSafePointerAdd(vThunks(1), 14& * 4&), 4&
2499
2500 vIPic = pvSafePointerAdd(vThunks(2), vIPic - MBI(0)): Erase MBI()
2501 ' subclass IPicture IUnknown:Release
2502 CopyMemory ByVal pvSafePointerAdd(vIPic, 8&), pvSafePointerAdd(vThunks(1), 26& * 4&), 4&
2503 ' subclass IPicture:Render
2504 CopyMemory ByVal pvSafePointerAdd(vIPic, 32&), pvSafePointerAdd(vThunks(1), 42& * 4&), 4&
2505 ' subclass IPicture:GetAttributes
2506 CopyMemory ByVal pvSafePointerAdd(vIPic, 64&), pvSafePointerAdd(vThunks(1), 31& * 4&), 4&
2507
2508
2509ExitRoutine:
2510 ' clean up if failure occurred above...
2511 For Index = 2& To 0& Step -1&
2512 If vThunks(Index) = 0& Then Exit For ' if any thunk failed creation, rewind everything
2513 Next
2514 If Index < 0& Then
2515 m_ThunkPtr = vThunks(0)
2516 SetProp m_Hwnd, "ThunkAddr", m_ThunkPtr
2517 SetProp m_Hwnd, "IPicAddr", vIPic
2518 SetProp m_Hwnd, "IPicDispAddr", vIPicDisp
2519 ' start subclassing the management window
2520 SetWindowLong m_Hwnd, GWL_WNDPROC, pvSafePointerAdd(m_ThunkPtr, 15& * 4&)
2521 pvCreateThunks = True
2522
2523 Else ' not all thunks were created, failure & abort
2524 m_ThunkPtr = -1&
2525 For Index = 0& To 2& ' ensure all thunks are released
2526 If vThunks(Index) Then VirtualFree vThunks(Index), 0&, MEM_RELEASE
2527 Next ' ensure any manually loaded DLLs are released
2528 If hMsImg Then FreeLibrary hMsImg
2529 If hGDIplus Then ' ensure GDI+ is stopped if it was started
2530 If hToken Then GdiplusShutdown hToken
2531 FreeLibrary hGDIplus
2532 End If ' set flag on management window so this routine is effectively disabled
2533 SetProp m_Hwnd, "ThunkAddr", m_ThunkPtr
2534 End If
2535
2536End Function
2537
2538Private Function pvSafePointerAdd(thePointer As Long, AmountToAdjust As Long) As Long
2539 ' ensure no pointer addition/subtraction wraps from postiive to negative or vice versa
2540 Const SIGN_BIT = &H80000000
2541 pvSafePointerAdd = ((thePointer Xor SIGN_BIT) + AmountToAdjust) Xor SIGN_BIT
2542End Function
2543
2544Private Function pvDWordAlign(ByVal Depth As Long, ByVal Width As Long, Optional ByVal Height As Long) As Long
2545 ' determine DWord aligned scan width for bitmaps. total bmp bits includes multiplying by rows (height)
2546 ' https://support.microsoft.com/en-us/kb/80080
2547 pvDWordAlign = ((Width * Depth + &H1F&) And Not &H1F&) \ &H8&
2548 If Height Then pvDWordAlign = pvDWordAlign * Abs(Height)
2549End Function
2550
2551'Return the address of the specified ordinal method on the oCallback object, 1 = last private method, 2 = second last private method, etc
2552Private Function zAddressOf(ByVal oCallback As Object, ByVal nOrdinal As Long) As Long
2553 Dim bSub As Byte 'Value we expect to find pointed at by a vTable method entry
2554 Dim bVal As Byte
2555 Dim nAddr As Long 'Address of the vTable
2556 Dim I As Long 'Loop index
2557 Dim J As Long 'Loop limit
2558
2559 CopyMemory nAddr, ByVal ObjPtr(oCallback), 4& 'Get the address of the callback object's instance
2560 If zProbe(nAddr + &H1C, I, bSub) = False Then Exit Function 'Probe for a Class method
2561
2562 I = pvSafePointerAdd(I, 4&) 'Bump to the next entry
2563 Do While J < 256 'Set a reasonable limit, scan 256 vTable entries
2564 CopyMemory nAddr, ByVal I, 4& 'Get the address stored in this vTable entry
2565
2566 If IsBadCodePtr(nAddr) Then 'Is the entry an invalid code address?
2567 CopyMemory zAddressOf, ByVal pvSafePointerAdd(I, -(nOrdinal * 4&)), 4& 'Return the specified vTable entry address
2568 Exit Do 'Bad method signature, quit loop
2569 End If
2570
2571 CopyMemory bVal, ByVal nAddr, 1& 'Get the byte pointed to by the vTable entry
2572 If bVal <> bSub Then 'If the byte doesn't match the expected value...
2573 CopyMemory zAddressOf, ByVal pvSafePointerAdd(I, -(nOrdinal * 4&)), 4& 'Return the specified vTable entry address
2574 Exit Do 'Bad method signature, quit loop
2575 End If
2576 J = J + 1&
2577 I = pvSafePointerAdd(I, 4&) 'Next vTable entry
2578 Loop
2579End Function
2580
2581'Probe at the specified start address for a method signature
2582Private Function zProbe(ByVal nStart As Long, ByRef nMethod As Long, ByRef bSub As Byte) As Boolean
2583 Dim bVal As Byte
2584 Dim nAddr As Long
2585 Dim nLimit As Long
2586 Dim nEntry As Long
2587
2588 nAddr = nStart 'Start address
2589 nLimit = nAddr + 32& 'Probe eight entries
2590 Do While nAddr < nLimit 'While we've not reached our probe depth
2591 CopyMemory nEntry, ByVal nAddr, 4& 'Get the vTable entry
2592
2593 If nEntry <> 0 Then 'If not an implemented interface
2594 CopyMemory bVal, ByVal nEntry, 1& 'Get the value pointed at by the vTable entry
2595 If bVal = &H33 Or bVal = &HE9 Then 'Check for a native or pcode method signature
2596 nMethod = nAddr 'Store the vTable entry
2597 bSub = bVal 'Store the found method signature
2598 zProbe = True 'Indicate success
2599 Exit Function 'Return
2600 End If
2601 End If
2602
2603 nAddr = nAddr + 4& 'Next vTable entry
2604 Loop
2605End Function
2606
2607Private Sub Class_Initialize()
2608 ' locates top-level VB owner window. This applies both during IDE and compiled exe
2609 ' determine if Vista or better being run
2610 ' cleans up any GDI+ image handles that may have been created from a previous instance
2611 ' where that instance was not shut down properly, i.e., END executed in IDE
2612 Dim lWnd As Long, pObj As Long
2613 Const WS_SYSMENU As Long = &H80000
2614 Const WS_VISIBLE As Long = &H10000000
2615 Const GW_OWNER As Long = 4
2616 Const GW_HWNDNEXT As Long = 2
2617 Const GWL_STYLE As Long = -16
2618
2619 Dim sBuffer() As Byte
2620 Dim nBufferLen As Long
2621 Dim lplpBuffer As Long
2622 Dim vsffi(0 To 25) As Integer ' equivalent to VS_FIXEDFILEINFO
2623 Dim puLen As Long
2624
2625 nBufferLen = GetFileVersionInfoSize("kernel32.dll", ByVal VarPtr(vsffi(0)))
2626 If nBufferLen > 0 Then
2627 ReDim sBuffer(nBufferLen) As Byte
2628 Call GetFileVersionInfo("kernel32.dll", 0&, nBufferLen, sBuffer(0))
2629 Call VerQueryValue(sBuffer(0), "\", lplpBuffer, puLen)
2630 Call CopyMemory(vsffi(0), ByVal lplpBuffer, 52&)
2631 m_VistaPlus = CBool(vsffi(5) > 5&) ' major version; want to know if Vista or higher O/S
2632 End If
2633
2634 lWnd = FindWindow(vbNullString, vbNullString)
2635 Do Until lWnd = 0
2636 If GetWindowThreadProcessId(lWnd, ByVal 0&) = App.ThreadID Then
2637 If (GetWindowLong(lWnd, GWL_STYLE) And (WS_SYSMENU Or WS_VISIBLE)) = (WS_SYSMENU Or WS_VISIBLE) Then
2638 If GetWindow(lWnd, GW_OWNER) = 0 Then
2639 m_Hwnd = lWnd
2640 Exit Do
2641 End If
2642 End If
2643 End If
2644 lWnd = GetWindow(lWnd, GW_HWNDNEXT)
2645 Loop
2646 If m_Hwnd Then
2647 ' if previous instance of this class was terminated via END, then any GDI+ images
2648 ' that were created were not destroyed; still hanging out in memory & is a crash potential.
2649 ' Clean that up as needed
2650 lWnd = FindWindowEx(m_Hwnd, 0&, "Static", "IPIC+Thunker")
2651 If lWnd Then
2652 m_ThunkPtr = GetProp(lWnd, "ThunkAddr")
2653 If Not (m_ThunkPtr = 0& Or m_ThunkPtr = -1&) Then ' thunk exists
2654 CopyMemory pObj, ByVal m_ThunkPtr, 4& ' subclasser instance handle?
2655 If pObj = 0& Then Call pvDisposeGDIpImages
2656 End If
2657 m_ThunkPtr = 0& ' reset; key flag to determine if pvInitialize is ever called
2658 End If
2659 End If
2660End Sub
2661
2662Private Sub Class_Terminate()
2663
2664 ' free up any GDI+ related images, update a couple thunk variables
2665 If m_Primary Is Nothing Then ' we are the primary
2666 If Not (m_ThunkPtr = 0 Or m_ThunkPtr = -1&) Then ' else class has not been fully initialized
2667 CopyMemory ByVal m_ThunkPtr, 0&, 4& ' prevetnt callbacks to this class
2668 ' Safe to walk routine after above line is executed
2669 Call pvDisposeGDIpImages ' destroy any GDI+ handles; if those handles were IStream-based,
2670 Erase m_PicRefs() ' then erasing array, removes IStream references
2671 End If
2672 If m_hDC Then DeleteDC m_hDC
2673 Else
2674 Set m_Primary = Nothing
2675 End If
2676End Sub
2677
2678'/////////////////////////////////////////////////////////////////////////////////////////////////////
2679' WARNING: This is always the final method in the class, nothing can follow it.
2680' Ignoring this warning will result in a crash every time
2681'/////////////////////////////////////////////////////////////////////////////////////////////////////
2682Private Sub pvReleased(ByVal pUnk As Long)
2683 ' This method is called by the Management thunk. It is called when either a
2684 ' subclassed IPicture or IPictureDisp interface is being set to Nothing.
2685 ' Note to self: Reason for subclassing both IPicture & IPictureDisp interfaces'
2686 ' IUnknown:Release functions is because one or the other would show a zero
2687 ' reference count. Both would not. In other words, it appears when the picture
2688 ' is being dereferenced, one of the interfaces is called and the other is
2689 ' reset internally by COM. Just a guess.
2690
2691 ' Only purpose of this method is to release any GDI+ image handle that is associated with
2692 ' the passed interface. Unless the picture being destroyed was loaded as a multi-page
2693 ' TIFF or multi-frame GIF, there will be no action taken in this method
2694
2695 Dim Index As Long, hImage As Long, lCount As Long
2696 Dim pImages As Long, gImage As Long, gIndex As Long
2697
2698' Debug.Print "releasing "; pUnk
2699
2700 For Index = 0& To m_RefCount - 1& ' locate the pUnk object in our array
2701 If pUnk = m_PicRefs(Index).pIPicture Then
2702 hImage = m_PicRefs(Index).pHandle ' set reference & exit loop
2703 Exit For
2704 ElseIf pUnk = m_PicRefs(Index).pIPicDisp Then
2705 hImage = m_PicRefs(Index).pHandle ' set reference & exit loop
2706 Exit For
2707 End If
2708 Next
2709 If Index < m_RefCount Then
2710 If hImage Then
2711 GdipDisposeImage hImage ' dispose of the image
2712 CopyMemory pImages, ByVal pvSafePointerAdd(m_ThunkPtr, 12&), 4& ' get array of GDI+ handles
2713 If pImages Then ' could be zero
2714 CopyMemory lCount, ByVal pImages, 4& ' get handle count in array
2715 For Index = 0& To lCount - 1& ' start the search
2716 CopyMemory gImage, ByVal pvSafePointerAdd(pImages, Index * 4& + 8&), 4&
2717 If gImage = hImage Then
2718 lCount = lCount - 1&
2719 If lCount = 0& Then ' release the array
2720 CopyMemory ByVal pvSafePointerAdd(m_ThunkPtr, 12&), 0&, 4&
2721 CoTaskMemRealloc pImages, 0&
2722 Else ' update array & shift as needed
2723 If Index < lCount Then
2724 CopyMemory ByVal pvSafePointerAdd(pImages, Index * 4& + 8&), _
2725 ByVal pvSafePointerAdd(pImages, lCount * 4& + 8&), 4&
2726 End If
2727 CopyMemory ByVal pImages, lCount, 4& ' update the count & exit loop
2728 End If
2729 Exit For
2730 End If
2731 Next
2732 End If
2733 End If
2734 Set m_PicRefs(Index).oStream = Nothing ' release the IStream as needed
2735 m_RefCount = m_RefCount - 1& ' update count & shift array as needed
2736 If Index < m_RefCount Then m_PicRefs(Index) = m_PicRefs(m_RefCount)
2737 Set m_PicRefs(m_RefCount).oStream = Nothing
2738 End If
2739
2740End Sub
2741'/////////////////////////////////////////////////////////////////////////////////////////////////////
2742' WARNING: No executable code can follow this warning banner
2743'/////////////////////////////////////////////////////////////////////////////////////////////////////
2744