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
| Option Explicit
'Raised when a menu-item created with this class is clicked
Public Event menuClicked(ByVal id As Long)
'Position at the subMenu to add the items to
Private subPos As Long
'Submenu for the new items
Private hMenuTo As Long
'Last menuItem Identifier
Private nId As Long
'Subclass
Private sc As cSubclass 'Subclasser
Implements WinSubHook.iSubclass 'Subclasser interface
'API functions for menus
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 InsertMenuItem Lib "user32" Alias "InsertMenuItemA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, ByRef lpcMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function CreateMenu Lib "user32" () As Long
Private Declare Function CheckMenuItem Lib "user32" (ByVal hMenu As Long, ByVal wIDCheckItem As Long, ByVal wCheck As Long) As Long
'API type for menus
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 String
cch As Long
End Type
'API constant for menus
Private Const MF_STRING = &H0&
Private Const MIIM_TYPE = &H10
Private Const MIIM_ID = &H2
Private Const MIIM_SUBMENU = &H4
Private Const MF_BYCOMMAND = &H0&
Private Const MF_CHECKED = &H8&
Private Const MF_UNCHECKED = &H0&
'Initialize menu-system
Public Sub initSystem(ByVal hWnd As Long, ByVal subMenuPos As Long, ByVal addPos As Long, ByVal firstId As Long)
'Set position at menu to add the items
subPos = addPos
'Set next identifier
nId = firstId
'Get menu
Dim hTmp As Long
hTmp = GetMenu(hWnd)
hMenuTo = GetSubMenu(hTmp, subMenuPos)
'Start subclass
Call sc.Subclass(hWnd, Me)
'Get menu clicks
Call sc.AddMsg(WM_COMMAND, MSG_BEFORE)
End Sub
'Add a menu Item
Public Function addItem(ByVal txt As String, Optional ByVal hTo As Long = -1, Optional ByVal posTo As Long = -1) As Long
'If not specified then add to standard Menu
If hTo = -1 Then
hTo = hMenuTo
End If
'If not specified then add to standard Position
If posTo = -1 Then
posTo = subPos
subPos = subPos + 1
End If
Dim item As MENUITEMINFO
With item
.cbSize = Len(item)
.fMask = MIIM_TYPE Or MIIM_ID
.fType = MF_STRING
.wID = nextId
.dwTypeData = txt
.cch = Len(.dwTypeData)
End With
addItem = item.wID
Call InsertMenuItem(hTo, posTo, True, item)
End Function
'Add an empty submenu
Public Function addSubMenu(ByVal txt As String, ByRef handleOfSub As Long, Optional ByVal hTo As Long = -1, Optional ByVal posTo As Long = -1) As Long
'If not specified then add to standard Menu
If hTo = -1 Then
hTo = hMenuTo
End If
'If not specified then add to standard Position
If posTo = -1 Then
posTo = subPos
subPos = subPos + 1
End If
Dim hSubMenu As Long
hSubMenu = CreateMenu
handleOfSub = hSubMenu
Dim item As MENUITEMINFO
With item
.cbSize = Len(item)
.fMask = MIIM_TYPE Or MIIM_SUBMENU Or MIIM_ID
.fType = MF_STRING
.dwTypeData = txt
.wID = nextId
.cch = Len(.dwTypeData)
.hSubMenu = hSubMenu
End With
addSubMenu = item.wID
Call InsertMenuItem(hTo, posTo, True, item)
End Function
'Check menu item
Public Sub check(ByVal id As Long)
Call CheckMenuItem(hMenuTo, id, MF_BYCOMMAND + MF_CHECKED)
End Sub
'Uncheck menu item
Public Sub uncheck(ByVal id As Long)
Call CheckMenuItem(hMenuTo, id, MF_BYCOMMAND + MF_UNCHECKED)
End Sub
'Return new Id and increase id
Private Function nextId() As Long
nextId = nId
nId = nId + 1
End Function
'Class Initialization
Private Sub Class_Initialize()
Set sc = New cSubclass
End Sub
'Class Termination
Private Sub Class_Terminate()
Set sc = Nothing
End Sub
'Interface to the subclass
Private Sub iSubclass_After(lReturn As Long, ByVal hWnd As Long, ByVal uMsg As WinSubHook.eMsg, ByVal wParam As Long, ByVal lParam As Long)
Call menuClicked("After ", lReturn, hWnd, uMsg, wParam, lParam)
End Sub
'Interface to the subclass
Private Sub iSubclass_Before(bHandled As Boolean, lReturn As Long, hWnd As Long, uMsg As WinSubHook.eMsg, wParam As Long, lParam As Long)
Call menuClicked("Before", lReturn, hWnd, uMsg, wParam, lParam)
End Sub
'Handles messages
Private Sub menuClicked(sWhen As String, lReturn As Long, hWnd As Long, uMsg As WinSubHook.eMsg, wParam As Long, lParam As Long)
If lParam = 0 Then 'Clicked on a menu
RaiseEvent menuClicked(wParam)
End If
End Sub |
:strip_icc():strip_exif()/u/59027/crop643fc1d5bdbb2_cropped.jpg?f=community)
:strip_icc():strip_exif()/u/71967/Grimlock.jpg?f=community)
:strip_exif()/u/51199/Test1.gif?f=community)
:strip_exif()/u/116048/henkflits.gif?f=community)
er is iig genoeg te vinden op internet. en dan zul je deze code weer zien... suc6 ermee 
:strip_icc():strip_exif()/u/6697/gerco-icon.jpg?f=community){kind=icon}
