-
Notifications
You must be signed in to change notification settings - Fork 2
Expand file tree
/
Copy pathclsMenu.cls
More file actions
1064 lines (973 loc) · 41.3 KB
/
clsMenu.cls
File metadata and controls
1064 lines (973 loc) · 41.3 KB
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
Option Explicit
' ------------------------------------------------------- Menu API -------------------------------------------------------------------
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal hwnd As Long, ByVal lptpm As Any) As Long
Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" (ByVal lpszFile As String, ByVal nIconIndex As Long, phiconLarge As Long, phiconSmall As Long, ByVal nIcons As Long) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Public Enum MenuType
Standard = &H0&
Checked = &H8&
Disabled = &H2&
GRAYED = &H1&
Separator = &H800&
POPUP = &H10&
SubMenuBegin
SubMenuEnd
End Enum
Const MF_CHECKED = &H8&
Const MF_APPEND = &H100&
Const TPM_LEFTALIGN = &H0&
Const MF_DISABLED = &H2&
Const MF_GRAYED = &H1&
Const MF_SEPARATOR = &H800&
Const MF_STRING = &H0&
Const MF_POPUP = &H10&
Const TPM_RETURNCMD = &H100&
Const TPM_RIGHTBUTTON = &H2&
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32.dll" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function VirtualAlloc Lib "kernel32.dll" (ByRef lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualFree Lib "kernel32.dll" (ByRef lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32.dll" (ByVal hdc As Long, ByRef pBitmapInfo As BITMAPINFO, ByVal un As Long, ByRef lplpVoid As Long, ByVal Handle As Long, ByVal dw As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal dwImageType As Long, ByVal dwDesiredWidth As Long, ByVal dwDesiredHeight As Long, ByVal dwFlags As Long) As Long
Private Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, ByRef piconinfo As ICONINFO) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Sub CreateStreamOnHGlobal Lib "ole32.dll" (ByRef hGlobal As Any, ByVal fDeleteOnRelease As Long, ByRef ppstm As Any)
Private Declare Function GetObjectType Lib "gdi32.dll" (ByVal hgdiobj As Long) As Long
Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal uItem As Long, ByVal fByPosition As Long, lpmii As MENUITEMINFO) As Long
Private Declare Function GetMenuItemInfo Lib "user32.dll" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal B As Boolean, ByRef lpMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetMenuInfo Lib "user32.dll" (ByVal hMenu As Long, ByRef LPMENUINFO As MENUINFO) As Long
Private Declare Function SetMenuInfo Lib "user32.dll" (ByVal hMenu As Long, ByRef LPCMENUINFO As MENUINFO) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetMenuItemID Lib "user32.dll" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private 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
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function Rectangle Lib "gdi32.dll" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function GetStockObject Lib "gdi32.dll" (ByVal nIndex As Long) As Long
Private Declare Function GetSysColor Lib "user32.dll" (ByVal nIndex As Long) As Long
Private Declare Function GetVersionEx Lib "Kernel32" Alias "GetVersionExA" (LpVersionInformation As OSVERSIONINFO) As Long
' ------------------------------------------------------- GDI Plus -------------------------------------------------------------------
Private Declare Function GdipDrawImageRectRectI Lib "gdiplus" (ByVal hGraphics As Long, ByVal hImage As Long, ByVal dstX As Long, ByVal dstY As Long, ByVal dstWidth As Long, ByVal dstHeight As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal SrcWidth As Long, ByVal SrcHeight As Long, ByVal srcUnit As Long, Optional ByVal imageAttributes As Long = 0, Optional ByVal CallBack As Long = 0, Optional ByVal CallbackData As Long = 0) As Long
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, ByRef Graphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal Graphics As Long) As Long
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal FileName As Long, ByRef Image As Long) As Long
Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, Optional ByRef lpOutput As Any) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
Private Declare Function GdipGetImageDimension Lib "gdiplus" (ByVal Image As Long, ByRef Width As Single, ByRef Height As Single) As Long
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal Stride As Long, ByVal PixelFormat As Long, Scan0 As Any, BITMAP As Long) As Long
Private Declare Function GdipImageRotateFlip Lib "gdiplus" (ByVal Image As Long, ByVal rfType As Long) As Long
Private Declare Function GdipCreateBitmapFromHICON Lib "GdiPlus.dll" (ByVal mHicon As Long, ByRef mBitmap As Long) As Long
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal Image As Long, ByRef Graphics As Long) As Long
Private Declare Function GdipGetImagePixelFormat Lib "gdiplus" (ByVal Image As Long, ByRef PixelFormat As Long) As Long
Private Declare Function GdipBitmapLockBits Lib "gdiplus" (ByVal BITMAP As Long, ByRef RECT As RECT, ByVal Flags As ImageLockMode, ByVal PixelFormat As Long, ByRef LockedBitmapData As BitmapData) As Long
Private Declare Function GdipBitmapUnlockBits Lib "gdiplus" (ByVal BITMAP As Long, ByRef LockedBitmapData As BitmapData) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hBmp As Long, ByVal hPal As Long, ByRef BITMAP As Long) As Long
Private Declare Function GdipLoadImageFromStream Lib "gdiplus" (ByVal Stream As Any, ByRef Image As Long) As Long
Private Declare Function GdipSetImageAttributesColorMatrix Lib "gdiplus" (ByVal imageattr As Long, ByVal ColorAdjust As Long, ByVal EnableFlag As Boolean, ByRef MatrixColor As COLORMATRIX, MatrixGray As Any, ByVal Flags As Long) As Long
Private Declare Function GdipCreateImageAttributes Lib "gdiplus" (ByRef imageattr As Long) As Long
Private Declare Function GdipDisposeImageAttributes Lib "gdiplus" (ByVal imageattr As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type MENUINFO
cbSize As Long
fMask As Long
dwStyle As Long
cyMax As Long
RhbrBack As Long
dwContextHelpID As Long
dwMenuData As Long
End Type
Private Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As Long
cch As Long
hbmpItem As Long
End Type
Private Type MEASUREITEMSTRUCT
CtlType As Long
CtlID As Long
itemID As Long
itemWidth As Long
itemHeight As Long
ItemData As Long
End Type
Private Type DRAWITEMSTRUCT
CtlType As Long
CtlID As Long
itemID As Long
itemAction As Long
ItemState As Long
hwndItem As Long
hdc As Long
rcItem As RECT
ItemData 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 IconHeader
ihReserved As Integer
ihType As Integer
ihCount As Integer
End Type
Private Type IconEntry
ieWidth As Byte
ieHeight As Byte
ieColorCount As Byte
ieReserved As Byte
iePlanes As Integer
ieBitCount As Integer
ieBytesInRes As Long
ieImageOffset As Long
End Type
Private Type ARGB
Blue As Byte
Green As Byte
Red As Byte
Alpha As Byte
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 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 BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As ARGB
End Type
Private Type GDIPlusStartupInput
GdiPlusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type COLORMATRIX
m(0 To 4, 0 To 4) As Single
End Type
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Type MemoDIB
hdc As Long
hDIB As Long
Ptr As Long
End Type
Private Enum ImageLockMode
ImageLockModeRead = &H1
ImageLockModeWrite = &H2
ImageLockModeUserInputBuf = &H4
End Enum
Private Enum ColorAdjustType
ColorAdjustTypeDefault = 0
ColorAdjustTypeBitmap = 1
ColorAdjustTypeBrush = 2
ColorAdjustTypePen = 3
ColorAdjustTypeText = 4
ColorAdjustTypeCount = 5
ColorAdjustTypeAny = 6
End Enum
Private Enum ColorMatrixFlags
ColorMatrixFlagsDefault = 0
ColorMatrixFlagsSkipGrays = 1
ColorMatrixFlagsAltGray = 2
End Enum
Private Const PixelFormat32bppARGB As Long = &H26200A
Private Const PixelFormat32bppRGB As Long = &H22009
Private Const GdiPlusVersion As Long = 1&
Private Const IconVersion As Long = &H30000
Private Const BI_RGB As Long = 0&
Private Const DIB_RGB_COLORS As Long = 0&
Private Const LR_LOADFROMFILE As Long = &H10
Private Const LR_LOADMAP3DCOLORS As Long = &H1000
Private Const LR_SHARED As Long = &H8000&
Private Const IMAGE_ICON As Long = 1
Private Const MIIM_STATE As Long = &H1
Private Const MIIM_ID As Long = &H2
Private Const MIIM_SUBMENU As Long = &H4
Private Const MIIM_CHECKMARKS As Long = &H8
Private Const MIIM_TYPE As Long = &H10
Private Const MIIM_DATA As Long = &H20
Private Const MIIM_BITMAP As Long = &H80
Private Const MIM_STYLE As Long = &H10
Private Const ODT_MENU As Long = 1
Private Const ODS_GRAYED As Long = &H2
Private Const ODS_CHECKED As Long = &H8
Private Const MNS_NOCHECK As Long = &H80000000
Private Const HBMMENU_CALLBACK As Long = -1
Private Const NULL_BRUSH As Long = 5
Private Const COLOR_GRAYTEXT As Long = 17
Private Const COLOR_APPWORKSPACE As Long = 12
Private Const SM_CXMENUCHECK As Long = 71
Private Const WM_DESTROY As Long = &H2
Private Const WM_MEASUREITEM As Long = &H2C
Private Const WM_DRAWITEM As Long = &H2B
Private Const WM_MENUSELECT As Long = &H11F
Private Const WM_ENTERIDLE As Long = &H121
Private Const WM_CONTEXTMENU As Long = &H7B
Private Const WM_ENTERMENULOOP As Long = &H211
Private Const WM_EXITMENULOOP As Long = &H212
Private Const WM_INITMENU As Long = &H116
Private Const WM_INITMENUPOPUP As Long = &H117
Private Const WM_MDIREFRESHMENU As Long = &H234
Private Const WM_MDISETMENU As Long = &H230
Private Const WM_MENUCHAR As Long = &H120
Private Const WM_MENUCOMMAND As Long = &H126
Private Const WM_MENUDRAG As Long = &H123
Private Const WM_MENUGETOBJECT As Long = &H124
Private Const WM_MENURBUTTONUP As Long = &H122
Private Const WM_NEXTMENU As Long = &H213
Private Const WM_UNINITMENUPOPUP As Long = &H125
Private Const GWL_WNDPROC As Long = -4
Private Const MEM_COMMIT As Long = &H1000
Private Const PAGE_EXECUTE_READWRITE As Long = &H40
Private Const MEM_RELEASE As Long = &H8000&
Public Event MenuMessages(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
Private pASMWrapper As Long
Private PrevWndProc As Long
Private m_hwnd As Long
Private GdipToken As Long
Private m_lWidth As Long
Private m_lHeight As Long
Private mDIB() As MemoDIB
Private IsWinVistaOrLater As Boolean
Private cColl As Collection
Private iHWnd As Long
Private ilhMenu As Long
Private hMenuHis() As String
Private hMenuHisC() As String
Public Property Get hwnd() As Long: hwnd = iHWnd: End Property
Public Property Let hwnd(ByVal FormHWnd As Long): iHWnd = FormHWnd: End Property
Public Property Get lhMenu() As Long: lhMenu = ilhMenu: End Property
Public Property Let lhMenu(ByVal hMenu As Long): ilhMenu = hMenu: End Property
Public Property Get ItemsCount(ByVal hMenu As Long) As Long
If IsMenusInitialized Then
Dim i As Long
For i = 0 To UBound(hMenuHis) Step 1
If hMenuHis(i) = hMenu Then
ItemsCount = hMenuHisC(i)
Exit For
End If
Next i
End If
End Property
Private Function IsMenusInitialized() As Boolean
On Error GoTo Die
Dim i As Integer
i = UBound(hMenuHis)
Die:
If Err.Number = 0 Then IsMenusInitialized = True
End Function
Public Function Create() As Long
If Not IsMenusInitialized Then
ReDim hMenuHis(0)
ReDim hMenuHisC(0)
Else
ReDim Preserve hMenuHis(UBound(hMenuHis) + 1)
ReDim Preserve hMenuHisC(UBound(hMenuHis))
End If
ilhMenu = CreatePopupMenu
hMenuHis(UBound(hMenuHis)) = ilhMenu
hMenuHisC(UBound(hMenuHis)) = 0
Create = CLng(ilhMenu)
End Function
Public Sub Destroy(Optional ByVal hMenu As Long = -1)
Dim i As Long
If hMenu = -1 Then
If Not IsMenusInitialized Then Exit Sub
For i = 0 To UBound(hMenuHis) Step 1
If hMenuHis(i) <> 0 Then DestroyMenu hMenuHis(i)
Next i
Erase hMenuHis
Else
DestroyMenu hMenu
If Not IsMenusInitialized Then Exit Sub
For i = 0 To UBound(hMenuHis) Step 1
If hMenuHis(i) = hMenu Then
hMenuHis(i) = 0
Exit For
End If
Next i
End If
End Sub
Public Function Append(Optional ByVal wFlags As MenuType = Standard, Optional ByVal Index As Long = -1, Optional ByVal Text As String = "", Optional hMenu As Variant = -1) As Long
If hMenu = -1 Then hMenu = ilhMenu
hMenu = CLng(hMenu)
Index = CLng(Index)
Select Case wFlags
Case Standard: Call AppendMenu(hMenu, MF_STRING, Index, Text)
Case Checked: AppendMenu hMenu, MF_CHECKED, Index, Text
Case Disabled: AppendMenu hMenu, MF_DISABLED, Index, Text
Case GRAYED: AppendMenu hMenu, MF_GRAYED, Index, Text
Case Separator: AppendMenu hMenu, MF_SEPARATOR, -1, ByVal 0&
Case POPUP: AppendMenu hMenu, MF_POPUP, Index, Text
End Select
Dim i As Long
For i = 0 To UBound(hMenuHis) Step 1
If hMenuHis(i) = hMenu Then
hMenuHisC(i) = hMenuHisC(i) + 1
Append = (hMenuHisC(i) - 1)
Exit For
End If
Next i
End Function
Public Function Display(Optional ByVal hMenu As Long = -1)
If hMenu = -1 Then hMenu = ilhMenu
Dim pt As POINTAPI
GetCursorPos pt
Display = TrackPopupMenuEx(hMenu, TPM_LEFTALIGN Or TPM_RETURNCMD Or TPM_RIGHTBUTTON, pt.X, pt.Y, iHWnd, ByVal 0&)
End Function
Public Function AddIconFromRes(ByVal Path As String, Optional ByVal Index As Long = 0, Optional hMenu As Variant = 0, Optional MenuIndex As Long = -1) As Long
AddIconFromRes = -1
Dim hIcon As Long
ExtractIconEx Path, Index, ByVal 0&, hIcon, 1
If Me.AddIconFromHandle(hIcon) Then
AddIconFromRes = UBound(mDIB) - 1
If hMenu <> 0 And MenuIndex <> -1 Then Me.PutImageToApiMenu (UBound(mDIB) - 1), hMenu, MenuIndex
End If
DestroyIcon hIcon
End Function
Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error Resume Next
Select Case uMsg
Case WM_MENUSELECT, WM_ENTERIDLE
RaiseEvent MenuMessages(hwnd, uMsg, wParam, lParam)
WindowProc = CallWindowProc(PrevWndProc, hwnd, uMsg, wParam, lParam)
Case WM_MEASUREITEM
Dim MIS As MEASUREITEMSTRUCT
CopyMemory MIS, ByVal lParam, Len(MIS)
If MIS.CtlType = ODT_MENU Then
If MIS.itemHeight < m_lHeight + 4 Then
MIS.itemHeight = m_lHeight + 4
End If
MIS.itemWidth = MIS.itemWidth + m_lWidth + 4
CopyMemory ByVal lParam, MIS, Len(MIS)
WindowProc = 1
Else
WindowProc = CallWindowProc(PrevWndProc, hwnd, uMsg, wParam, lParam)
End If
Case WM_DRAWITEM
Dim DIS As DRAWITEMSTRUCT
Dim IsDisabled As Boolean
Dim IsCheckStyle As Boolean
Dim IsChecked As Boolean
Dim lLeft As Long
Dim MI As MENUINFO
CopyMemory DIS, ByVal lParam, Len(DIS)
If DIS.CtlType = ODT_MENU Then
If DIS.hwndItem <> GetMenu(hwnd) Then
With MI
.cbSize = Len(MI)
.fMask = MIM_STYLE
End With
GetMenuInfo DIS.hwndItem, MI
IsCheckStyle = (MI.dwStyle And MNS_NOCHECK) <> MNS_NOCHECK
IsChecked = (DIS.ItemState And ODS_CHECKED) = ODS_CHECKED
lLeft = IIf(IsCheckStyle, GetSystemMetrics(SM_CXMENUCHECK), 0)
End If
IsDisabled = (DIS.ItemState And ODS_GRAYED) = ODS_GRAYED
If Not IsCheckStyle And IsChecked Then
Call DrawCheck(DIS.hdc, lLeft, DIS.rcItem.Top, m_lWidth + 4, m_lHeight + 4, IsDisabled)
End If
DrawDIB DIS.hdc, lLeft + 2, DIS.rcItem.Top + 2, cColl(DIS.hwndItem & "-" & DIS.itemID), IsDisabled
WindowProc = 1
Else
WindowProc = CallWindowProc(PrevWndProc, hwnd, uMsg, wParam, lParam)
End If
Case WM_DESTROY
WindowProc = CallWindowProc(PrevWndProc, hwnd, uMsg, wParam, lParam)
Call StopSubclassing
Case Else
WindowProc = CallWindowProc(PrevWndProc, hwnd, uMsg, wParam, lParam)
End Select
End Function
Public Property Get IsWindowVistaOrLater() As Boolean
IsWindowVistaOrLater = IsWinVistaOrLater
End Property
Public Property Get ImageCount() As Long
ImageCount = UBound(mDIB) - 1
End Property
Public Function RemoveImage(ByVal Index As Long) As Boolean
Dim i As Long
If Index < 0 Or Index > Me.ImageCount Then Exit Function
With mDIB(Index)
Call DeleteObject(.hDIB)
Call DeleteDC(.hdc)
End With
For i = Index To Me.ImageCount
mDIB(i) = mDIB(i + 1)
Next
ReDim Preserve mDIB(Me.ImageCount)
RemoveImage = True
End Function
Public Function PutImageToVBMenu(ByVal ImageID As Long, ByVal MenuPos As Long, ParamArray vSubMenuPos() As Variant) As Boolean
On Error Resume Next
Dim hMenu As Long
Dim hSubMenu As Long
Dim MII As MENUITEMINFO
Dim v As Variant
Dim sKey As String
hMenu = GetMenu(m_hwnd)
hSubMenu = hMenu
For Each v In vSubMenuPos
hSubMenu = GetSubMenu(hSubMenu, v)
Next
With MII
.cbSize = Len(MII)
.fMask = MIIM_ID
End With
If GetMenuItemInfo(hSubMenu, MenuPos, True, MII) = 0 Then Exit Function
sKey = hSubMenu & "-" & MII.wID
With MII
'.cbSize = Len(MII)
.fMask = MIIM_BITMAP 'Or MIIM_DATA
If ImageID = -1 Then
.hbmpItem = 0
If KeyExists(sKey) Then Call cColl.Remove(sKey)
Else
If IsWinVistaOrLater Then
.hbmpItem = mDIB(ImageID).hDIB
Else
.hbmpItem = HBMMENU_CALLBACK
If KeyExists(sKey) Then Call cColl.Remove(sKey)
cColl.Add ImageID, sKey
End If
End If
'.dwItemData = ImageID
End With
PutImageToVBMenu = SetMenuItemInfo(hSubMenu, MenuPos, True, MII)
If hSubMenu = hMenu Then DrawMenuBar m_hwnd
End Function
Public Function PutImageToApiMenu(ByVal ImageID As Long, ByVal hMenu As Long, ByVal MenuPos As Long, Optional ByVal ItemData As Long) As Boolean
Dim MII As MENUITEMINFO
Dim sKey As String
With MII
.cbSize = Len(MII)
.fMask = MIIM_ID
End With
If GetMenuItemInfo(hMenu, MenuPos, True, MII) = 0 Then Exit Function
sKey = hMenu & "-" & MII.wID
With MII
.fMask = MIIM_BITMAP Or MIIM_DATA
If ImageID = -1 Then
.hbmpItem = 0
If KeyExists(sKey) Then Call cColl.Remove(sKey)
Else
If IsWinVistaOrLater Then
.hbmpItem = mDIB(ImageID).hDIB
Else
.hbmpItem = HBMMENU_CALLBACK
If KeyExists(sKey) Then Call cColl.Remove(sKey)
cColl.Add ImageID, sKey
End If
End If
.dwItemData = ItemData
End With
PutImageToApiMenu = SetMenuItemInfo(hMenu, MenuPos, True, MII)
End Function
Public Sub RemoveMenuCheckApi(ByVal hMenu As Long)
Dim MI As MENUINFO
With MI
.cbSize = Len(MI)
.fMask = MIM_STYLE
.dwStyle = MNS_NOCHECK
End With
SetMenuInfo hMenu, MI
End Sub
Public Sub RemoveMenuCheckVB(ParamArray vSubMenuPos() As Variant)
Dim MI As MENUINFO
Dim hMenu As Long
Dim hSubMenu As Long
Dim v As Variant
hMenu = GetMenu(m_hwnd)
hSubMenu = hMenu
For Each v In vSubMenuPos
hSubMenu = GetSubMenu(hSubMenu, v)
Next
With MI
.cbSize = Len(MI)
.fMask = MIM_STYLE
.dwStyle = MNS_NOCHECK
End With
SetMenuInfo hSubMenu, MI
End Sub
Private Sub DrawCheck(ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal X2 As Long, ByVal Y2 As Long, bDisabled As Boolean)
Dim hPen As Long, OldPen As Long
Dim hBrush As Long, OldBrush As Long
hPen = CreatePen(0, 1, GetSysColor(IIf(bDisabled, COLOR_GRAYTEXT, COLOR_APPWORKSPACE)))
hBrush = GetStockObject(NULL_BRUSH)
OldPen = SelectObject(hdc, hPen)
OldBrush = SelectObject(hdc, hBrush)
Rectangle hdc, X, Y, X + X2, Y + Y2
DeleteObject SelectObject(hdc, OldPen)
Call SelectObject(hdc, OldBrush)
End Sub
Private Function CreateNewDib() As Long
Dim tBITMAPINFO As BITMAPINFO
Dim Index As Long
Dim TempDC As Long
With tBITMAPINFO.bmiHeader
.biSize = Len(tBITMAPINFO.bmiHeader)
.biBitCount = 32
.biHeight = m_lWidth
.biWidth = m_lHeight
.biPlanes = 1
.biSizeImage = .biWidth * .biHeight * 4&
End With
Index = UBound(mDIB)
With mDIB(Index)
TempDC = GetDC(0&)
.hdc = CreateCompatibleDC(TempDC)
.hDIB = CreateDIBSection(TempDC, tBITMAPINFO, DIB_RGB_COLORS, .Ptr, 0&, 0&)
Call ReleaseDC(0&, TempDC)
If .hDIB <> 0 Then
CreateNewDib = Index
Else
CreateNewDib = -1
Exit Function
End If
End With
ReDim Preserve mDIB(Index + 1)
End Function
Public Function Clear()
Dim i As Long
For i = 0 To UBound(mDIB) - 1
With mDIB(i)
Call DeleteObject(.hDIB)
Call DeleteDC(.hdc)
End With
Next
ReDim mDIB(0)
End Function
Private Sub DrawDIB(ByVal DestHdc As Long, ByVal X As Long, ByVal Y As Long, ByVal Index As Long, Disabled As Boolean)
Dim hGraphics As Long
Dim hImage As Long
Dim hAttributes As Long
Dim tMatrixColor As COLORMATRIX
Dim tMatrixGray As COLORMATRIX
If Index < 0 Or Index > Me.ImageCount Then Exit Sub
If GdipCreateBitmapFromScan0(m_lWidth, m_lHeight, m_lWidth * 4&, PixelFormat32bppARGB, ByVal mDIB(Index).Ptr, hImage) = 0 Then
If GdipCreateFromHDC(DestHdc, hGraphics) = 0 Then
GdipImageRotateFlip hImage, &H6
If Disabled Then
GdipCreateImageAttributes hAttributes
With tMatrixColor
.m(0, 0) = 0.299
.m(1, 0) = .m(0, 0)
.m(2, 0) = .m(0, 0)
.m(0, 1) = 0.587
.m(1, 1) = .m(0, 1)
.m(2, 1) = .m(0, 1)
.m(0, 2) = 0.114
.m(1, 2) = .m(0, 2)
.m(2, 2) = .m(0, 2)
.m(3, 3) = 0.5
.m(4, 4) = 1
End With
GdipSetImageAttributesColorMatrix hAttributes, ColorAdjustTypeDefault, True, tMatrixColor, tMatrixGray, ColorMatrixFlagsDefault
End If
GdipDrawImageRectRectI hGraphics, hImage, X, Y, m_lWidth, m_lHeight, 0, 0, m_lWidth, m_lHeight, &H2, hAttributes, 0&, 0&
If hAttributes Then Call GdipDisposeImageAttributes(hAttributes)
GdipDeleteGraphics hGraphics
End If
GdipDisposeImage hImage
End If
End Sub
Private Function AlphaIconToBmp(ByVal IconHandle As Long, ByRef RefBmp As Long) As Long
Dim tRECT As RECT
Dim tICONINFO As ICONINFO
Dim tBitmapData As BitmapData
Dim lPixelFormat As Long
Dim sngWidth As Single
Dim sngHeight As Single
If GetIconInfo(IconHandle, tICONINFO) <> 0 Then
If GdipCreateBitmapFromHBITMAP(tICONINFO.hbmColor, 0&, RefBmp) = 0 Then
If GdipGetImagePixelFormat(RefBmp, lPixelFormat) = 0 Then
If GdipGetImageDimension(RefBmp, sngWidth, sngHeight) = 0 Then
With tRECT
.Right = CLng(sngWidth)
.Bottom = CLng(sngHeight)
End With
If GdipBitmapLockBits(RefBmp, tRECT, ImageLockModeRead, lPixelFormat, tBitmapData) = 0 Then
Call GdipCreateBitmapFromScan0(tRECT.Right, tRECT.Bottom, tBitmapData.Stride, PixelFormat32bppARGB, ByVal tBitmapData.Scan0, AlphaIconToBmp)
Call GdipBitmapUnlockBits(RefBmp, tBitmapData)
End If
End If
End If
End If
Call DeleteObject(tICONINFO.hbmMask)
Call DeleteObject(tICONINFO.hbmColor)
End If
End Function
Public Function AddIconFromHandle(ByVal hIcon As Long, Optional bGhosted As Boolean) As Boolean
Dim hBmp As Long
Dim hImage As Long
On Local Error GoTo AddIconFromHandle_Error
If hIcon <> 0 Then
If IsAlphaIcon(hIcon) Then
hImage = AlphaIconToBmp(hIcon, hBmp)
Else
GdipCreateBitmapFromHICON hIcon, hImage
End If
End If
AddIconFromHandle = pvAddImagen(hImage, bGhosted)
If hBmp <> 0 Then GdipDisposeImage hBmp
AddIconFromHandle_Error:
End Function
Public Function AddImageFromFile(ByVal FileName As String, Optional bGhosted As Boolean) As Boolean
On Local Error GoTo AddImageFromFile_Error
Dim hIcon As Long
Dim FileType As String
Dim hBmp As Long
Dim hImage As Long
FileType = UCase(Right(FileName, 3))
If FileType = "ICO" Or FileType = "CUR" Then
hIcon = LoadImage(App.hInstance, FileName, IMAGE_ICON, m_lWidth, m_lHeight, LR_LOADFROMFILE)
If hIcon <> 0 Then
If IsAlphaIcon(hIcon) Then
hImage = AlphaIconToBmp(hIcon, hBmp)
Else
GdipCreateBitmapFromHICON hIcon, hImage
End If
DestroyIcon hIcon
End If
Else
Call GdipLoadImageFromFile(StrPtr(FileName), hImage)
End If
AddImageFromFile = pvAddImagen(hImage, bGhosted)
If hBmp <> 0 Then GdipDisposeImage hBmp
AddImageFromFile_Error:
End Function
Public Function AddImageFromStream(ByRef bvData() As Byte, Optional bGhosted As Boolean) As Boolean
On Local Error GoTo AddImageFromStream_Error
Dim hImage As Long
Dim hIcon As Long
Dim hBmp As Long
If Not IsArrayDim(VarPtrArray(bvData)) Then Exit Function
If bvData(2) = vbResIcon Or bvData(2) = vbResCursor Then
hIcon = LoadIconFromStream(bvData)
If hIcon = 0 Then Exit Function
If IsAlphaIcon(hIcon) Then
hImage = AlphaIconToBmp(hIcon, hBmp)
Else
GdipCreateBitmapFromHICON hIcon, hImage
End If
DestroyIcon hIcon
Else
LoadImageFromStream bvData, hImage
End If
AddImageFromStream = pvAddImagen(hImage, bGhosted)
If hBmp <> 0 Then GdipDisposeImage hBmp
AddImageFromStream_Error:
End Function
Private Function pvAddImagen(ByVal hImage As Long, Optional bGhosted As Boolean) As Boolean
Dim hGraphics As Long
Dim ImgWidth As Single
Dim ImgHeight As Single
Dim Index As Long
Dim OldhDib As Long
If hImage <> 0 Then
Index = CreateNewDib()
If Index <> -1 Then
OldhDib = SelectObject(mDIB(Index).hdc, mDIB(Index).hDIB)
GdipCreateFromHDC mDIB(Index).hdc, hGraphics
GdipGetImageDimension hImage, ImgWidth, ImgHeight
If bGhosted Then
Dim tMatrixColor As COLORMATRIX
Dim tMatrixGray As COLORMATRIX
Dim hAttributes As Long
GdipCreateImageAttributes hAttributes
With tMatrixColor
.m(0, 0) = 1
.m(1, 1) = 1
.m(2, 2) = 1
.m(3, 3) = 0.7
.m(4, 4) = 1
End With
GdipSetImageAttributesColorMatrix hAttributes, ColorAdjustTypeDefault, True, tMatrixColor, tMatrixGray, ColorMatrixFlagsDefault
End If
GdipDrawImageRectRectI hGraphics, hImage, 0, 0, m_lWidth, m_lHeight, 0, 0, ImgWidth, ImgHeight, &H2, hAttributes, 0&, 0&
If hAttributes Then Call GdipDisposeImageAttributes(hAttributes)
GdipDisposeImage hImage
GdipDeleteGraphics hGraphics
Call SelectObject(mDIB(Index).hdc, OldhDib)
pvAddImagen = True
End If
End If
End Function
Private Function LoadImageFromStream(ByRef bvData() As Byte, ByRef hImage As Long) As Boolean
On Local Error GoTo LoadImageFromStream_Error
Dim IStream As IUnknown
Call CreateStreamOnHGlobal(bvData(0), 0&, IStream)
If Not IStream Is Nothing Then
If GdipLoadImageFromStream(IStream, hImage) = 0 Then
LoadImageFromStream = True
End If
End If
Set IStream = Nothing
LoadImageFromStream_Error:
End Function
Private Function LoadIconFromStream(ByRef bytIcoData() As Byte) As Long
On Local Error GoTo LoadIconFromStream_Error
Dim tIconHeader As IconHeader
Dim tIconEntry() As IconEntry
Dim MaxBitCount As Long
Dim MaxSize As Long
Dim Aproximate As Long
Dim IconID As Long
Dim hIcon As Long
Dim i As Long
Call CopyMemory(tIconHeader, bytIcoData(0), Len(tIconHeader))
If tIconHeader.ihCount >= 1 Then
ReDim tIconEntry(tIconHeader.ihCount - 1)
Call CopyMemory(tIconEntry(0), bytIcoData(Len(tIconHeader)), Len(tIconEntry(0)) * tIconHeader.ihCount)
IconID = -1
For i = 0 To tIconHeader.ihCount - 1
If tIconEntry(i).ieBitCount > MaxBitCount Then MaxBitCount = tIconEntry(i).ieBitCount
Next
For i = 0 To tIconHeader.ihCount - 1
If MaxBitCount = tIconEntry(i).ieBitCount Then
MaxSize = CLng(tIconEntry(i).ieWidth) + CLng(tIconEntry(i).ieHeight)
If MaxSize > Aproximate And MaxSize <= (m_lWidth + m_lHeight) Then
Aproximate = MaxSize
IconID = i
End If
End If
Next
If IconID = -1 Then Exit Function
With tIconEntry(IconID)
hIcon = CreateIconFromResourceEx(bytIcoData(.ieImageOffset), .ieBytesInRes, 1, IconVersion, m_lWidth, m_lHeight, &H0)
If hIcon <> 0 Then
LoadIconFromStream = hIcon
End If
End With
End If
LoadIconFromStream_Error:
End Function
Public Function Init(ByVal hwnd As Long, ImgWidth As Long, ByVal ImgHeight As Long, Optional ByVal bRaiseEvent As Boolean) As Boolean
If GdipToken Then
m_lWidth = ImgWidth
m_lHeight = ImgHeight
m_hwnd = hwnd
If UBound(mDIB) > 0 Then
Me.Clear
End If
If Not IsWinVistaOrLater Or bRaiseEvent = True Then
If hwnd <> 0 Then
Call StopSubclassing
Init = SetSubclassing(hwnd)
End If
Else
Init = True
End If
End If
End Function
Private Function SetSubclassing(ByVal hwnd As Long) As Boolean
If PrevWndProc = 0 Then
If pASMWrapper <> 0 Then
PrevWndProc = SetWindowLong(hwnd, GWL_WNDPROC, pASMWrapper)
If PrevWndProc <> 0 Then
SetSubclassing = True
End If
End If
End If
End Function
Private Function StopSubclassing() As Boolean
If m_hwnd <> 0 Then
If PrevWndProc <> 0 Then
Call SetWindowLong(m_hwnd, GWL_WNDPROC, PrevWndProc)
m_hwnd = 0
PrevWndProc = 0
StopSubclassing = True
End If
End If
End Function
Private Sub Class_Initialize()
Me.hwnd = Application.hwnd
Dim ASM(0 To 103) As Byte
Dim pVar As Long
Dim ThisClass As Long
Dim CallbackFunction As Long
Dim pVirtualFree
Dim i As Long
Dim sCode As String
Dim tOSVI As OSVERSIONINFO
Set cColl = New Collection
tOSVI.dwOSVersionInfoSize = Len(tOSVI)
Call GetVersionEx(tOSVI)
If tOSVI.dwMajorVersion < 5 Then Exit Sub
IsWinVistaOrLater = tOSVI.dwMajorVersion >= 6
ReDim mDIB(0)
InitGDI
pASMWrapper = VirtualAlloc(ByVal 0&, 104, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
If pASMWrapper <> 0 Then
ThisClass = ObjPtr(Me)
Call CopyMemory(pVar, ByVal ThisClass, 4)
Call CopyMemory(CallbackFunction, ByVal (pVar + 28), 4)
pVirtualFree = GetProcAddress(GetModuleHandle("kernel32.dll"), "VirtualFree")
sCode = "90FF05000000006A0054FF742418FF742418FF742418FF7424186800000000B800000000FFD0FF0D00000000A10000000085C075" & _
"0458C21000A10000000085C0740458C2100058595858585868008000006A00680000000051B800000000FFE00000000000000000"
For i = 0 To Len(sCode) - 1 Step 2
ASM(i / 2) = CByte("&h" & Mid$(sCode, i + 1, 2))
Next
Call CopyMemory(ASM(3), pASMWrapper + 96, 4)
Call CopyMemory(ASM(40), pASMWrapper + 96, 4)
Call CopyMemory(ASM(58), pASMWrapper + 96, 4)
Call CopyMemory(ASM(45), pASMWrapper + 100, 4)
Call CopyMemory(ASM(84), pASMWrapper, 4)
Call CopyMemory(ASM(27), ThisClass, 4)
Call CopyMemory(ASM(32), CallbackFunction, 4)
Call CopyMemory(ASM(90), pVirtualFree, 4)
Call CopyMemory(ByVal pASMWrapper, ASM(0), 104)
End If
End Sub
Private Sub Class_Terminate()
Dim Counter As Long
If pASMWrapper <> 0 Then
Call StopSubclassing
Call CopyMemory(Counter, ByVal (pASMWrapper + 104), 4)
If Counter = 0 Then
'Call VirtualFree(ByVal pASMWrapper, 0, MEM_RELEASE)
Else
Call CopyMemory(ByVal (pASMWrapper + 108), 1, 4)
End If
End If
Clear
TerminateGDI
End Sub
Private Sub InitGDI()
Dim GdipStartupInput As GDIPlusStartupInput
GdipStartupInput.GdiPlusVersion = GdiPlusVersion
Call GdiplusStartup(GdipToken, GdipStartupInput, ByVal 0&)
End Sub
Private Sub TerminateGDI()
If GdipToken <> 0 Then Call GdiplusShutdown(GdipToken)
End Sub
Private Function IsArrayDim(ByVal lpArray As Long) As Boolean
Dim lAddress As Long
Call CopyMemory(lAddress, ByVal lpArray, &H4)
IsArrayDim = Not (lAddress = 0)
End Function
Private Function KeyExists(ByVal sKey As String) As Boolean
On Error GoTo HandleError:
Dim val As Variant
val = cColl(sKey)