-
Notifications
You must be signed in to change notification settings - Fork 7
/
AlphaBlendImage.ctl
1610 lines (1505 loc) · 58.4 KB
/
AlphaBlendImage.ctl
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
VERSION 5.00
Begin VB.UserControl AlphaBlendImage
BackStyle = 0 'Transparent
CanGetFocus = 0 'False
ClientHeight = 2880
ClientLeft = 0
ClientTop = 0
ClientWidth = 3840
ClipBehavior = 0 'None
DrawStyle = 2 'Dot
ScaleHeight = 240
ScaleMode = 3 'Pixel
ScaleWidth = 320
Windowless = -1 'True
End
Attribute VB_Name = "AlphaBlendImage"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'=========================================================================
'
' AlphaBlendImage (c) 2019 by wqweto@gmail.com
'
' Poor Man's Transparent Image Control
'
'=========================================================================
Option Explicit
DefObj A-Z
Private Const STR_MODULE_NAME As String = "AlphaBlendImage"
'=========================================================================
' Public events
'=========================================================================
Event Click()
Event OwnerDraw(ByVal hGraphics As Long, ClientLeft As Long, ClientTop As Long, ClientWidth As Long, ClientHeight As Long, ByVal hPicture As Long)
Event DblClick()
Event ContextMenu()
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'=========================================================================
' API
'=========================================================================
'--- for GdipCreateBitmapFromScan0
Private Const PixelFormat32bppARGB As Long = &H26200A
Private Const PixelFormat32bppPARGB As Long = &HE200B
'--- for GdipDrawImageXxx
Private Const UnitPixel As Long = 2
'--- DIB Section constants
Private Const DIB_RGB_COLORS As Long = 0 ' color table in RGBs
'--- for GdipSetInterpolationMode
Private Const InterpolationModeHighQualityBicubic As Long = 7
'--- for Gdip*WorldTransform
Private Const MatrixOrderAppend As Long = 1
'--- for GdipBitmapLockBits
Private Const ImageLockModeRead As Long = 1
'--- for GlobalAlloc
Private Const GMEM_DDESHARE As Long = &H2000
Private Const GMEM_MOVEABLE As Long = &H2
'--- for SetClipboardData
Private Const CF_DIBV5 As Long = 17
Private Const BI_BITFIELDS As Long = 3
'--- for GetWindowLong
Private Const GWL_EXSTYLE As Long = -20
Private Const WS_EX_LAYERED As Long = &H80000
'--- for UpdateLayeredWindow
Private Const ULW_ALPHA As Long = 2
Private Const AC_SRC_OVER As Long = 0
Private Const AC_SRC_ALPHA As Long = 1
'--- for CreateImagingFactory
Private Const WINCODEC_SDK_VERSION1 As Long = &H236&
Private Const WINCODEC_SDK_VERSION2 As Long = &H237&
'--- for CreateDecoderFromFilename
Private Const GENERIC_READ As Long = &H80000000
'--- for IWICBitmapScaler
Private Const WICBitmapInterpolationModeFant As Long = 3
Private Const WICBitmapInterpolationModeHighQualityCubic As Long = 4
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long)
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Function OleTranslateColor Lib "oleaut32" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByVal lColorRef As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, pIconInfo As ICONINFO) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal hDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As Any, ByVal wUsage As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, lpBitsInfo As BITMAPINFOHEADER, ByVal wUsage As Long, lpBits As Long, ByVal Handle As Long, ByVal dw As Long) As Long
Private Declare Function AlphaBlend Lib "msimg32" (ByVal hDestDC As Long, ByVal lX As Long, ByVal lY As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal widthSrc As Long, ByVal heightSrc As Long, ByVal blendFunct As Long) As Boolean
Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (lpPictDesc As PICTDESC, riid As Any, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function CreateIconIndirect Lib "user32" (pIconInfo As ICONINFO) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Function SHCreateMemStream Lib "shlwapi" Alias "#12" (pInit As Any, ByVal cbInit As Long) As stdole.IUnknown
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal clrColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function UpdateLayeredWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal hdcDest As Long, ptDst As Any, pSize As Any, ByVal hdcSrc As Long, ptSrc As Any, ByVal crKey As Long, pBlend As Any, ByVal dwFlags As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As Any) As Long
Private Declare Function MapWindowPoints Lib "user32" (ByVal hWndFrom As Long, ByVal hWndTo As Long, lppt As Any, ByVal cPoints As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
'--- clipboard support
Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
'--- GDI+
Private Declare Function GdiplusStartup Lib "gdiplus" (hToken As Long, pInputBuf As Any, Optional ByVal pOutputBuf As Long = 0) As Long
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal lWidth As Long, ByVal lHeight As Long, ByVal lStride As Long, ByVal lPixelFormat As Long, ByVal Scan0 As Long, hBitmap As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal hImage As Long) As Long
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal hImage As Long, hGraphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal hGraphics As Long) As Long
Private Declare Function GdipDrawImageRectRect Lib "gdiplus" (ByVal hGraphics As Long, ByVal hImage As Long, ByVal dstX As Single, ByVal dstY As Single, ByVal dstWidth As Single, ByVal dstHeight As Single, ByVal srcX As Single, ByVal srcY As Single, ByVal srcWidth As Single, ByVal srcHeight As Single, Optional ByVal srcUnit As Long = UnitPixel, Optional ByVal hImageAttributes As Long, Optional ByVal pfnCallback As Long, Optional ByVal lCallbackData As Long) As Long
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hDC As Long, hGraphics As Long) As Long
Private Declare Function GdipCreateImageAttributes Lib "gdiplus" (hImgAttr As Long) As Long
Private Declare Function GdipSetImageAttributesColorMatrix Lib "gdiplus" (ByVal hImgAttr As Long, ByVal lAdjustType As Long, ByVal fAdjustEnabled As Long, clrMatrix As Any, grayMatrix As Any, ByVal lFlags As Long) As Long
Private Declare Function GdipSetImageAttributesColorKeys Lib "gdiplus" (ByVal hImgAttr As Long, ByVal lAdjustType As Long, ByVal fAdjustEnabled As Long, ByVal clrLow As Long, ByVal clrHigh As Long) As Long
Private Declare Function GdipDisposeImageAttributes Lib "gdiplus" (ByVal hImgAttr As Long) As Long
Private Declare Function GdipCloneBitmapAreaI Lib "gdiplus" (ByVal lX As Long, ByVal lY As Long, ByVal lWidth As Long, ByVal lHeight As Long, ByVal lPixelFormat As Long, ByVal srcBitmap As Long, dstBitmap As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hBmp As Long, ByVal hPal As Long, hBtmap As Long) As Long
Private Declare Function GdipCreateBitmapFromHICON Lib "gdiplus" (ByVal hIcon As Long, hBitmap As Long) As Long
Private Declare Function GdipGetImageDimension Lib "gdiplus" (ByVal hImage As Long, nWidth As Single, nHeight As Single) As Long '
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal sFileName As Long, mImage As Long) As Long
Private Declare Function GdipLoadImageFromStream Lib "gdiplus" (ByVal pStream As stdole.IUnknown, mImage As Long) As Long
Private Declare Function GdipTranslateWorldTransform Lib "gdiplus" (ByVal hGraphics As Long, ByVal nDx As Single, ByVal nDy As Single, ByVal lOrder As Long) As Long
Private Declare Function GdipScaleWorldTransform Lib "gdiplus" (ByVal hGraphics As Long, ByVal nSx As Single, ByVal nSy As Single, ByVal lOrder As Long) As Long
Private Declare Function GdipRotateWorldTransform Lib "gdiplus" (ByVal hGraphics As Long, ByVal nRotation As Single, ByVal lOrder As Long) As Long
Private Declare Function GdipSetInterpolationMode Lib "gdiplus" (ByVal hGraphics As Long, ByVal lMode As Long) As Long
Private Declare Function GdipBitmapLockBits Lib "gdiplus" (ByVal hBitmap As Long, lpRect As Any, ByVal lFlags As Long, ByVal lPixelFormat As Long, uLockedBitmapData As BitmapData) As Long
Private Declare Function GdipBitmapUnlockBits Lib "gdiplus" (ByVal hBitmap As Long, uLockedBitmapData As BitmapData) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal hBitmap As Long, hbmReturn As Long, ByVal clrBackground As Long) As Long
Private Declare Function GdipBitmapGetPixel Lib "gdiplus" (ByVal hBitmap As Long, ByVal lX As Long, ByVal lY As Long, clrPixel As Long) As Long
Private Declare Function GdipBitmapSetPixel Lib "gdiplus" (ByVal hBitmap As Long, ByVal lX As Long, ByVal lY As Long, ByVal clrPixel As Long) As Long
'--- WIC
Private Declare Function WICCreateImagingFactory_Proxy Lib "windowscodecs" (ByVal SDKVersion As Long, ppIImagingFactory As stdole.IUnknown) As Long
Private Declare Function IWICImagingFactory_CreateDecoderFromFilename_Proxy Lib "windowscodecs" (ByVal pFactory As stdole.IUnknown, ByVal wzFilename As Long, pguidVendor As Any, ByVal dwDesiredAccess As Long, ByVal lMetadataOptions As Long, ppIDecoder As stdole.IUnknown) As Long
Private Declare Function IWICImagingFactory_CreateDecoderFromStream_Proxy Lib "windowscodecs" (ByVal pFactory As stdole.IUnknown, ByVal pStream As stdole.IUnknown, pguidVendor As Any, ByVal lMetadataOptions As Long, ppIDecoder As stdole.IUnknown) As Long
Private Declare Function IWICImagingFactory_CreateFormatConverter_Proxy Lib "windowscodecs" (ByVal pFactory As stdole.IUnknown, ppIFormatConverter As stdole.IUnknown) As Long
Private Declare Function IWICImagingFactory_CreateBitmapScaler_Proxy Lib "windowscodecs" (ByVal pFactory As stdole.IUnknown, ppIBitmapScaler As stdole.IUnknown) As Long
Private Declare Function IWICBitmapDecoder_GetFrameCount_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, pCount As Long) As Long
Private Declare Function IWICBitmapDecoder_GetFrame_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, ByVal lIndex As Long, ppIBitmapFrame As stdole.IUnknown) As Long
Private Declare Function IWICBitmapScaler_Initialize_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, ByVal pISource As stdole.IUnknown, ByVal uiWidth As Long, ByVal uiHeight As Long, ByVal lMode As Long) As Long
Private Declare Function IWICBitmapSource_CopyPixels_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, prc As Any, ByVal cbStride As Long, ByVal cbBufferSize As Long, pbBuffer As Any) As Long
Private Declare Function IWICBitmapSource_GetSize_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, puiWidth As Long, puiHeight As Long) As Long
Private Declare Function IWICFormatConverter_Initialize_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, ByVal pISource As stdole.IUnknown, dstFormat As Any, ByVal lDither As Long, ByVal pIPalette As stdole.IUnknown, ByVal dblAlphaThresholdPercent As Double, ByVal lPaletteTranslate As Long) As Long
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type ICONINFO
fIcon As Long
xHotspot As Long
yHotspot As Long
hbmMask As Long
hbmColor As Long
End Type
Private Type PICTDESC
lSize As Long
lType As Long
hBmp As Long
hPal As Long
End Type
Private Type SAFEARRAY1D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
cElements As Long
lLbound As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type BitmapData
Width As Long
Height As Long
Stride As Long
PixelFormat As Long
Scan0 As Long
Reserved As Long
End Type
Private Type BITMAPV5HEADER
bV5Size As Long
bV5Width As Long
bV5Height As Long
bV5Planes As Integer
bV5BitCount As Integer
bV5Compression As Long
bV5SizeImage As Long
bV5XPelsPerMeter As Long
bV5YPelsPerMeter As Long
bV5ClrUsed As Long
bV5ClrImportant As Long
bV5RedMask As Long
bV5GreenMask As Long
bV5BlueMask As Long
bV5AlphaMask As Long
bV5CSType As Long
bV5EndpointsRedX As Long
bV5EndpointsRedY As Long
bV5EndpointsRedZ As Long
bV5EndpointsGreenX As Long
bV5EndpointsGreenY As Long
bV5EndpointsGreenZ As Long
bV5EndpointsBlueX As Long
bV5EndpointsBlueY As Long
bV5EndpointsBlueZ As Long
bV5GammaRed As Long
bV5GammaGreen As Long
bV5GammaBlue As Long
bV5Intent As Long
bV5ProfileData As Long
bV5ProfileSize As Long
bV5Reserved As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
'=========================================================================
' Constants and member variables
'=========================================================================
Private Const DEF_OPACITY As Single = 1
Private Const DEF_ROTATION As Single = 0
Private Const DEF_ZOOM As Single = 1
Private Const DEF_MASKCOLOR As Long = vbMagenta
Private Const DEF_AUTOREDRAW As Boolean = False
Private Const DEF_STRETCH As Boolean = False
Private m_oPicture As StdPicture
Private m_clrMask As OLE_COLOR
Private m_bAutoRedraw As Boolean
Private m_sngOpacity As Single
Private m_sngRotation As Single
Private m_sngZoom As Single
Private m_bStretch As Boolean
'--- run-time
Private m_eContainerScaleMode As ScaleModeConstants
Private m_bShown As Boolean
Private m_hAttributes As Long
Private m_hBitmap As Long
Private m_hPictureBitmap As Long
Private m_hPictureAttributes As Long
Private m_hRedrawDib As Long
Private m_nDownButton As Integer
Private m_nDownShift As Integer
Private m_sngDownX As Single
Private m_sngDownY As Single
Private m_pWicFactory As stdole.IUnknown
Private m_sLastError As String
Private Type UcsRgbQuad
R As Byte
G As Byte
B As Byte
A As Byte
End Type
'=========================================================================
' Error handling
'=========================================================================
Private Function PrintError(sFunction As String) As VbMsgBoxResult
m_sLastError = Err.Description
Debug.Print "Critical error: " & Err.Description & " [" & STR_MODULE_NAME & "." & sFunction & "]", Timer
End Function
'=========================================================================
' Properties
'=========================================================================
Property Get Picture() As StdPicture
Set Picture = m_oPicture
End Property
Property Set Picture(oValue As StdPicture)
If Not m_oPicture Is oValue Then
Set m_oPicture = oValue
pvPreparePicture m_oPicture, m_clrMask, m_hPictureBitmap, m_hPictureAttributes
If Not m_bStretch And TypeOf Extender Is VBControlExtender Then
pvSizeExtender m_hPictureBitmap, Extender
End If
pvRefresh
PropertyChanged
End If
End Property
Property Get MaskColor() As OLE_COLOR
MaskColor = m_clrMask
End Property
Property Let MaskColor(ByVal clrValue As OLE_COLOR)
If m_clrMask <> clrValue Then
m_clrMask = clrValue
pvPreparePicture m_oPicture, m_clrMask, m_hPictureBitmap, m_hPictureAttributes
pvRefresh
PropertyChanged
End If
End Property
Property Get AutoRedraw() As Boolean
AutoRedraw = m_bAutoRedraw
End Property
Property Let AutoRedraw(ByVal bValue As Boolean)
If m_bAutoRedraw <> bValue Then
m_bAutoRedraw = bValue
pvRefresh
PropertyChanged
End If
End Property
Property Get Opacity() As Single
Opacity = m_sngOpacity
End Property
Property Let Opacity(ByVal sngValue As Single)
If m_sngOpacity <> sngValue Then
m_sngOpacity = IIf(sngValue > 1, 1, IIf(sngValue < 0, 0, sngValue))
pvRefresh
PropertyChanged
End If
End Property
Property Get Rotation() As Single
Rotation = m_sngRotation
End Property
Property Let Rotation(ByVal sngValue As Single)
If m_sngRotation <> sngValue Then
m_sngRotation = sngValue
pvRefresh
PropertyChanged
End If
End Property
Property Get Zoom() As Single
Zoom = m_sngZoom
End Property
Property Let Zoom(ByVal sngValue As Single)
If m_sngZoom <> sngValue Then
m_sngZoom = sngValue
If Not m_bStretch And TypeOf Extender Is VBControlExtender Then
pvSizeExtender m_hPictureBitmap, Extender
End If
pvRefresh
PropertyChanged
End If
End Property
Property Get Stretch() As Boolean
Stretch = m_bStretch
End Property
Property Let Stretch(ByVal bValue As Boolean)
If m_bStretch <> bValue Then
m_bStretch = bValue
If Not m_bStretch And TypeOf Extender Is VBControlExtender Then
pvSizeExtender m_hPictureBitmap, Extender
End If
pvRefresh
PropertyChanged
End If
End Property
Property Get PixelARGB(ByVal lX As Long, ByVal lY As Long) As Long
If m_hBitmap = 0 Then
pvPrepareBitmap m_hBitmap
End If
Call GdipBitmapGetPixel(m_hBitmap, lX, lY, PixelARGB)
End Property
Property Let PixelARGB(ByVal lX As Long, ByVal lY As Long, ByVal clrValue As Long)
If m_hBitmap = 0 Then
pvPrepareBitmap m_hBitmap
End If
Call GdipBitmapSetPixel(m_hBitmap, lX, lY, clrValue)
End Property
Property Get LastError() As String
LastError = m_sLastError
End Property
'=========================================================================
' Methods
'=========================================================================
Public Sub Refresh()
Const FUNC_NAME As String = "Refresh"
Dim hMemDC As Long
Dim hPrevDib As Long
On Error GoTo EH
If m_hRedrawDib <> 0 Then
Call DeleteObject(m_hRedrawDib)
m_hRedrawDib = 0
End If
If AutoRedraw Then
hMemDC = CreateCompatibleDC(0)
If hMemDC = 0 Then
GoTo QH
End If
If Not pvCreateDib(hMemDC, ScaleWidth, ScaleHeight, m_hRedrawDib) Then
GoTo QH
End If
hPrevDib = SelectObject(hMemDC, m_hRedrawDib)
pvPaintControl hMemDC
End If
UserControl.Refresh
QH:
On Error Resume Next
If hMemDC <> 0 Then
Call SelectObject(hMemDC, hPrevDib)
Call DeleteDC(hMemDC)
hMemDC = 0
End If
Exit Sub
EH:
PrintError FUNC_NAME
Resume QH
End Sub
Public Sub Repaint()
Const FUNC_NAME As String = "Repaint"
On Error GoTo EH
If m_bShown Then
pvPrepareBitmap m_hBitmap
pvPrepareAttribs m_sngOpacity, m_hAttributes
Refresh
End If
QH:
Exit Sub
EH:
PrintError FUNC_NAME
Resume QH
End Sub
Public Function GdipLoadPicture(sFileName As String, Optional ByVal TargetWidth As Long, Optional ByVal TargetHeight As Long) As StdPicture
Const FUNC_NAME As String = "GdipLoadPicture"
Dim hBitmap As Long
On Error GoTo EH
If GdipLoadImageFromFile(StrPtr(sFileName), hBitmap) <> 0 Then
GoTo QH
End If
Set GdipLoadPicture = pvLoadPicture(hBitmap, Nothing, TargetWidth, TargetHeight)
QH:
Exit Function
EH:
PrintError FUNC_NAME
Resume QH
End Function
Public Function GdipLoadPictureArray(baBuffer() As Byte, Optional ByVal TargetWidth As Long, Optional ByVal TargetHeight As Long) As StdPicture
Const FUNC_NAME As String = "GdipLoadPictureArray"
Dim pStream As stdole.IUnknown
Dim hBitmap As Long
On Error GoTo EH
Set pStream = SHCreateMemStream(baBuffer(LBound(baBuffer)), UBound(baBuffer) - LBound(baBuffer) + 1)
If pStream Is Nothing Then
GoTo QH
End If
If GdipLoadImageFromStream(pStream, hBitmap) <> 0 Then
GoTo QH
End If
Set GdipLoadPictureArray = pvLoadPicture(hBitmap, Nothing, TargetWidth, TargetHeight)
QH:
Exit Function
EH:
PrintError FUNC_NAME
Resume QH
End Function
Public Function GdipSetClipboardDib(oPic As StdPicture) As Boolean
Const FUNC_NAME As String = "GdipSetClipboardDib"
Const SIGN_BIT As Long = &H80000000
Dim hPictureBitmap As Long
Dim hPictureAttributes As Long
Dim uData As BitmapData
Dim bNeedClipClose As Boolean
Dim uHdr As BITMAPINFOHEADER
Dim aColors(0 To 2) As Long
Dim lPtr As Long
Dim hMem As Long
On Error GoTo EH
If Not pvPreparePicture(oPic, MaskColor, hPictureBitmap, hPictureAttributes) Then
GoTo QH
End If
If GdipBitmapLockBits(hPictureBitmap, ByVal 0, ImageLockModeRead, PixelFormat32bppARGB, uData) <> 0 Then
GoTo QH
End If
uHdr.biSize = LenB(uHdr)
uHdr.biWidth = uData.Width
uHdr.biHeight = -uData.Height
uHdr.biPlanes = 1
uHdr.biBitCount = 32
uHdr.biCompression = BI_BITFIELDS
uHdr.biSizeImage = uData.Stride * uData.Height
aColors(0) = &HFF0000
aColors(1) = &HFF00&
aColors(2) = &HFF&
hMem = GlobalAlloc(GMEM_DDESHARE Or GMEM_MOVEABLE, LenB(uHdr) + 12 + uData.Stride * uData.Height)
If hMem = 0 Then
GoTo QH
End If
lPtr = GlobalLock(hMem)
If lPtr = 0 Then
GoTo QH
End If
Call CopyMemory(ByVal lPtr, uHdr, LenB(uHdr)): lPtr = (lPtr Xor SIGN_BIT) + LenB(uHdr) Xor SIGN_BIT
Call CopyMemory(ByVal lPtr, aColors(0), 12): lPtr = (lPtr Xor SIGN_BIT) + 12 Xor SIGN_BIT
Call CopyMemory(ByVal lPtr, ByVal uData.Scan0, uData.Stride * uData.Height)
Call GlobalUnlock(hMem)
'--- clip copy
If OpenClipboard(hWnd) = 0 Then
GoTo QH
End If
bNeedClipClose = True
If EmptyClipboard() = 0 Then
GoTo QH
End If
If SetClipboardData(vbCFDIB, hMem) = 0 Then
GoTo QH
End If
hMem = 0
'--- success
GdipSetClipboardDib = True
QH:
If bNeedClipClose Then
Call CloseClipboard
End If
If hMem <> 0 Then
Call GlobalFree(hMem)
End If
If uData.Scan0 <> 0 Then
Call GdipBitmapUnlockBits(hPictureBitmap, uData)
End If
If hPictureBitmap <> 0 Then
Call GdipDisposeImage(hPictureBitmap)
End If
If hPictureAttributes <> 0 Then
Call GdipDisposeImageAttributes(hPictureAttributes)
End If
Exit Function
EH:
PrintError FUNC_NAME
Resume QH
End Function
Public Function GdipSetClipboardDibV5(oPic As StdPicture) As Boolean
Const FUNC_NAME As String = "GdipSetClipboardDibV5"
Const SIGN_BIT As Long = &H80000000
Dim hPictureBitmap As Long
Dim hPictureAttributes As Long
Dim uData As BitmapData
Dim bNeedClipClose As Boolean
Dim uHdr As BITMAPV5HEADER
Dim lPtr As Long
Dim hMem As Long
On Error GoTo EH
If Not pvPreparePicture(oPic, MaskColor, hPictureBitmap, hPictureAttributes) Then
GoTo QH
End If
If GdipBitmapLockBits(hPictureBitmap, ByVal 0, ImageLockModeRead, PixelFormat32bppARGB, uData) <> 0 Then
GoTo QH
End If
uHdr.bV5Size = LenB(uHdr)
uHdr.bV5Width = uData.Width
uHdr.bV5Height = -uData.Height
uHdr.bV5Planes = 1
uHdr.bV5BitCount = 32
uHdr.bV5Compression = BI_BITFIELDS
uHdr.bV5SizeImage = uData.Stride * uData.Height
uHdr.bV5RedMask = &HFF0000
uHdr.bV5GreenMask = &HFF00&
uHdr.bV5BlueMask = &HFF&
uHdr.bV5AlphaMask = &HFF000000
hMem = GlobalAlloc(GMEM_DDESHARE Or GMEM_MOVEABLE, LenB(uHdr) + uData.Stride * uData.Height)
If hMem = 0 Then
GoTo QH
End If
lPtr = GlobalLock(hMem)
If lPtr = 0 Then
GoTo QH
End If
Call CopyMemory(ByVal lPtr, uHdr, LenB(uHdr)): lPtr = (lPtr Xor SIGN_BIT) + LenB(uHdr) Xor SIGN_BIT
Call CopyMemory(ByVal lPtr, ByVal uData.Scan0, uData.Stride * uData.Height)
Call GlobalUnlock(hMem)
'--- clip copy
If OpenClipboard(hWnd) = 0 Then
GoTo QH
End If
bNeedClipClose = True
If EmptyClipboard() = 0 Then
GoTo QH
End If
If SetClipboardData(CF_DIBV5, hMem) = 0 Then
GoTo QH
End If
hMem = 0
'--- success
GdipSetClipboardDibV5 = True
QH:
If bNeedClipClose Then
Call CloseClipboard
End If
If hMem <> 0 Then
Call GlobalFree(hMem)
End If
If uData.Scan0 <> 0 Then
Call GdipBitmapUnlockBits(hPictureBitmap, uData)
End If
If hPictureBitmap <> 0 Then
Call GdipDisposeImage(hPictureBitmap)
End If
If hPictureAttributes <> 0 Then
Call GdipDisposeImageAttributes(hPictureAttributes)
End If
Exit Function
EH:
PrintError FUNC_NAME
Resume QH
End Function
Public Function GdipUpdateLayeredWindow(ByVal hWnd As Long) As Boolean
Const FUNC_NAME As String = "GdipUpdateLayeredWindow"
Dim lStyle As Long
Dim hScreenDC As Long
Dim hMemDC As Long
Dim hBmp As Long
Dim hPrevBmp As Long
Dim uRect(0 To 1) As POINTAPI
Dim ptSrc As POINTAPI
On Error GoTo EH
lStyle = GetWindowLong(hWnd, GWL_EXSTYLE)
If (lStyle And WS_EX_LAYERED) = 0 Then
Call SetWindowLong(hWnd, GWL_EXSTYLE, lStyle Or WS_EX_LAYERED)
End If
hScreenDC = GetDC(0)
If hScreenDC = 0 Then
GoTo QH
End If
hMemDC = CreateCompatibleDC(hScreenDC)
If hMemDC = 0 Then
GoTo QH
End If
If GdipCreateHBITMAPFromBitmap(m_hBitmap, hBmp, 0) <> 0 Then
GoTo QH
End If
hPrevBmp = SelectObject(hMemDC, hBmp)
If hPrevBmp = 0 Then
GoTo QH
End If
Call GetClientRect(hWnd, uRect(0))
Call MapWindowPoints(hWnd, GetParent(hWnd), uRect(0), 2)
With uRect(1)
.X = .X - uRect(0).X
.Y = .Y - uRect(0).Y
End With
Call UpdateLayeredWindow(hWnd, hScreenDC, uRect(0), uRect(1), hMemDC, ptSrc, 0, _
AC_SRC_ALPHA * &H1000000 + CByte(255 * m_sngOpacity) * &H10000 + AC_SRC_OVER, ULW_ALPHA)
'--- success
GdipUpdateLayeredWindow = True
QH:
If hBmp <> 0 Then
If hPrevBmp <> 0 Then
Call SelectObject(hMemDC, hPrevBmp)
End If
Call DeleteObject(hBmp)
End If
If hMemDC <> 0 Then
Call DeleteDC(hMemDC)
End If
If hScreenDC <> 0 Then
Call ReleaseDC(0, hScreenDC)
End If
Exit Function
EH:
PrintError FUNC_NAME
Resume QH
End Function
Public Function WicLoadPicture( _
sFileName As String, _
Optional ByVal TargetWidth As Long, _
Optional ByVal TargetHeight As Long, _
Optional ByVal ImageFrame As Long) As StdPicture
Const FUNC_NAME As String = "WicLoadPicture"
Dim pDecoder As stdole.IUnknown
Dim lFameCount As Long
Dim pFrame As stdole.IUnknown
On Error GoTo EH
If m_pWicFactory Is Nothing Then
If WICCreateImagingFactory_Proxy(WINCODEC_SDK_VERSION2, m_pWicFactory) < 0 Then
If pvCheckHResult(WICCreateImagingFactory_Proxy(WINCODEC_SDK_VERSION1, m_pWicFactory)) < 0 Then
GoTo QH
End If
End If
End If
If pvCheckHResult(IWICImagingFactory_CreateDecoderFromFilename_Proxy(m_pWicFactory, StrPtr(sFileName), ByVal 0, GENERIC_READ, 0, pDecoder)) < 0 Or pDecoder Is Nothing Then
GoTo QH
End If
If pvCheckHResult(IWICBitmapDecoder_GetFrameCount_Proxy(pDecoder, lFameCount)) < 0 Or ImageFrame >= lFameCount Then
GoTo QH
End If
If pvCheckHResult(IWICBitmapDecoder_GetFrame_Proxy(pDecoder, ImageFrame, pFrame)) < 0 Or pFrame Is Nothing Then
GoTo QH
End If
Set WicLoadPicture = pvLoadPicture(0, pFrame, TargetWidth, TargetHeight)
QH:
Exit Function
EH:
PrintError FUNC_NAME
Resume QH
End Function
Public Function WicLoadPictureArray( _
baBuffer() As Byte, _
Optional ByVal TargetWidth As Long, _
Optional ByVal TargetHeight As Long, _
Optional ByVal ImageFrame As Long) As StdPicture
Const FUNC_NAME As String = "WicLoadPictureArray"
Dim pStream As stdole.IUnknown
Dim pDecoder As stdole.IUnknown
Dim lFameCount As Long
Dim pFrame As stdole.IUnknown
On Error GoTo EH
If m_pWicFactory Is Nothing Then
If WICCreateImagingFactory_Proxy(WINCODEC_SDK_VERSION2, m_pWicFactory) < 0 Then
If pvCheckHResult(WICCreateImagingFactory_Proxy(WINCODEC_SDK_VERSION1, m_pWicFactory)) < 0 Then
GoTo QH
End If
End If
End If
Set pStream = SHCreateMemStream(baBuffer(LBound(baBuffer)), UBound(baBuffer) - LBound(baBuffer) + 1)
If pStream Is Nothing Then
GoTo QH
End If
If pvCheckHResult(IWICImagingFactory_CreateDecoderFromStream_Proxy(m_pWicFactory, pStream, ByVal 0, 0, pDecoder)) < 0 Or pDecoder Is Nothing Then
GoTo QH
End If
If pvCheckHResult(IWICBitmapDecoder_GetFrameCount_Proxy(pDecoder, lFameCount)) < 0 Or ImageFrame >= lFameCount Then
GoTo QH
End If
If pvCheckHResult(IWICBitmapDecoder_GetFrame_Proxy(pDecoder, ImageFrame, pFrame)) < 0 Or pFrame Is Nothing Then
GoTo QH
End If
Set WicLoadPictureArray = pvLoadPicture(0, pFrame, TargetWidth, TargetHeight)
QH:
Exit Function
EH:
PrintError FUNC_NAME
Resume QH
End Function
'= private ===============================================================
Private Function pvLoadPicture( _
ByVal hBitmap As Long, _
pFrame As stdole.IUnknown, _
ByVal sngTargetWidth As Single, _
ByVal sngTargetHeight As Single) As StdPicture
Const FUNC_NAME As String = "pvLoadPicture"
Const EPSILON As Single = 0.0001
Dim sngWidth As Single
Dim sngHeight As Single
Dim lWidth As Long
Dim lHeight As Long
Dim hMemDC As Long
Dim hDib As Long
Dim hPrevDib As Long
Dim hGraphics As Long
Dim uInfo As ICONINFO
Dim hIcon As Long
Dim uDesc As PICTDESC
Dim aGUID(0 To 3) As Long
Dim pConverter As stdole.IUnknown
Dim pScaler As stdole.IUnknown
Dim lpBits As Long
On Error GoTo EH
If hBitmap <> 0 Then
If GdipGetImageDimension(hBitmap, sngWidth, sngHeight) <> 0 Then
GoTo QH
End If
Else
If pvCheckHResult(IWICBitmapSource_GetSize_Proxy(pFrame, lWidth, lHeight)) < 0 Then
GoTo QH
End If
sngWidth = lWidth
sngHeight = lHeight
End If
hMemDC = CreateCompatibleDC(0)
If hMemDC = 0 Then
GoTo QH
End If
If Abs(sngTargetWidth) < EPSILON Then
sngTargetWidth = sngWidth
End If
If Abs(sngTargetHeight) < EPSILON Then
sngTargetHeight = sngHeight
End If
If Not pvCreateDib(hMemDC, sngTargetWidth, sngTargetHeight, hDib, lpBits) Then
GoTo QH
End If
If hBitmap <> 0 Then
hPrevDib = SelectObject(hMemDC, hDib)
If GdipCreateFromHDC(hMemDC, hGraphics) <> 0 Then
GoTo QH
End If
If GdipDrawImageRectRect(hGraphics, hBitmap, 0, 0, sngWidth, sngHeight, 0, 0, sngTargetWidth, sngTargetHeight) <> 0 Then
GoTo QH
End If
Call SelectObject(hMemDC, hPrevDib)
hPrevDib = 0
Else
If pvCheckHResult(IWICImagingFactory_CreateFormatConverter_Proxy(m_pWicFactory, pConverter)) < 0 Or pConverter Is Nothing Then
GoTo QH
End If
'--- GUID_WICPixelFormat32bppPBGRA
aGUID(0) = &H6FDDC324
aGUID(1) = &H4BFE4E03
aGUID(2) = &H773D85B1
aGUID(3) = &H10C98D76
If pvCheckHResult(IWICFormatConverter_Initialize_Proxy(pConverter, pFrame, aGUID(0), 0, Nothing, 0#, 0)) < 0 Then
GoTo QH
End If
If Abs(sngWidth - sngTargetWidth) > EPSILON Or Abs(sngHeight - sngTargetHeight) > EPSILON Then
If pvCheckHResult(IWICImagingFactory_CreateBitmapScaler_Proxy(m_pWicFactory, pScaler)) < 0 Then
GoTo QH
End If
If IWICBitmapScaler_Initialize_Proxy(pScaler, pConverter, sngTargetWidth, sngTargetHeight, WICBitmapInterpolationModeHighQualityCubic) < 0 Then
If pvCheckHResult(IWICBitmapScaler_Initialize_Proxy(pScaler, pConverter, sngTargetWidth, sngTargetHeight, WICBitmapInterpolationModeFant)) < 0 Then
GoTo QH
End If
End If
Else
Set pScaler = pConverter
End If
If pvCheckHResult(IWICBitmapSource_CopyPixels_Proxy(pScaler, ByVal 0&, sngTargetWidth * 4, sngTargetWidth * sngTargetHeight * 4, ByVal lpBits)) < 0 Then
GoTo QH
End If
End If
With uInfo
.fIcon = 1
.hbmColor = hDib
.hbmMask = CreateBitmap(sngTargetWidth, sngTargetHeight, 1, 1, ByVal 0)
End With
hIcon = CreateIconIndirect(uInfo)
With uDesc
.lSize = Len(uDesc)
.lType = vbPicTypeIcon
.hBmp = hIcon
End With
'--- IID_IPicture
aGUID(0) = &H7BF80980
aGUID(1) = &H101ABF32
aGUID(2) = &HAA00BB8B
aGUID(3) = &HAB0C3000
If OleCreatePictureIndirect(uDesc, aGUID(0), 1, pvLoadPicture) <> 0 Then
GoTo QH
End If
hIcon = 0
QH:
If hBitmap <> 0 Then
Call GdipDisposeImage(hBitmap)
hBitmap = 0
End If
If hMemDC <> 0 Then
If hPrevDib <> 0 Then
Call SelectObject(hMemDC, hPrevDib)
End If
Call DeleteDC(hMemDC)
hMemDC = 0
End If
If hDib <> 0 Then
Call DeleteObject(hDib)
hDib = 0
End If
If hGraphics <> 0 Then
Call GdipDeleteGraphics(hGraphics)
hGraphics = 0
End If
If hIcon <> 0 Then
Call DestroyIcon(hIcon)
hIcon = 0
End If
If uInfo.hbmMask <> 0 Then
Call DeleteObject(uInfo.hbmMask)
uInfo.hbmMask = 0
End If
Exit Function
EH:
PrintError FUNC_NAME
Resume QH
End Function
Private Sub pvRefresh()
m_bShown = False
If m_hRedrawDib <> 0 Then
Call DeleteObject(m_hRedrawDib)
m_hRedrawDib = 0
End If
UserControl.Refresh
End Sub
Private Function pvPaintControl(ByVal hDC As Long) As Boolean
Const FUNC_NAME As String = "pvPaintControl"
Dim hGraphics As Long
On Error GoTo EH
If Not m_bShown Then
m_bShown = True
pvPrepareBitmap m_hBitmap
pvPrepareAttribs m_sngOpacity, m_hAttributes
End If
If m_hBitmap <> 0 Then
If GdipCreateFromHDC(hDC, hGraphics) <> 0 Then
GoTo QH
End If
If GdipDrawImageRectRect(hGraphics, m_hBitmap, 0, 0, ScaleWidth, ScaleHeight, 0, 0, ScaleWidth, ScaleHeight, , m_hAttributes) <> 0 Then
GoTo QH
End If
'--- success
pvPaintControl = True
End If
QH:
On Error Resume Next
If hGraphics <> 0 Then
Call GdipDeleteGraphics(hGraphics)
hGraphics = 0
End If
Exit Function
EH:
PrintError FUNC_NAME
Resume QH
End Function
Private Function pvPrepareBitmap(hBitmap As Long) As Boolean
Const FUNC_NAME As String = "pvPrepareBitmap"
Const EPSILON As Single = 0.0001
Dim hGraphics As Long
Dim hNewBitmap As Long
Dim lLeft As Long
Dim lTop As Long
Dim lWidth As Long
Dim lHeight As Long
Dim sngPicWidth As Single
Dim sngPicHeight As Single
Dim sngZoom As Single
On Error GoTo EH
If GdipCreateBitmapFromScan0(ScaleWidth, ScaleHeight, ScaleWidth * 4, PixelFormat32bppPARGB, 0, hNewBitmap) <> 0 Then
GoTo QH
End If