forked from syntax53/Nightmare-Redux
-
Notifications
You must be signed in to change notification settings - Fork 0
/
NMRTask_ctlTaskBar.ctl
3576 lines (3080 loc) · 140 KB
/
NMRTask_ctlTaskBar.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 ctlTaskBar
Alignable = -1 'True
ClientHeight = 345
ClientLeft = 0
ClientTop = 0
ClientWidth = 6840
ScaleHeight = 23
ScaleMode = 3 'Pixel
ScaleWidth = 456
ToolboxBitmap = "NMRTask_ctlTaskBar.ctx":0000
Begin VB.Timer tmrRefresh
Interval = 250
Left = 960
Top = 0
End
Begin VB.Timer FlashTimer
Interval = 300
Left = 0
Top = 0
End
Begin VB.Timer tmrMouse
Interval = 100
Left = 480
Top = 0
End
End
Attribute VB_Name = "ctlTaskBar"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Option Compare Text
' default offsets and widths
Private Const DEFAULT_ITEM_WIDTH As Single = 250
Private Const FIRST_OFFSET As Single = 1
Private Const STANDARD_OFFSET As Single = 3
Private Const ICON_WIDTH As Single = 18
'For Button height
Private m_Task_Height As Integer
'Used to stop multiable building of the
'Private Tmr_Tick As Long
'Private Bol_Checking As Boolean
Private Default_Font_Colour As Long
'
' for drawing (button selection)
Private m_nIndexBeingSelected As Integer
Private m_bInsetSelected As Boolean
Private m_LastMouseOver As Integer
Private m_iLast As Integer
Private m_AvailableHeight As Long
Private m_AvailableWidth As Long
'Becouse I have no idea how the buld process works and I could not stop it moving the f$%king buttons
Private Bol_Refresh As Boolean
'elements linked with icons collection
'updated instantly on every change
Private m_maxCount As Integer
Public m_colIcons As Collection
Attribute m_colIcons.VB_VarMemberFlags = "440"
Public m_colTrayIcons As Collection
Attribute m_colTrayIcons.VB_VarMemberFlags = "440"
Private m_refActive As clsIcon
' for drawing
Private m_cxBorder As Long
Private m_cyBorder As Long
Private m_NoDraw As Boolean
Private m_ClickedMain As Boolean
'and sizing
Private m_nOptimalHeight As Long
Private m_nAlign As AlignConstants
Private m_ActualHeight As Long
Private m_ActualWidth As Long
' tool tips
Private m_strOriginalTooltip As String
Private m_bTooltip As Boolean
' properties
Private m_ForeColor As OLE_COLOR
Private m_BackColor As OLE_COLOR
Private m_RaisedBackColor As OLE_COLOR
Private m_SunkenBackColor As OLE_COLOR
Private m_SelectingBackColor As OLE_COLOR
Public Enum enmStyles
Default = 0
CoolBar = 1
End Enum
Private m_Style As enmStyles
Private m_CoolBarSeparator As Boolean
Private m_ShowActive As Boolean
Private m_ShowTray As Boolean
Private m_ShowMenu As Boolean
Private m_MenuCaption As String
Private m_AutoHide As Boolean
Private m_AutoHideWait As Integer
Private m_AutoHideAnimate As Boolean
Private m_AutoHideAnimateFrames As Integer
Private m_hImageList As Long
Private m_MenuButtonIcon As Long
Private m_MenuButtonWidth As Long
Private m_MenuBarColor As OLE_COLOR
Private m_MenuBarTextColor As OLE_COLOR
Private m_MenuBarText As String
Private m_MenuHighlightColor As OLE_COLOR
Private m_MenuHighlightTextColor As OLE_COLOR
Private m_MenuBackColor As OLE_COLOR
Private m_MenuForeColor As OLE_COLOR
' property defaults
Private Const m_def_ForeColor = vbButtonText
Private Const m_def_BackColor = vbButtonFace
Private Const m_def_RaisedBackColor = vbButtonFace
Private Const m_def_SunkenBackColor = vb3DHighlight
Private Const m_def_SelectingBackColor = vbButtonFace
Private Const m_def_Style = enmStyles.Default
Private Const m_def_CoolBarSeparator = False
Private Const m_def_ShowActive = True
Private Const m_def_ShowTray = False
Private Const m_def_ShowMenu = False
Private Const m_def_MenuCaption = "Start"
Private Const m_def_AutoHide = False
Private Const m_def_AutoHideWait = 1200
Private Const m_def_AutoHideAnimate = False
Private Const m_def_AutoHideAnimateFrames = 50
Private Const m_def_MenuButtonIcon = -1
Private Const m_def_MenuButtonWidth = 80
Private Const m_def_MenuBarColor = vbActiveTitleBar
Private Const m_def_MenuBarTextColor = vbActiveTitleBarText
Private Const m_def_MenuBarText = ""
Private Const m_def_MenuHighlightColor = vbHighlight
Private Const m_def_MenuHighlightTextColor = vbHighlightText
Private Const m_def_MenuBackColor = vbMenuBar
Private Const m_def_MenuForeColor = vbMenuText
' Events
Public Event ChildMinimize(ByVal hWnd As Long, ByVal Caption As String)
Attribute ChildMinimize.VB_Description = "This event is non-functional at the moment."
Public Event ChildMaximize(ByVal hWnd As Long, ByVal Caption As String)
Attribute ChildMaximize.VB_Description = "This event triggers when an MDI Child form is maximized within the MDI Client we are watching."
Public Event ChildRestore(ByVal hWnd As Long, ByVal Caption As String)
Attribute ChildRestore.VB_Description = "This event triggers when an MDI Child form Restores within the MDI Client window we are watching."
Public Event ChildActivate(ByVal hWnd As Long, ByVal Caption As String)
Attribute ChildActivate.VB_Description = "This event fires when a MDI Child form activates within the MDI Client form that we are watching."
Public Event ChildCreate(ByVal hWnd As Long, ByVal Caption As String)
Attribute ChildCreate.VB_Description = "This event triggers when an MDI Child is created within the MDI Client that we are watching."
Public Event ChildDestroy(ByVal hWnd As Long)
Attribute ChildDestroy.VB_Description = "This event triggers when an MDI Child form is closed/unloaded from within the MDI Client we are watching. "
Public Event AutoHide()
Public Event AutoHideShow()
Public Event TrayIconClick(ByVal Button As Integer, ByVal Index As Integer, ByVal Key As String, ByVal ToolTip As String)
Attribute TrayIconClick.VB_Description = "This event is triggered when an item in the tray area is clicked."
Public Event MenuItemClick(ByVal Key As String, ByVal vTag As Variant)
Public Event MenuItemDrawDisabled(ByRef Disabled As Boolean, ByVal Key As String, ByVal vTag As Variant)
Private m_Menu As Long
Public MainMenu As clsMenuItems
Attribute MainMenu.VB_VarMemberFlags = "400"
Private m_MenuItemData As Long
Private m_Main As Long
Private m_FontStyle As StdFont
Public Property Get ButtonFont() As StdFont
'On Error Resume Next
Set ButtonFont = m_FontStyle
End Property
Public Property Set ButtonFont(ByVal Value As StdFont)
Set m_FontStyle = Value
Call PropertyChanged("ButtonFont")
End Property
' all of these Raise* sub's are here so the module can raise
' events on the taskbar.
Public Sub RaiseMenuItemDrawDisabled(ByRef Disabled As Boolean, ByVal Key As String, ByVal vTag As Variant)
On Error GoTo ErrorHandler
RaiseEvent MenuItemDrawDisabled(Disabled, Key, vTag)
Done:
Exit Sub
ErrorHandler:
Dim lngErrNum As Long: Dim strErrDesc As String: lngErrNum = Err.Number: strErrDesc = Err.Description
If InDesign = True Then: Stop: Else: Call HandleError("Class " & TypeName(Me) & "_RaiseMenuItemDrawDisabled" & vbCrLf & "Line# " & Erl & vbCrLf & "Err#" & Err.Number & vbCrLf & "Desc. " & Err.Description, App.Title, "Disabled=" & Disabled)
GoTo Done
End Sub
Public Sub RaiseMenuItemClick(ByVal Key As String, ByVal vTag As Variant)
Attribute RaiseMenuItemClick.VB_MemberFlags = "40"
On Error GoTo ErrorHandler
If Len(Key) > 0 Then
RaiseEvent MenuItemClick(Key, vTag)
End If
Done:
Exit Sub
ErrorHandler:
Dim lngErrNum As Long: Dim strErrDesc As String: lngErrNum = Err.Number: strErrDesc = Err.Description
If InDesign = True Then: Stop: Else: Call HandleError("Class " & TypeName(Me) & "_RaiseMenuItemClick" & vbCrLf & "Line# " & Erl & vbCrLf & "Err#" & Err.Number & vbCrLf & "Desc. " & Err.Description, App.Title, "Key=" & Key)
GoTo Done
End Sub
Public Sub RaiseChildCreate(ByVal hWnd As Long)
Attribute RaiseChildCreate.VB_MemberFlags = "40"
On Error GoTo ErrorHandler
Dim sCaption As String
sCaption = WindowText(hWnd)
RaiseEvent ChildCreate(hWnd, sCaption)
Done:
Exit Sub
ErrorHandler:
Dim lngErrNum As Long: Dim strErrDesc As String: lngErrNum = Err.Number: strErrDesc = Err.Description
If InDesign = True Then: Stop: Else: Call HandleError("Class " & TypeName(Me) & "_RaiseChildCreate" & vbCrLf & "Line# " & Erl & vbCrLf & "Err#" & Err.Number & vbCrLf & "Desc. " & Err.Description, App.Title, "hWnd=" & hWnd)
GoTo Done
End Sub
Public Sub RaiseChildDestroy(ByVal hWnd As Long)
Attribute RaiseChildDestroy.VB_MemberFlags = "40"
On Error GoTo ErrorHandler
RaiseEvent ChildDestroy(hWnd)
Done:
Exit Sub
ErrorHandler:
Dim lngErrNum As Long: Dim strErrDesc As String: lngErrNum = Err.Number: strErrDesc = Err.Description
If InDesign = True Then: Stop: Else: Call HandleError("Class " & TypeName(Me) & "_RaiseChildDestroy" & vbCrLf & "Line# " & Erl & vbCrLf & "Err#" & Err.Number & vbCrLf & "Desc. " & Err.Description, App.Title, "hWnd=" & hWnd)
GoTo Done
End Sub
Public Sub RaiseChildMinimize(ByVal hWnd As Long)
Attribute RaiseChildMinimize.VB_MemberFlags = "40"
On Error GoTo ErrorHandler
Dim sCaption As String
sCaption = WindowText(hWnd)
RaiseEvent ChildMinimize(hWnd, sCaption)
Done:
Exit Sub
ErrorHandler:
Dim lngErrNum As Long: Dim strErrDesc As String: lngErrNum = Err.Number: strErrDesc = Err.Description
If InDesign = True Then: Stop: Else: Call HandleError("Class " & TypeName(Me) & "_RaiseChildMinimize" & vbCrLf & "Line# " & Erl & vbCrLf & "Err#" & Err.Number & vbCrLf & "Desc. " & Err.Description, App.Title, "hWnd=" & hWnd)
GoTo Done
End Sub
Public Sub RaiseChildMaximize(ByVal hWnd As Long)
Attribute RaiseChildMaximize.VB_MemberFlags = "40"
On Error GoTo ErrorHandler
Dim sCaption As String
sCaption = WindowText(hWnd)
RaiseEvent ChildMaximize(hWnd, sCaption)
Done:
Exit Sub
ErrorHandler:
Dim lngErrNum As Long: Dim strErrDesc As String: lngErrNum = Err.Number: strErrDesc = Err.Description
If InDesign = True Then: Stop: Else: Call HandleError("Class " & TypeName(Me) & "_RaiseChildMaximize" & vbCrLf & "Line# " & Erl & vbCrLf & "Err#" & Err.Number & vbCrLf & "Desc. " & Err.Description, App.Title, "hWnd=" & hWnd)
GoTo Done
End Sub
Public Sub RaiseChildRestore(ByVal hWnd As Long)
Attribute RaiseChildRestore.VB_MemberFlags = "40"
On Error GoTo ErrorHandler
Dim sCaption As String
sCaption = WindowText(hWnd)
RaiseEvent ChildRestore(hWnd, sCaption)
Done:
Exit Sub
ErrorHandler:
Dim lngErrNum As Long: Dim strErrDesc As String: lngErrNum = Err.Number: strErrDesc = Err.Description
If InDesign = True Then: Stop: Else: Call HandleError("Class " & TypeName(Me) & "_RaiseChildRestore" & vbCrLf & "Line# " & Erl & vbCrLf & "Err#" & Err.Number & vbCrLf & "Desc. " & Err.Description, App.Title, "hWnd=" & hWnd)
GoTo Done
End Sub
Public Sub RaiseChildActivate(ByVal hWnd As Long)
Attribute RaiseChildActivate.VB_MemberFlags = "40"
On Error GoTo ErrorHandler
Dim sCaption As String
sCaption = WindowText(hWnd)
RaiseEvent ChildActivate(hWnd, sCaption)
Done:
Exit Sub
ErrorHandler:
Dim lngErrNum As Long: Dim strErrDesc As String: lngErrNum = Err.Number: strErrDesc = Err.Description
If InDesign = True Then: Stop: Else: Call HandleError("Class " & TypeName(Me) & "_RaiseChildActivate" & vbCrLf & "Line# " & Erl & vbCrLf & "Err#" & Err.Number & vbCrLf & "Desc. " & Err.Description, App.Title, "hWnd=" & hWnd)
GoTo Done
End Sub
Friend Property Get hWnd() As Long
On Error GoTo ErrorHandler
' this call is simple, it returns the usercontrols hWnd,
' so we can use it in GetParent() API calls in the module
hWnd = UserControl.hWnd
Done:
Exit Property
ErrorHandler:
Dim lngErrNum As Long: Dim strErrDesc As String: lngErrNum = Err.Number: strErrDesc = Err.Description
If InDesign = True Then: Stop: Else: Call HandleError("Class " & TypeName(Me) & "_hWnd" & vbCrLf & "Line# " & Erl & vbCrLf & "Err#" & Err.Number & vbCrLf & "Desc. " & Err.Description, App.Title, "")
GoTo Done
End Property
Friend Sub OnRefresh(Optional ByVal hWndActive As Long = 0)
On Error GoTo ErrorHandler
' we are about to refresh our taskbar
' called only from substitutedWndProc for MDI window
If m_refActive Is Nothing Then
UpdateIconsCollection hWndActive
MapIconCollection
ElseIf hWndActive <> m_refActive.hWnd Then
UpdateIconsCollection hWndActive
MapIconCollection
ElseIf hWndActive = m_refActive.hWnd Then
'// added to fix problem when minimized more then 2 windows
UpdateIconsCollection hWndActive
MapIconCollection
If m_refActive.State = vbMinimized Then
Call ShowWindow(m_refActive.hWnd, SW_HIDE)
End If
'// end minimize fix
If Not m_refActive.Title = WindowText(hWndActive) Then
m_refActive.Title = WindowText(hWndActive)
PaintOne hWndActive
End If
End If
Done:
Exit Sub
ErrorHandler:
Dim lngErrNum As Long: Dim strErrDesc As String: lngErrNum = Err.Number: strErrDesc = Err.Description
If InDesign = True Then: Stop: Else: Call HandleError("Class " & TypeName(Me) & "_OnRefresh" & vbCrLf & "Line# " & Erl & vbCrLf & "Err#" & Err.Number & vbCrLf & "Desc. " & Err.Description, App.Title, "hWndActive=" & hWndActive)
GoTo Done
End Sub
Private Sub FlashTimer_Timer()
On Error GoTo ErrorHandler
' painting whole area
Dim I As Integer
Dim rcItem As RECT
Dim Icn As clsIcon
Dim lEdgeParam As Long
Dim hBrush As Long ' receives handle to the blue hatched brush to use
Dim r As RECT ' rectangular area to fill
Dim lRet As Long ' return value
Dim nDiff As Single
Dim nIconTop As Single
Dim rcIcon As RECT
Dim lpDrawTextParams As DRAWTEXTPARAMS
Dim nTextH As Single
Dim oTest As POINTAPI
Dim oTrayPoint As POINTAPI
Dim vEdge As Variant
Dim oTrayIcon As clsTrayIcon
Dim bRet As Boolean
Dim j As Integer
Dim Font_Color As Long
'Stop the Timer
FlashTimer.Enabled = False
If m_colIcons Is Nothing Or m_NoDraw = True Then
' no buttons, clear the control
UserControl.Cls
Exit Sub
End If
I = 0
' set the colors
UserControl.BackColor = m_BackColor
UserControl.ForeColor = m_ForeColor
lpDrawTextParams.iLeftMargin = 1
lpDrawTextParams.iRightMargin = 1
lpDrawTextParams.iTabLength = 2
lpDrawTextParams.cbSize = 20
I = 0
For Each Icn In m_colIcons
I = I + 1
If Icn.IsFlashing Then
If Icn.FlashOn Then
Icn.FlashOn = False
If Icn.FlashCount >= Icn.SetFlashCount Then
Icn.FlashOn = False
Icn.IsFlashing = False
Icn.FlashCount = 0
End If
Else
Icn.FlashOn = True
Icn.FlashCount = Icn.FlashCount + 1
End If
Else
GoTo NextItem
End If
If Icn Is m_refActive Then
Icn.FlashOn = False
Icn.IsFlashing = False
Icn.FlashCount = 0
'GoTo NextItem
End If
' three states of a push button
If Icn Is m_refActive And m_ShowActive Then
vEdge = EDGE_SUNKEN
UserControl.FontBold = True
hBrush = CreateSolidBrush(TranslateColor(Icn.Selected_BackColour))
' NOT being pushed at the moment
ElseIf Not I = m_nIndexBeingSelected Then
vEdge = EDGE_RAISED
If Icn.IsFlashing And Icn.FlashOn Then
hBrush = CreateSolidBrush(TranslateColor(Icn.FlashColour))
Else
hBrush = CreateSolidBrush(TranslateColor(Icn.Unselected_BackColour))
End If
UserControl.FontBold = False
' being pushed at the moment
Else
vEdge = EDGE_SUNKEN
UserControl.FontBold = False
hBrush = CreateSolidBrush(TranslateColor(m_SelectingBackColor))
End If
If ItemRect(I, rcItem) Then
' draw the edge.
If vEdge <> 0 Then
DrawEdge UserControl.hdc, rcItem, vEdge, BF_RECT
End If
' we selected the right hBrush up above, now use it to
' draw the back color.
lRet = CopyRect(r, rcItem)
r.Bottom = r.Bottom - 2
r.Top = r.Top + 1
r.Left = r.Left + 1
r.Right = r.Right - 2
lRet = FillRect(UserControl.hdc, r, hBrush) ' fill the rectangle using the brush
lRet = DeleteObject(hBrush) ' clean up
' fix the rect to fit inside the new border thats
' been drawn
rcItem.Left = rcItem.Left + m_cxBorder + 1
rcItem.Top = rcItem.Top + m_cyBorder
rcItem.Right = rcItem.Right - m_cxBorder - 1
rcItem.Bottom = rcItem.Bottom - m_cyBorder - 1
' used to calculate the position to draw the icon
nDiff = rcItem.Bottom - rcItem.Top
' draw the icon
' calculate the position to draw the icon
nIconTop = rcItem.Top + (nDiff - ICON_WIDTH) \ 2
If Icn.IconPtr <> 0 Then
DrawIconEx UserControl.hdc, rcItem.Left, nIconTop + 2, Icn.IconPtr, 16, 16, 0, 0, DI_NORMAL
Else
' no icon was returned, so we cant draw anything.
End If
' drawing a text with default font for a control
If Icn.IconPtr <> 0 Then
' has an icon. so add space for it.
rcItem.Left = rcItem.Left + ICON_WIDTH + 2
Else
' no icon, so draw it over to the left.
rcItem.Left = rcItem.Left + 2
End If
lpDrawTextParams.iLeftMargin = 1
lpDrawTextParams.iRightMargin = 1
lpDrawTextParams.iTabLength = 2
lpDrawTextParams.cbSize = 20
' calculate all the dimensions for the rect to
' draw the text in.
GetTextExtentPoint32 UserControl.hdc, Icn.Title, Len(Icn.Title), oTest
nTextH = oTest.y
If nTextH < nDiff Then
nDiff = (nDiff - nTextH) \ 2
rcItem.Bottom = rcItem.Bottom - nDiff
rcItem.Top = rcItem.Top + nDiff
End If
'Set the Font Style.
Set UserControl.Font = m_FontStyle
If Icn.Change_Font_Colour Then
UserControl.ForeColor = Icn.FontColour
Else
UserControl.ForeColor = Default_Font_Colour
End If
' draw the text
DrawTextEx UserControl.hdc, Icn.Title, Len(Icn.Title), rcItem, _
DT_LEFT Or DT_VCENTER Or DT_WORD_ELLIPSIS, lpDrawTextParams
'Set the default colour back to normal
If Icn.Change_Font_Colour Then
UserControl.ForeColor = Default_Font_Colour
End If
End If
j = I + 1
' now if it is CoolBar style, we draw the separator
' line inbetween buttons
If m_colIcons.Count > 1 And j < m_colIcons.Count Then
If m_Style = CoolBar And m_CoolBarSeparator = True Then
If m_nAlign = vbAlignBottom Or m_nAlign = vbAlignTop Then
' draw 2 lines to give it the 3d look.
UserControl.Line (r.Right + 3, r.Top)-(r.Right + 3, r.Bottom), vb3DShadow
UserControl.Line (r.Right + 4, r.Top + 1)-(r.Right + 4, r.Bottom + 1), TranslateColor(m_SunkenBackColor)
ElseIf m_nAlign = vbAlignLeft Or m_nAlign = vbAlignRight Then
UserControl.Line (r.Left, r.Bottom + 3)-(r.Right, r.Bottom + 3), vb3DShadow
UserControl.Line (r.Left, r.Bottom + 4)-(r.Right, r.Bottom + 4), TranslateColor(m_SunkenBackColor)
End If
End If
End If
NextItem:
Next
' draw the tray
If m_ShowTray And (Not m_colTrayIcons Is Nothing) Then
TrayRect rcItem
DrawEdge UserControl.hdc, rcItem, BDR_SUNKENOUTER, BF_RECT
I = -1
For Each oTrayIcon In m_colTrayIcons
I = I + 1
If TrayIconPoint(I, oTrayPoint) Then
If hImageList <> 0 Then
ImageList_DrawEx hImageList, oTrayIcon.Icon, UserControl.hdc, oTrayPoint.x, oTrayPoint.y, 16, 16, CLR_NONE, CLR_DEFAULT, ILD_TRANSPARENT
End If
End If
Next
Set oTrayIcon = Nothing
End If
Done:
DeleteObject hBrush
'Start the Timer
FlashTimer.Enabled = True
Exit Sub
ErrorHandler:
Dim lngErrNum As Long: Dim strErrDesc As String: lngErrNum = Err.Number: strErrDesc = Err.Description
If InDesign = True Then: Stop: Else: Call HandleError("Class " & TypeName(Me) & "_UserControl_Paint" & vbCrLf & "Line# " & Erl & vbCrLf & "Err#" & Err.Number & vbCrLf & "Desc. " & Err.Description, App.Title, "")
GoTo Done
End Sub
'
Private Sub tmrMouse_Timer()
On Error GoTo ErrorHandler
' this timer is used to take away the focus rect, for bars
' that are coolbar style, when the mouse leaves the
' window for the usercontrol.
' On Error Resume Next
Dim oPoint As POINTAPI
Dim lRet As Long
Dim hWnd As Long
Dim I As Integer
Dim lWait As Long
Dim lTemp As Long
Dim iCount As Integer
Static bTest As Boolean
Static iLast As Integer
Static lstart As Long
Static lNow As Long
Static bFirstDone As Boolean
If Not Ambient.UserMode() Then Exit Sub
' get the X and Y of the mouse's current position
lRet = GetCursorPos(oPoint)
hWnd = WindowFromPoint(oPoint.x, oPoint.y)
' get the handle of the window underneath that X and Y
' if its the first time through we have to
' set these up with defaults.
If lstart = 0 And lNow = 0 Then
lstart = GetTickCount()
lNow = lstart
End If
' if the last time we came through this sub
' the hWnd was NOT the same as the usercontrol.hWnd (btest = false)
' AND we havent re-drawn the last mouse'd over
' element (ilast = 1) then redraw it, to clear away
' the mouseover border
If bTest = False And iLast = 1 Then
iLast = 0
If m_Style = CoolBar Then
InvalidateElement m_LastMouseOver
End If
m_iLast = -1
End If
If hWnd = UserControl.hWnd Then
'If UserControl.Ambient.UserMode() Then MsgBox "Showing"
bTest = True
iLast = 1
' handle AutoHide = True
If m_AutoHide Then
' bring it back to size
If m_nAlign = vbAlignBottom Or m_nAlign = vbAlignTop Then
If UserControl.Extender.Height <> m_ActualHeight Then
UserControl.Extender.Height = m_ActualHeight
RaiseEvent AutoHideShow
End If
ElseIf m_nAlign = vbAlignLeft Or m_nAlign = vbAlignRight Then
If UserControl.Extender.Width <> m_ActualWidth Then
UserControl.Extender.Width = m_ActualWidth
RaiseEvent AutoHideShow
End If
End If
' allow the paint to happen now
m_NoDraw = False
End If
Else
'If UserControl.Ambient.UserMode() Then MsgBox "Hiding"
' the gettickcount's are used to time how long they have been off the
' bar, so we can hold off on making the bar hide, for a couple
' seconds.
If bTest = True Then
' get the starting time
lstart = GetTickCount()
bTest = False
Else
' now every loop through, while we are off, get the new time
lNow = GetTickCount()
End If
' handle AutoHide = True
' if lNow is more than m_AutoHideWait AFTER lStart then hide
If Not m_ClickedMain And m_AutoHide And (((lNow - lstart) > m_AutoHideWait) Or bFirstDone = False) Then
' we shrink it down, because they moved the mouse
' outside of the usercontrol
If m_nAlign = vbAlignBottom Or m_nAlign = vbAlignTop Then
If m_AutoHideAnimate And UserControl.Extender.Height <> 75 And m_AutoHideAnimateFrames > 1 Then
' all of this code handles the animation
lTemp = UserControl.Extender.Height \ m_AutoHideAnimateFrames
iCount = m_AutoHideAnimateFrames + 1
Do Until iCount = 1
iCount = iCount - 1
lWait = GetTickCount()
If (lTemp * iCount) < 75 Then
Exit Do
End If
UserControl.Extender.Height = lTemp * iCount
Do Until (GetTickCount() - lWait) > 3
DoEvents
Loop
Loop
End If
UserControl.Extender.Height = 75
RaiseEvent AutoHide
ElseIf m_nAlign = vbAlignLeft Or m_nAlign = vbAlignRight Then
If m_AutoHideAnimate And UserControl.Extender.Width <> 75 And m_AutoHideAnimateFrames > 1 Then
lTemp = UserControl.Extender.Width \ m_AutoHideAnimateFrames
iCount = m_AutoHideAnimateFrames + 1
Do Until iCount = 1
iCount = iCount - 1
lWait = GetTickCount()
If (lTemp * iCount) < 75 Then
Exit Do
End If
UserControl.Extender.Width = lTemp * iCount
Do Until (GetTickCount() - lWait) > 3
DoEvents
Loop
Loop
End If
UserControl.Extender.Width = 75
RaiseEvent AutoHide
End If
' make sure we arent painting, and clear the usercontrol
m_NoDraw = True
' bFirstDone is used to hide the bar initially if autohide
' is turned on
bFirstDone = True
UserControl.Cls
End If
End If
Done:
Exit Sub
ErrorHandler:
Select Case Err.Number
Case 398
Err.Clear
GoTo Done
Case Else
Dim lngErrNum As Long: Dim strErrDesc As String: lngErrNum = Err.Number: strErrDesc = Err.Description
If InDesign = True Then: Stop: Else: Call HandleError("Class " & TypeName(Me) & "_tmrMouse_Timer" & vbCrLf & "Line# " & Erl & vbCrLf & "Err#" & Err.Number & vbCrLf & "Desc. " & Err.Description, App.Title, "")
GoTo Done
End Select
End Sub
Private Sub tmrRefresh_Timer()
Dim Icn As clsIcon
'timer to refresh window titles until keyboard actions are captured
If Not m_colIcons Is Nothing Then
If Not m_NoDraw Then
For Each Icn In m_colIcons
If Not Icn.Title = WindowText(Icn.hWnd) Then
Icn.Title = WindowText(Icn.hWnd)
Call PaintOne(Icn.hWnd)
End If
Next Icn
End If
End If
Set Icn = Nothing
End Sub
Private Sub UserControl_Hide()
' if the usercontrol is going to hide, then we dont want to
' do any of the work we do. so stop it all
If Ambient.UserMode() Then
On Error Resume Next
UnSubClassParentWnd Me
ClearCollection
UserControl.Parent.Arrange vbArrangeIcons
End If
End Sub
Private Sub UserControl_Initialize()
Set MainMenu = New clsMenuItems
Bol_Refresh = True
Default_Font_Colour = UserControl.ForeColor
End Sub
Private Sub UserControl_InitProperties()
If GetParent(Me.hWnd) = 0 Then
' no parent.
Err.Raise 20000, "TaskBar", "TaskBar control may be placed on MDI froms only"
Else
' have a parent. setup default property values
If Ambient.UserMode() Then
ghWnd = GetParent(hWnd)
End If
m_Task_Height = 22 'GetSystemMetrics(SM_CYCAPTION)
m_Style = m_def_Style
m_ForeColor = m_def_ForeColor
m_BackColor = m_def_BackColor
m_RaisedBackColor = m_def_RaisedBackColor
m_SunkenBackColor = m_def_SunkenBackColor
m_SelectingBackColor = m_def_SelectingBackColor
m_CoolBarSeparator = m_def_CoolBarSeparator
m_ShowActive = m_def_ShowActive
m_ShowTray = m_def_ShowTray
m_ShowMenu = m_def_ShowMenu
m_MenuCaption = m_def_MenuCaption
m_AutoHide = m_def_AutoHide
m_AutoHideWait = m_def_AutoHideWait
m_AutoHideAnimate = m_def_AutoHideAnimate
m_AutoHideAnimateFrames = m_def_AutoHideAnimateFrames
m_MenuButtonIcon = m_def_MenuButtonIcon
m_MenuButtonWidth = m_def_MenuButtonWidth
m_MenuBarColor = m_def_MenuBarColor
m_MenuBarTextColor = m_def_MenuBarTextColor
m_MenuBarText = m_def_MenuBarText
m_MenuHighlightColor = m_def_MenuHighlightColor
gMenuHighlight = TranslateColor(m_MenuHighlightColor)
m_MenuHighlightTextColor = m_def_MenuHighlightTextColor
gMenuHighlightText = TranslateColor(m_MenuHighlightTextColor)
m_MenuBackColor = m_def_MenuBackColor
gMenuBackColor = TranslateColor(m_MenuBackColor)
m_MenuForeColor = m_def_MenuForeColor
gMenuForeColor = TranslateColor(m_MenuForeColor)
m_NoDraw = False
m_ClickedMain = False
End If
End Sub
Private Sub UserControl_LostFocus()
' if the usercontrol loses focus, then we
' want to make sure that nothing has the mouseover
' effect still drawn.
Dim I As Integer
If m_colIcons Is Nothing Then Exit Sub
For I = 0 To m_colIcons.Count
InvalidateElement I
Next I
End Sub
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
On Error GoTo ErrorHandler
' mouse down, instant click (button behaviour later)
If Not Ambient.UserMode() Then Exit Sub
Dim oRect As RECT
If Button = vbLeftButton Then
' detect which element and mark it
' set for refreshing (invalidate)
' set capture and wait for release
m_nIndexBeingSelected = ElementFromPoint(x, y)
m_bInsetSelected = (m_nIndexBeingSelected > 0)
If (m_nIndexBeingSelected > 0) Then
' the set capture call just makes sure
' that we receive all the mouse events for our
' process (even if it is over another object)
' until we call the ReleaseCapture event.
' this way we can trap for the mouse up and
' mousemove after a mousedown, even if they
' happen over another part of the application.
SetCapture UserControl.hWnd
InvalidateElement m_nIndexBeingSelected
m_ClickedMain = False
Else
If m_ShowMenu = True Then
If IsPointInMainMenu(x, y) Then
If MainMenuRect(oRect) Then
InvalidateRect UserControl.hWnd, oRect, False
SetCapture UserControl.hWnd
DrawEdge UserControl.hdc, oRect, EDGE_SUNKEN, BF_RECT
m_ClickedMain = True
Else
m_ClickedMain = False
End If
Else
m_ClickedMain = False
End If
End If
End If
End If
Done:
Exit Sub
ErrorHandler:
Dim lngErrNum As Long: Dim strErrDesc As String: lngErrNum = Err.Number: strErrDesc = Err.Description
If InDesign = True Then: Stop: Else: Call HandleError("Class " & TypeName(Me) & "_UserControl_MouseDown" & vbCrLf & "Line# " & Erl & vbCrLf & "Err#" & Err.Number & vbCrLf & "Desc. " & Err.Description, App.Title, "Button=" & Button, "Shift=" & Shift, "x=" & x, "y=" & y)
GoTo Done
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
On Error GoTo ErrorHandler
Dim Icn As clsIcon
Dim I As Integer
Dim bNewStatus As Boolean
Dim nElPointed As Integer
Dim rc As RECT
Dim rcRect As RECT
Dim bDispElement As Boolean
Dim bDispTrayIcon As Boolean
Dim sTrayIconTip As String
Dim oTest As POINTAPI
Dim iIcon As Integer
If Not Ambient.UserMode() Then Exit Sub
If m_nIndexBeingSelected > 0 Then
' moving while item pressed can change state
' of a button originaly pressed
' is the mouse still over the pressed element?
bNewStatus = IsPointInElement(x, y, m_nIndexBeingSelected)
' if the pressed element was one of the task bar buttons
' and the mouse is not over that element anymore, then
' take away the mouseover effect, or put the raised
' edge back so it looks like a butotn again.
If m_bInsetSelected <> bNewStatus Then
m_bInsetSelected = bNewStatus
InvalidateElement m_nIndexBeingSelected
End If
ElseIf Button = 0 Then
' handle the tray
If IsPtInTray(x, y) Then
iIcon = TrayIconFromPoint(x, y)
If (iIcon <> -1 And m_colTrayIcons.Count > 0) Then
If m_colTrayIcons.Item(iIcon + 1).ToolTip <> vbNullString Then
bDispTrayIcon = True
sTrayIconTip = m_colTrayIcons.Item(iIcon + 1).ToolTip
Else
bDispTrayIcon = False
End If
Else
bDispTrayIcon = False
End If
End If
' handle elements
nElPointed = ElementFromPoint(x, y)
If nElPointed > 0 Then
bDispElement = False
' if we are moving around, we want to change
' tooltip text (original one is in use)
'
' the rule is that if we enter a button where text can't
' fit into, we change ToolTipText property
' we also set m_bTooltip flag on just to rember
' to restore original contns later
If ItemRect(nElPointed, rc) Then
If rc.Left + m_cxBorder < x And rc.Right - m_cxBorder > x And _
rc.Top + m_cyBorder <= y And rc.Bottom - m_cyBorder > y Then
' test for the text width.
GetTextExtentPoint32 UserControl.hdc, m_colIcons(nElPointed).Title, Len(m_colIcons(nElPointed).Title), oTest
bDispElement = oTest.x > rc.Right - rc.Left - ICON_WIDTH - 6
' if its using the coolbar style
' it needs to have the mouseover effect.
If m_Style = CoolBar Then
' we use the iLast so we dont keep re-drawing
' it helps with the flicker.
If m_iLast <> nElPointed Then
For I = 0 To m_colIcons.Count
If nElPointed = I Then
DrawEdge UserControl.hdc, rc, EDGE_RAISED, BF_RECT
' this is used for clearing
' the edge from a button, when
' we leave the usercontrol
' with the mouse (mouseout)
m_LastMouseOver = nElPointed
m_iLast = nElPointed
Else
InvalidateElement I
End If
Next I
End If
End If
End If
End If
ElseIf m_bTooltip And Not bDispTrayIcon Then
UserControl.Extender.ToolTipText = m_strOriginalTooltip
m_bTooltip = False
End If
' just setting the right tooltip
If bDispElement Then
If UserControl.Extender.ToolTipText <> m_colIcons(nElPointed).Title Then
UserControl.Extender.ToolTipText = m_colIcons(nElPointed).Title
End If
m_bTooltip = True
ElseIf bDispTrayIcon Then
If UserControl.Extender.ToolTipText <> sTrayIconTip Then
UserControl.Extender.ToolTipText = sTrayIconTip
End If
m_bTooltip = True
ElseIf IsPointInMainMenu(x, y) Then
If UserControl.Extender.ToolTipText <> m_MenuCaption Then
UserControl.Extender.ToolTipText = m_MenuCaption
End If
m_bTooltip = True
ElseIf m_bTooltip Then
UserControl.Extender.ToolTipText = m_strOriginalTooltip
m_bTooltip = False
End If
End If
Done:
Exit Sub
ErrorHandler:
Dim lngErrNum As Long: Dim strErrDesc As String: lngErrNum = Err.Number: strErrDesc = Err.Description
If InDesign = True Then: Stop: Else: Call HandleError("Class " & TypeName(Me) & "_UserControl_MouseMove" & vbCrLf & "Line# " & Erl & vbCrLf & "Err#" & Err.Number & vbCrLf & "Desc. " & Err.Description, App.Title, "Button=" & Button, "Shift=" & Shift, "x=" & x, "y=" & y)
GoTo Done