-
Notifications
You must be signed in to change notification settings - Fork 9
/
Copy pathjcButton.ctl
4292 lines (3366 loc) · 158 KB
/
jcButton.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 jcbutton
AutoRedraw = -1 'True
ClientHeight = 375
ClientLeft = 0
ClientTop = 0
ClientWidth = 1335
DefaultCancel = -1 'True
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ScaleHeight = 25
ScaleMode = 3 'Pixel
ScaleWidth = 89
End
Attribute VB_Name = "jcbutton"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'***************************************************************************
'* Title: JC button
'* Function: An ownerdrawn multistyle button
'* Author: Juned Chhipa
'* Created: November 2008
'* Contact me: [email protected]
'*
'* Copyright © 2008-2009 Juned Chhipa. All rights reserved.
'***************************************************************************
'* This control can be used as an alternative to Command Button. It is
'* a lightweight button control which will emulate new button styles.
'* Compile to get more faster results
'*
'* This control uses self-subclassing routines of Paul Caton.
'* Feel free to use this control. Please read Licence.txt
'* Please send comments/suggestions/bug reports to [email protected]
'****************************************************************************
'*
'* - CREDITS:
'* - Paul Caton :- Self-Subclass Routines
'* - Noel Dacara :- DropDown menu support
'* - Fred.CPP :- For the amazing Aqua Style and for flexible tooltips
'* - Gonkuchi :- For his sub TransBlt to make grayscale pictures
'* - Carles P.V. :- For fastest gradient routines
'*
'* I have tested this control painstakingly and tried my best to make
'* it work as a real command button. But still, if any bugs found,
'* please report to the email address provided above ;)
'****************************************************************************
'* This software is provided "as-is" without any express/implied warranty. *
'* In no event shall the author be held liable for any damages arising *
'* from the use of this software. *
'* If you do not agree with these terms, do not install "JCButton". Use *
'* of the program implicitly means you have agreed to these terms. * *
' *
'* Permission is granted to anyone to use this software for any purpose, *
'* including commercial use, and to alter and redistribute it, provided *
'* tSlwestr the following conditions are met: *
'* *
'* 1.All redistributions of source code files must retain all copyright *
'* notices tSlwestr are currently in place, and this list of conditions *
'* without any modification. *
'* *
'* 2.All redistributions in binary form must retain all occurrences of *
'* above copyright notice and web site addresses tSlwestr are currently in *
'* place (for example, in the About boxes). *
'* *
'* 3.Modified versions in source or binary form must be plainly marked as *
'* such, and must not be misrepresented as being the original software. *
'****************************************************************************
'* N'joy ;)
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINT) As Long
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function StretchDIBits Lib "gdi32" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal wSrcWidth As Long, ByVal wSrcHeight As Long, lpBits As Any, lpBitsInfo As Any, ByVal wUsage As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function 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 CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDc As Long, ByVal hObject As Long) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function PtInRegion Lib "gdi32" (ByVal hRgn As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetPixel Lib "gdi32.dll" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function GetPixel Lib "gdi32.dll" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetTextColor Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDc As Long, ByVal crColor As Long) As Long
Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal hPalette As Long, ByRef pccolorref As Long) As Long
Private Declare Function FillRgn Lib "gdi32" (ByVal hDc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function GetNearestColor Lib "gdi32" (ByVal hDc As Long, ByVal crColor As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As tLOGFONT) As Long
'User32 Declares
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function CopyRect Lib "user32" (lpDestRect As RECT, lpSourceRect As RECT) As Long
Private Declare Function DrawEdge Lib "user32" (ByVal hDc As Long, qrc As RECT, ByVal Edge As Long, ByVal grfFlags As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hDc As Long, lpRect As RECT) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hDc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function TransparentBlt Lib "MSIMG32.dll" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINT) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function LoadCursor Lib "user32.dll" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function SetCursor Lib "user32.dll" (ByVal hCursor As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function CreateWindowEx Lib "user32" 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, lpParam As Any) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32.dll" () As Long
Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetCapture Lib "user32.dll" () As Long
Private Declare Function FillRect Lib "user32.dll" (ByVal hDc As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function DrawTextW Lib "user32" (ByVal hDc As Long, ByVal lpStr As Long, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hDc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
'==========================================================================================================================================================================================================================================================================================
' Subclassing Declares
Private Enum eMsgWhen
MSG_AFTER = 1 'Message calls back after the original (previous) WndProc
MSG_BEFORE = 2 'Message calls back before the original (previous) WndProc
MSG_BEFORE_AND_AFTER = MSG_AFTER Or MSG_BEFORE 'Message calls back before and after the original (previous) WndProc
End Enum
Private Enum TRACKMOUSEEVENT_FLAGS
TME_HOVER = &H1
TME_LEAVE = &H2
TME_QUERY = &H40000000
TME_CANCEL = &H80000000
End Enum
'Windows Messages
Private Const WM_MOUSEMOVE As Long = &H200
Private Const WM_MOUSELEAVE As Long = &H2A3
Private Const WM_THEMECHANGED As Long = &H31A
Private Const WM_SYSCOLORCHANGE As Long = &H15
Private Const WM_MOVING As Long = &H216
Private Const WM_NCACTIVATE As Long = &H86
Private Const WM_ACTIVATE As Long = &H6
Private Const ALL_MESSAGES As Long = -1 'All messages added or deleted
Private Const GMEM_FIXED As Long = 0 'Fixed memory GlobalAlloc flag
Private Const GWL_WNDPROC As Long = -4 'Get/SetWindow offset to the WndProc procedure address
Private Const PATCH_04 As Long = 88 'Table B (before) address patch offset
Private Const PATCH_05 As Long = 93 'Table B (before) entry count patch offset
Private Const PATCH_08 As Long = 132 'Table A (after) address patch offset
Private Const PATCH_09 As Long = 137 'Table A (after) entry count patch offset
Private Type TRACKMOUSEEVENT_STRUCT
cbSize As Long
dwFlags As TRACKMOUSEEVENT_FLAGS
hwndTrack As Long
dwHoverTime As Long
End Type
'for subclass
Private Type tSubData 'Subclass data type
hWnd As Long 'Handle of the window being subclassed
nAddrSub As Long 'The address of our new WndProc (allocated memory).
nAddrOrig As Long 'The address of the pre-existing WndProc
nMsgCntA As Long 'Msg after table entry count
nMsgCntB As Long 'Msg before table entry count
aMsgTblA() As Long 'Msg after table array
aMsgTblB() As Long 'Msg Before table array
End Type
'for subclass
Private sc_aSubData() As tSubData 'Subclass data array
Private bTrack As Boolean
Private bTrackUser32 As Boolean
'Kernel32 declares used by the Subclasser
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub RtlMoveMemory Lib "kernel32" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As Long
Private Declare Function TrackMouseEvent Lib "user32" (lpEventTrack As TRACKMOUSEEVENT_STRUCT) As Long
Private Declare Function TrackMouseEventComCtl Lib "Comctl32" Alias "_TrackMouseEvent" (lpEventTrack As TRACKMOUSEEVENT_STRUCT) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
' End of Subclassing Declares
'==========================================================================================================================================================================================================================================================================================================
'[Enumerations]
Public Enum enumButtonStlyes
[eStandard] '1) Standard VB Button
[eFlat] '2) Standard Toolbar Button
[eWindowsXP] '3) Famous Win XP Button
[eVistaAero] '5) The New Vista Aero Button
[eOfficeXP]
[eOffice2003] '13) Office 2003 Style
[eXPToolbar] '4) XP Toolbar
[eVistaToolbar] '9) Vista Toolbar Button
[eOutlook2007] '8) Office 2007 Outlook Button
[eAOL] '6) AOL Buttons
[eInstallShield] '7) InstallShield?!?~?
[eGelButton] '11) Gel Button
[e3DHover] '13) 3D Hover Button
[eFlatHover] '12) Flat Hover Button
End Enum
#If False Then
Private eStandard, eFlat, eVistaAero, eVistaToolbar, eInstallShield, eFlatHover, eOffice2003
Private eWindowsXP, eXPToolbar, e3DHover, eGelButton, eOutlook2007, eAOL, eOfficeXP
#End If
Public Enum enumButtonModes
[ebmCommandButton]
[ebmCheckBox]
[ebmOptionButton]
End Enum
#If False Then
Private ebmCommandButton, ebmCheckBox, ebmOptionButton
#End If
Public Enum enumButtonStates
[eStateNormal] 'Normal State
[eStateOver] 'Hover State
[eStateDown] 'Down State
End Enum
#If False Then
'A trick to preserve casing when typing in IDE
Private eStateNormal, eStateOver, eStateDown, eStateFocused
#End If
Public Enum enumCaptionAlign
[ecLeftAlign]
[ecCenterAlign]
[ecRightAlign]
End Enum
#If False Then
'A trick to preserve casing when typing in IDE
Private ecLeftAlign, ecCenterAlign, ecRightAlign
#End If
Public Enum enumPictureAlign
[epLeftEdge]
[epLeftOfCaption]
[epRightEdge]
[epRightOfCaption]
[epBackGround]
[epTopEdge]
[epTopOfCaption]
[epBottomEdge]
[epBottomOfCaption]
End Enum
#If False Then
Private epLeftEdge, epRightEdge, epRightOfCaption, epLeftOfCaption, epBackGround
Private epTopEdge, epTopOfCaption, epBottomEdge, epBottomOfCaption
#End If
' --Tooltip Icons
Public Enum enumIconType
TTNoIcon
TTIconInfo
TTIconWarning
TTIconError
End Enum
#If False Then
Private TTNoIcon, TTIconInfo, TTIconWarning, TTIconError
#End If
' --Tooltip [ Balloon / Standard ]
Public Enum enumTooltipStyle
TooltipStandard
TooltipBalloon
End Enum
#If False Then
Private TooltipStandard, TooltipBalloon
#End If
' --Caption effects
Public Enum enumCaptionEffects
[eseNone]
[eseEmbossed]
[eseEngraved]
[eseShadowed]
[eseOutline]
[eseCover]
End Enum
#If False Then
Private eseNone, eseEmbossed, eseEngraved, eseShadowed, eseOutline, eseCover
#End If
Public Enum enumPicEffect
[epeNone]
[epeLighter]
[epeDarker]
End Enum
#If False Then
Private epeNone, epeLighter, epeDarker, epePushUp
#End If
' --For dropdown symbols
Public Enum enumSymbol
ebsNone
ebsArrowUp = 5
ebsArrowDown = 6
End Enum
#If False Then
Private ebsArrowUp, ebsArrowDown, ebsNone
#End If
Public Enum enumXPThemeColors
[ecsBlue]
[ecsOliveGreen]
[ecsSilver]
[ecsCustom]
End Enum
' --A trick to preserve casing of enums while typing in IDE
#If False Then
Private ecsBlue, ecsOliveGreen, ecsSilver, ecsCustom
#End If
' --For gradient subs
Public Enum GradientDirectionCts
[gdHorizontal] = 0
[gdVertical] = 1
[gdDownwardDiagonal] = 2
[gdUpwardDiagonal] = 3
End Enum
' --A trick to preserve casing of enums when typing in IDE
#If False Then
Private gdHorizontal, gdVertical, gdDownwardDiagonal, gdUpwardDiagonal
#End If
Public Enum enumMenuAlign
[edaBottom]
[edaTop]
[edaLeft]
[edaRight]
[edaTopLeft]
[edaBottomLeft]
[edaTopRight]
[edaBottomRight]
End Enum
#If False Then
Private edaBottom, edaTop, edaTopLeft, edaBottomLeft, edaTopRight, edaBottomRight
#End If
' used for Button colors
Private Type tButtonColors
tBackColor As Long
tDisabledColor As Long
tForeColor As Long
tForeColorOver As Long
tGreyText As Long
End Type
' used to define various graphics areas
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
''Tooltip Window Types
Private Type TOOLINFO
lSize As Long
lFlags As Long
lHwnd As Long
lId As Long
lpRect As RECT
hInstance As Long
lpStr As String
lParam As Long
End Type
Private Type POINT
X As Long
Y As Long
End Type
' --Used for creating a drop down symbol
' --I m using Marlett Font to create tSlwestr symbol
Private Type tLOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * 32
End Type
' RGB Colors structure
Private Type RGBColor
r As Single
g As Single
B As Single
End Type
' for gradient painting and bitmap tiling
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 RGBTRIPLE
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBTRIPLE
End Type
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128 '* Maintenance string for PSS usage.
End Type
' --constants for unicode support
Private Const VER_PLATFORM_WIN32_NT = 2
' --constants for Flat Button
Private Const BDR_RAISEDINNER As Long = &H4
' --constants for Win 98 style buttons
Private Const BDR_SUNKEN95 As Long = &HA
Private Const BDR_RAISED95 As Long = &H5
Private Const BF_LEFT As Long = &H1
Private Const BF_TOP As Long = &H2
Private Const BF_RIGHT As Long = &H4
Private Const BF_BOTTOM As Long = &H8
Private Const BF_RECT As Long = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
' --System Hand Pointer
Private Const IDC_HAND As Long = 32649
' --Color Constant
Private Const COLOR_BTNFACE As Long = 15
Private Const COLOR_BTNHIGHLIGHT As Long = 20
Private Const COLOR_BTNSHADOW As Long = 16
Private Const COLOR_HIGHLIGHT As Long = 13
Private Const COLOR_GRAYTEXT As Long = 17
Private Const CLR_INVALID As Long = &HFFFF
Private Const DIB_RGB_COLORS As Long = 0
' --Windows Messages
Private Const WM_USER As Long = &H400
Private Const GWL_STYLE As Long = -16
Private Const WS_CAPTION As Long = &HC00000
Private Const WS_THICKFRAME As Long = &H40000
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const SWP_REFRESH As Long = (&H1 Or &H2 Or &H4 Or &H20)
Private Const SWP_NOACTIVATE As Long = &H10
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOSIZE As Long = &H1
Private Const SWP_SHOWWINDOW As Long = &H40
Private Const HWND_TOPMOST As Long = -&H1
Private Const CW_USEDEFAULT As Long = &H80000000
''Tooltip Window Constants
Private Const TTS_NOPREFIX As Long = &H2
Private Const TTF_CENTERTIP As Long = &H2
Private Const TTM_ADDTOOLA As Long = (WM_USER + 4)
Private Const TTM_DELTOOLA As Long = (WM_USER + 5)
Private Const TTM_SETTIPBKCOLOR As Long = (WM_USER + 19)
Private Const TTM_SETTIPTEXTCOLOR As Long = (WM_USER + 20)
Private Const TTM_SETTITLE As Long = (WM_USER + 32)
Private Const TTM_DELTOOLW As Long = (WM_USER + 51)
Private Const TTM_ADDTOOLW As Long = (WM_USER + 50)
Private Const TTM_SETTITLEW As Long = (WM_USER + 33)
Private Const TTS_BALLOON As Long = &H40
Private Const TTS_ALWAYSTIP As Long = &H1
Private Const TTF_SUBCLASS As Long = &H10
Private Const TOOLTIPS_CLASSA As String = "tooltips_class32"
' --Formatting Text Consts
Private Const DT_CALCRECT As Long = &H400
Private Const DT_CENTER As Long = &H1
Private Const DT_VCENTER As Long = &H4
Private Const DT_WORDBREAK As Long = &H10
Private Const DT_DRAWFLAG As Long = DT_CENTER Or DT_WORDBREAK Or DT_VCENTER
' --for drawing Icon Constants
Private Const DI_NORMAL As Long = &H3
' --Property Variables:
Private m_ButtonStyle As enumButtonStlyes 'Choose your Style
Private m_Buttonstate As enumButtonStates 'Normal / Over / Down
Private m_bIsDown As Boolean 'Is button is pressed?
Private m_bMouseInCtl As Boolean 'Is Mouse in Control
Private m_bHasFocus As Boolean 'Has focus?
Private m_bHandPointer As Boolean 'Use Hand Pointer
Private m_lCursor As Long
Private m_bDefault As Boolean 'Is Default?
Private m_DropDownSymbol As enumSymbol
Private m_bDropDownSep As Boolean
Private m_ButtonMode As enumButtonModes 'Command/Check/Option button
Private m_CaptionEffects As enumCaptionEffects
Private m_bValue As Boolean 'Value (Checked/Unchekhed)
Private m_bShowFocus As Boolean 'Bool to show focus
Private m_bParentActive As Boolean 'Parent form Active or not
Private m_lParenthWnd As Long 'Is parent active?
Private m_WindowsNT As Long 'OS Supports Unicode?
Private m_bEnabled As Boolean 'Enabled/Disabled
Private m_Caption As String 'String to draw caption
Private m_CaptionAlign As enumCaptionAlign
Private m_bColors As tButtonColors 'Button Colors
Private m_bUseMaskColor As Boolean 'Transparent areas
Private m_lMaskColor As Long 'Set Transparent color
Private m_lButtonRgn As Long 'Button Region
Private m_bIsSpaceBarDown As Boolean 'Space bar down boolean
Private m_ButtonRect As RECT 'Button Position
Private m_FocusRect As RECT
Private WithEvents mFont As StdFont
Attribute mFont.VB_VarHelpID = -1
Private m_lXPColor As enumXPThemeColors
Private m_lDownButton As Integer 'For click/Dblclick events
Private m_lDShift As Integer 'A flag for dblClick
Private m_lDX As Single
Private m_lDY As Single
' --Popup menu variables
Private m_bPopupEnabled As Boolean 'Popus is enabled
Private m_bPopupShown As Boolean 'Popupmenu is shown
Private m_bPopupInit As Boolean 'Flag to prevent WM_MOUSLEAVE to redraw the button
Private DropDownMenu As VB.Menu 'Popupmenu to be shown
Private MenuAlign As enumMenuAlign 'PopupMenu Alignments
Private MenuFlags As Long 'PopupMenu Flags
Private DefaultMenu As VB.Menu 'Default menu in the popupmenu
' --Tooltip variables
Private m_sTooltipText As String
Private m_sTooltiptitle As String
Private m_lToolTipIcon As enumIconType
Private m_lTooltipType As enumTooltipStyle
Private m_lttBackColor As Long
Private m_lttForeColor As Long
Private m_lttCentered As Boolean
Private m_lttHwnd As Long
Private ttip As TOOLINFO
' --Caption variables
Private CaptionW As Long 'Width of Caption
Private CaptionH As Long 'Height of Caption
Private CaptionX As Long 'Left of Caption
Private CaptionY As Long 'Top of Caption
Private lpSignRect As RECT 'Drop down Symbol rect
Private m_TextRect As RECT 'Caption drawing area
' --Picture variables
Private m_Picture As StdPicture
Private m_PictureHot As StdPicture
Private m_PictureDown As StdPicture
Private m_PicSemiTrans As Boolean
Private m_PictureShadow As Boolean
Private m_PictureAlign As enumPictureAlign 'Picture Alignments
Private m_PicEffectonOver As enumPicEffect 'Blend effect
Private m_PicEffectonDown As enumPicEffect 'Blend effect
Private m_bPicPushOnHover As Boolean
Private PicH As Long
Private PicW As Long
Private tmppic As New StdPicture 'Temp picture
Private PicX As Long 'X position of picture
Private PicY As Long 'Y Position of Picture
Private m_PicRect As RECT 'Picture drawing area
Private lh As Long 'ScaleHeight of button
Private lw As Long 'ScaleWidth of button
' Events
Public Event Click()
Public Event DblClick()
Public Event MouseEnter()
Public Event MouseLeave()
Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event KeyPress(KeyAcsii As Integer)
Private Sub DrawLineApi(ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal color As Long)
'****************************************************************************
'* draw lines
'****************************************************************************
Dim pt As POINT
Dim hPen As Long
Dim hPenOld As Long
hPen = CreatePen(0, 1, color)
hPenOld = SelectObject(hDc, hPen)
MoveToEx hDc, X1, Y1, pt
LineTo hDc, X2, Y2
SelectObject hDc, hPenOld
DeleteObject hPen
DeleteObject hPenOld
End Sub
Private Function BlendColorEx(Color1 As Long, Color2 As Long, Optional Percent As Long) As Long
' Combines two colors together by how many percent.
' Inspired from dcbutton (honestly not copied!!) hehe
Dim r1 As Long, g1 As Long, b1 As Long
Dim r2 As Long, g2 As Long, b2 As Long
Dim r3 As Long, g3 As Long, b3 As Long
If Percent <= 0 Then Percent = 0
If Percent >= 100 Then Percent = 100
r1 = Color1 And 255
g1 = (Color1 \ 256) And 255
b1 = (Color1 \ 65536) And 255
r2 = Color2 And 255
g2 = (Color2 \ 256) And 255
b2 = (Color2 \ 65536) And 255
r3 = r1 + (r1 - r2) * Percent \ 100
g3 = g1 + (g1 - g2) * Percent \ 100
b3 = b1 + (b1 - b2) * Percent \ 100
BlendColorEx = r3 + 256& * g3 + 65536 * b3
End Function
Private Function BlendColors(ByVal lBackColorFrom As Long, ByVal lBackColorTo As Long) As Long
'***************************************************************************
'* Combines (mix) two colors *
'* This is another method in which you can't specify percentage
'***************************************************************************
BlendColors = RGB(((lBackColorFrom And &HFF) + (lBackColorTo And &HFF)) / 2, (((lBackColorFrom \ &H100) And &HFF) + ((lBackColorTo \ &H100) And &HFF)) / 2, (((lBackColorFrom \ &H10000) And &HFF) + ((lBackColorTo \ &H10000) And &HFF)) / 2)
End Function
Private Sub DrawRectangle(ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long, ByVal color As Long)
'****************************************************************************
'* Draws a rectangle specified by coords and color of the rectangle *
'****************************************************************************
Dim brect As RECT
Dim hBrush As Long
Dim ret As Long
brect.Left = X
brect.Top = Y
brect.Right = X + Width
brect.Bottom = Y + Height
hBrush = CreateSolidBrush(color)
ret = FrameRect(hDc, brect, hBrush)
ret = DeleteObject(hBrush)
End Sub
Private Sub DrawFocusRectangle(ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long)
'****************************************************************************
'* Draws a Focus Rectangle inside button if m_bShowFocus property is True *
'****************************************************************************
Dim brect As RECT
Dim RetVal As Long
brect.Left = X
brect.Top = Y
brect.Right = X + Width
brect.Bottom = Y + Height
RetVal = DrawFocusRect(hDc, brect)
End Sub
Private Sub TransBlt(ByVal DstDC As Long, ByVal DstX As Long, ByVal DstY As Long, ByVal DstW As Long, ByVal DstH As Long, ByVal SrcPic As StdPicture, Optional ByVal TransColor As Long = -1, Optional ByVal BrushColor As Long = -1, Optional ByVal MonoMask As Boolean = False, Optional ByVal isGreyscale As Boolean = False)
'****************************************************************************
'* Routine : To make transparent and grayscale images *
'* Author : Gonkuchi *
'* All credits goes to the author of Chameleon button - > Gonkuchi *
'* I was first using Jim Jose's routine to make grayscale images
'* But I find this more powerful! [sorry Jim ;)]
'
'* Modified by me to get the LightonHover and DarkonDown picture effects
'****************************************************************************
Dim B As Long, H As Long, F As Long, I As Long, newW As Long
Dim TmpDC As Long, TmpBmp As Long, TmpObj As Long
Dim Sr2DC As Long, Sr2Bmp As Long, Sr2Obj As Long
Dim Data1() As RGBTRIPLE, Data2() As RGBTRIPLE
Dim Info As BITMAPINFO, BrushRGB As RGBTRIPLE, gCol As Long
Dim hOldOb As Long, PicEffect As enumPicEffect
Dim PicBlend As Boolean
Dim SrcDC As Long, tObj As Long, ttt As Long
If DstW = 0 Or DstH = 0 Then Exit Sub
If SrcPic Is Nothing Then Exit Sub
If m_Buttonstate = eStateOver Then
PicEffect = m_PicEffectonOver
ElseIf m_Buttonstate = eStateDown Then
PicEffect = m_PicEffectonDown
End If
PicBlend = m_PicSemiTrans
SrcDC = CreateCompatibleDC(hDc)
If DstW < 0 Then DstW = UserControl.ScaleX(SrcPic.Width, 8, UserControl.ScaleMode)
If DstH < 0 Then DstH = UserControl.ScaleY(SrcPic.Height, 8, UserControl.ScaleMode)
If SrcPic.Type = vbPicTypeBitmap Then 'check if it's an icon or a bitmap
tObj = SelectObject(SrcDC, SrcPic)
Else
Dim hBrush As Long
tObj = SelectObject(SrcDC, CreateCompatibleBitmap(DstDC, DstW, DstH))
hBrush = CreateSolidBrush(TransColor)
DrawIconEx SrcDC, 0, 0, SrcPic.Handle, DstW, DstH, 0, hBrush, DI_NORMAL
DeleteObject hBrush
End If
TmpDC = CreateCompatibleDC(SrcDC)
Sr2DC = CreateCompatibleDC(SrcDC)
TmpBmp = CreateCompatibleBitmap(DstDC, DstW, DstH)
Sr2Bmp = CreateCompatibleBitmap(DstDC, DstW, DstH)
TmpObj = SelectObject(TmpDC, TmpBmp)
Sr2Obj = SelectObject(Sr2DC, Sr2Bmp)
ReDim Data1(DstW * DstH * 3 - 1)
ReDim Data2(UBound(Data1))
With Info.bmiHeader
.biSize = Len(Info.bmiHeader)
.biWidth = DstW
.biHeight = DstH
.biPlanes = 1
.biBitCount = 24
End With
BitBlt TmpDC, 0, 0, DstW, DstH, DstDC, DstX, DstY, vbSrcCopy
BitBlt Sr2DC, 0, 0, DstW, DstH, SrcDC, 0, 0, vbSrcCopy
GetDIBits TmpDC, TmpBmp, 0, DstH, Data1(0), Info, 0
GetDIBits Sr2DC, Sr2Bmp, 0, DstH, Data2(0), Info, 0
If BrushColor > 0 Then
BrushRGB.rgbBlue = (BrushColor \ &H10000) Mod &H100
BrushRGB.rgbGreen = (BrushColor \ &H100) Mod &H100
BrushRGB.rgbRed = BrushColor And &HFF
End If
' --No Maskcolor to use
If Not m_bUseMaskColor Then TransColor = -1
newW = DstW - 1
For H = 0 To DstH - 1
F = H * DstW
For B = 0 To newW
I = F + B
If GetNearestColor(hDc, CLng(Data2(I).rgbRed) + 256& * Data2(I).rgbGreen + 65536 * Data2(I).rgbBlue) <> TransColor Then
With Data1(I)
If BrushColor > -1 Then
If MonoMask Then
If (CLng(Data2(I).rgbRed) + Data2(I).rgbGreen + Data2(I).rgbBlue) <= 384 Then Data1(I) = BrushRGB
Else
Data1(I) = BrushRGB
End If
Else
If isGreyscale Then
gCol = CLng(Data2(I).rgbRed * 0.3) + Data2(I).rgbGreen * 0.59 + Data2(I).rgbBlue * 0.11
.rgbRed = gCol: .rgbGreen = gCol: .rgbBlue = gCol
Else
If PicEffect = epeLighter Or PicBlend Then
' /--Draw Semi Transparent effect
.rgbRed = (CLng(.rgbRed) + Data2(I).rgbRed * 2) \ 3
.rgbGreen = (CLng(.rgbGreen) + Data2(I).rgbGreen * 2) \ 3
.rgbBlue = (CLng(.rgbBlue) + Data2(I).rgbBlue * 2) \ 3
ElseIf PicEffect = epeDarker Then
' /--Draw darker picture
.rgbRed = (CLng(.rgbRed) + Data2(I).rgbRed * 2.5) \ 3.5
.rgbGreen = (CLng(.rgbGreen) + Data2(I).rgbGreen * 2.5) \ 3.5
.rgbBlue = (CLng(.rgbBlue) + Data2(I).rgbBlue * 2.5) \ 3.5
Else
Data1(I) = Data2(I)
End If
End If
End If
End With
End If
Next B
Next H
' /--Paint it!
SetDIBitsToDevice DstDC, DstX, DstY, DstW, DstH, 0, 0, 0, DstH, Data1(0), Info, 0
Erase Data1, Data2
DeleteObject SelectObject(TmpDC, TmpObj)
DeleteObject SelectObject(Sr2DC, Sr2Obj)
If SrcPic.Type = vbPicTypeIcon Then DeleteObject SelectObject(SrcDC, tObj)
DeleteDC TmpDC
DeleteDC Sr2DC
DeleteObject tObj
DeleteDC SrcDC
End Sub
Private Sub DrawGradientEx(ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long, ByVal Color1 As Long, ByVal Color2 As Long, ByVal GradientDirection As GradientDirectionCts)
'****************************************************************************
'* Draws very fast Gradient in four direction. *
'* Author: Carles P.V (Gradient Master) *
'* This routine works as a heart for this control. *
'* Thank you so much Carles. *
'****************************************************************************
Dim uBIH As BITMAPINFOHEADER
Dim lBits() As Long
Dim lGrad() As Long
Dim r1 As Long
Dim g1 As Long
Dim b1 As Long
Dim r2 As Long
Dim g2 As Long
Dim b2 As Long
Dim dR As Long
Dim dG As Long
Dim dB As Long
Dim Scan As Long
Dim I As Long
Dim iEnd As Long
Dim iOffset As Long
Dim j As Long
Dim jEnd As Long
Dim iGrad As Long
'-- A minor check
'If (Width < 1 Or Height < 1) Then Exit Sub
If (Width < 1 Or Height < 1) Then
Exit Sub
End If
'-- Decompose colors
Color1 = Color1 And &HFFFFFF
r1 = Color1 Mod &H100&
Color1 = Color1 \ &H100&
g1 = Color1 Mod &H100&
Color1 = Color1 \ &H100&
b1 = Color1 Mod &H100&
Color2 = Color2 And &HFFFFFF
r2 = Color2 Mod &H100&
Color2 = Color2 \ &H100&
g2 = Color2 Mod &H100&
Color2 = Color2 \ &H100&
b2 = Color2 Mod &H100&
'-- Get color distances
dR = r2 - r1
dG = g2 - g1
dB = b2 - b1
'-- Size gradient-colors array
Select Case GradientDirection
Case [gdHorizontal]
ReDim lGrad(0 To Width - 1)
Case [gdVertical]
ReDim lGrad(0 To Height - 1)
Case Else
ReDim lGrad(0 To Width + Height - 2)
End Select
'-- Calculate gradient-colors
iEnd = UBound(lGrad())
If (iEnd = 0) Then
'-- Special case (1-pixel wide gradient)
lGrad(0) = (b1 \ 2 + b2 \ 2) + 256 * (g1 \ 2 + g2 \ 2) + 65536 * (r1 \ 2 + r2 \ 2)
Else
For I = 0 To iEnd
lGrad(I) = b1 + (dB * I) \ iEnd + 256 * (g1 + (dG * I) \ iEnd) + 65536 * (r1 + (dR * I) \ iEnd)
Next I
End If
'-- Size DIB array
ReDim lBits(Width * Height - 1) As Long
iEnd = Width - 1
jEnd = Height - 1
Scan = Width
'-- Render gradient DIB
Select Case GradientDirection
Case [gdHorizontal]
For j = 0 To jEnd
For I = iOffset To iEnd + iOffset
lBits(I) = lGrad(I - iOffset)
Next I
iOffset = iOffset + Scan
Next j
Case [gdVertical]
For j = jEnd To 0 Step -1
For I = iOffset To iEnd + iOffset
lBits(I) = lGrad(j)
Next I
iOffset = iOffset + Scan
Next j
Case [gdDownwardDiagonal]
iOffset = jEnd * Scan
For j = 1 To jEnd + 1
For I = iOffset To iEnd + iOffset
lBits(I) = lGrad(iGrad)
iGrad = iGrad + 1
Next I
iOffset = iOffset - Scan
iGrad = j
Next j