-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathVbaModule.cls
310 lines (279 loc) · 11.9 KB
/
VbaModule.cls
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
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "VbaModule"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Private Type PublicObjectDescriptor
lpObjectInfo As LongPtr ' 0x00
Reserved1 As LongLong ' 0x08
lpPublicVariableIntegers As LongPtr ' 0x10
lpStaticVariableIntegers As LongPtr ' 0x18
lpDataPublicVariables As LongPtr ' 0x20
lpDataStaticVariables As LongPtr ' 0x28
lpModuleName As LongPtr ' 0x30 'Pointer to char[]
MethodCount As LongLong ' 0x38
lpMethodNamePtrArray As LongPtr ' 0x40 'Array of pointers to char[]
OffsetToStaticVariables As Long ' 0x48
Flags As Long ' 0x4C
Null1 As Long ' 0x50
End Type
Private Type ObjectInfo
ReferenceCount As Integer ' 0x00
ObjectIndex As Integer ' 0x02
DWord1 As Long ' 0x04
lpObjectTable As LongPtr ' 0x08
Ptr1 As LongPtr ' 0x10
Ptr2 As LongPtr ' 0x18
QWord1 As LongLong ' 0x20
QWord2 As LongLong ' 0x28
lpPublicObjectDescriptor As LongPtr ' 0x30 'Points directly to the object descriptor itself
Ptr3 As LongPtr ' 0x38
MethodCount As Integer ' 0x40
MethodCount2 As Integer ' 0x42 'Potentially unreliable?
DWord2 As Long ' 0x44
lpMethodInfoPointers As LongPtr ' 0x48 'Array of pointers to MethodInfo structures
Word1 As Integer ' 0x50 'Constants in constant pool?
Word2 As Integer ' 0x52 'Constants to allocate in constant pool?
DWord3 As Long ' 0x54
Ptr4 As LongPtr ' 0x58
Ptr5 As LongPtr ' 0x60
QWord3 As LongLong ' 0x68
QWord4 As LongLong ' 0x70
QWord5 As LongLong ' 0x78
QWord6 As LongLong ' 0x80
Ptr6 As LongPtr ' 0x88
End Type
Private mOriginalAddress As LongPtr
Private mOriginalObjectInfoAddress As LongPtr
Private mObjectInfo As ObjectInfo
Private mPublicObjectDescriptor As PublicObjectDescriptor
Private mObjectInfoSize As Long
Private mPublicObjectDescriptorSize As Long
Private mModuleName As String
Private mMethodData As Scripting.Dictionary
Private Const CLASS_NAME As String = "VbaModule"
Implements ILoadedFromAddress
Implements IMethodical
Private Sub Class_Initialize()
'Alas that we can't use a static class variable.
Const METHOD_NAME As String = CLASS_NAME & ".Class_Initialize"
On Error GoTo HandleError
mObjectInfoSize = LenB(mObjectInfo)
mPublicObjectDescriptorSize = LenB(mPublicObjectDescriptor)
Set mMethodData = New Scripting.Dictionary
mMethodData.CompareMode = TextCompare
Exit Sub
HandleError:
If Err.Source <> METHOD_NAME Then
Err.Raise Err.Number, METHOD_NAME & "." & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
Else
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End If
End Sub
#If Win64 Then
Private Sub ILoadedFromAddress_LoadFromAddress(ByVal lpAddress As LongLong, Optional Index As Long = 0)
#Else
Private Sub ILoadedFromAddress_LoadFromAddress(ByVal lpAddress As Long, Optional Index As Long = 0)
#End If
Const METHOD_NAME As String = "get_ILoadedFromAddress_LoadFromAddress[" & CLASS_NAME & "]"
On Error GoTo HandleError
Call LoadPublicObjectDescriptor(lpAddress + (Index * mPublicObjectDescriptorSize))
Exit Sub
HandleError:
If Err.Source <> METHOD_NAME Then
Err.Raise Err.Number, METHOD_NAME & "." & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
Else
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End If
End Sub
Private Property Get MethodData() As Scripting.Dictionary
Const METHOD_NAME As String = CLASS_NAME & ".get_MethodData"
On Error GoTo HandleError
If MethodCount <> mMethodData.Count Then
'Lazy loading again!
LoadMethods
End If
Set MethodData = mMethodData
Exit Property
HandleError:
If Err.Source <> METHOD_NAME Then
Err.Raise Err.Number, METHOD_NAME & "." & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
Else
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End If
End Property
Private Sub LoadMethods()
Const METHOD_NAME As String = CLASS_NAME & ".LoadMethods"
On Error GoTo HandleError
Dim i As Long
Dim methodName As String
Dim methodAddress As LongPtr
Dim namePointers() As LongPtr
Dim addressPointers() As LongPtr
Dim n(0 To MAX_VBA_OBJECT_NAME_LENGTH - 1) As Byte
If MethodCount <= 0 Then Exit Sub
ReDim namePointers(0 To MethodCount - 1)
ReDim addressPointers(0 To MethodCount - 1)
Memory.FollowPointer VarPtr(namePointers(0)), mPublicObjectDescriptor.lpMethodNamePtrArray, POINTER_SIZE * MethodCount
Memory.FollowPointer VarPtr(addressPointers(0)), mObjectInfo.lpMethodInfoPointers, POINTER_SIZE * MethodCount
With mMethodData
.RemoveAll
For i = 1 To MethodCount
Memory.FollowPointer VarPtr(n(0)), namePointers(i - 1), MAX_VBA_OBJECT_NAME_LENGTH
mMethodData.Add (RTrimNull(VBA.StrConv(n, vbUnicode))), addressPointers(i - 1)
Next
End With
Exit Sub
HandleError:
If Err.Source <> METHOD_NAME Then
Err.Raise Err.Number, METHOD_NAME & "." & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
Else
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End If
End Sub
Private Sub LoadPublicObjectDescriptor(lpAddress As LongPtr)
Const METHOD_NAME As String = CLASS_NAME & ".LoadPublicObjectDescriptor"
On Error GoTo HandleError
Dim n(0 To 1023) As Byte
mOriginalAddress = lpAddress
Memory.FollowPointer VarPtr(mPublicObjectDescriptor), lpAddress, mPublicObjectDescriptorSize
With mPublicObjectDescriptor
Memory.FollowPointer VarPtr(n(0)), .lpModuleName, MAX_VBA_OBJECT_NAME_LENGTH
mModuleName = RTrimNull(VBA.StrConv(n, vbUnicode))
If .Reserved1 <> -1 Then '&HFFFFFFFF in x86, &HFFFFFFFFFFFFFFFF in x64
'Invalid POD. - Always -1
GoTo InvalidObjectInfo
ElseIf .MethodCount < 0 Or .MethodCount > &H100 Then
'Invalid POD - Max methods allowed is 255 (&HFF)
GoTo InvalidObjectInfo
End If
Call LoadObjectInfo(.lpObjectInfo)
' Error handling in LoadObjectInfo ensures that this won't be loaded if it's invalid.
End With
Exit Sub
InvalidObjectInfo:
Exit Sub
HandleError:
If Err.Source <> METHOD_NAME Then
Err.Raise Err.Number, METHOD_NAME & "." & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
Else
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End If
End Sub
Public Property Get MethodCount() As Long
Const METHOD_NAME As String = CLASS_NAME & ".get_MethodCount"
On Error GoTo HandleError
MethodCount = mObjectInfo.MethodCount: Exit Property
HandleError:
If Err.Source <> METHOD_NAME Then
Err.Raise Err.Number, METHOD_NAME & "." & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
Else
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End If
End Property
Public Property Get Name() As String
Const METHOD_NAME As String = CLASS_NAME & ".get_Name"
On Error GoTo HandleError
Name = mModuleName: Exit Property
HandleError:
If Err.Source <> METHOD_NAME Then
Err.Raise Err.Number, METHOD_NAME & "." & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
Else
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End If
End Property
Private Sub LoadObjectInfo(lpAddress As LongPtr)
Const METHOD_NAME As String = CLASS_NAME & ".LoadObjectInfo"
On Error GoTo HandleError
Memory.FollowPointer VarPtr(mObjectInfo), lpAddress, mObjectInfoSize
'Validate the objects
With mObjectInfo
Debug.Assert .lpPublicObjectDescriptor = mOriginalAddress
If .lpPublicObjectDescriptor <> mOriginalAddress Then
GoTo InvalidObject
Exit Sub
End If
Debug.Assert .MethodCount = mPublicObjectDescriptor.MethodCount
End With
mOriginalObjectInfoAddress = lpAddress
Exit Sub
HandleError:
mOriginalObjectInfoAddress = 0
mPublicObjectDescriptor.lpObjectInfo = 0
If Err.Source <> METHOD_NAME Then
Err.Raise Err.Number, METHOD_NAME & "." & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
Else
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End If
Exit Sub
InvalidObject:
mOriginalObjectInfoAddress = 0
mPublicObjectDescriptor.lpObjectInfo = 0
End Sub
#If Win64 Then
Private Property Get ILoadedFromAddress_OriginalAddress() As LongLong
#Else
Private Property Get ILoadedFromAddress_OriginalAddress() As Long
#End If
Const METHOD_NAME As String = "get_ILoadedFromAddress_OriginalAddress[" & CLASS_NAME & "]"
On Error GoTo HandleError
ILoadedFromAddress_OriginalAddress = mOriginalAddress: Exit Property
HandleError:
If Err.Source <> METHOD_NAME Then
Err.Raise Err.Number, METHOD_NAME & "." & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
Else
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End If
End Property
#If Win64 Then
Private Function IMethodical_GetAddressByName(CallName As String) As LongLong
#Else
Private Function IMethodical_GetAddressByName(CallName As String) As Long
#End If
Const METHOD_NAME As String = "get_IMethodical_GetAddressByName[" & CLASS_NAME & "]"
On Error GoTo HandleError
IMethodical_GetAddressByName = Me.GetAddressByName(CallName)
Exit Function
HandleError:
If Err.Source <> METHOD_NAME Then
Err.Raise Err.Number, METHOD_NAME & "." & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
Else
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End If
End Function
Public Function GetAddressByName(CallName As String) As LongPtr
Const METHOD_NAME As String = CLASS_NAME & ".GetAddressByName"
' If a two-part name is specified, verify that the first part _
matches this module name, then look for the final piece. _
If not, search as is.
Dim firstPeriod As Long, callToPass As String
firstPeriod = VBA.InStr(1, CallName, ".", vbBinaryCompare)
If firstPeriod > 0 Then
If VBA.Left$(CallName, firstPeriod - 1) <> Me.Name Then
Err.Raise INVALID_PROCEDURE_CALL_OR_ARGUMENT, METHOD_NAME, "The specified call name to the object " & Me.Name & " was invalid (" & CallName & ").", Err.HelpFile, Err.HelpContext
Exit Function
End If
callToPass = VBA.Mid$(CallName, firstPeriod + 1)
Else
callToPass = CallName
End If
On Error GoTo HandleError
If MethodData.Exists(callToPass) Then
GetAddressByName = MethodData.Item(callToPass)
Exit Function
End If
On Error GoTo 0
Err.Raise INVALID_PROCEDURE_CALL_OR_ARGUMENT, METHOD_NAME, "Method, function, or procedure not found.", Err.HelpFile, Err.HelpContext
Exit Function
HandleError:
If Err.Source <> METHOD_NAME Then
Err.Raise Err.Number, METHOD_NAME & "." & Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
Else
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End If
End Function