-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathVbaObjects.cls
315 lines (278 loc) · 10.8 KB
/
VbaObjects.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
311
312
313
314
315
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "VbaObjects"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Base 0
Option Explicit
Private Type ObjectTable
lpX1 As LongPtr ' 0x00
lpProjectInfo As LongPtr ' 0x08
lpSecondaryProjectInfo As LongPtr ' 0x10
Reserved As LongLong ' 0x18
Null1 As LongLong ' 0x20
lp6CC0 As LongPtr ' 0x28
GUID As GUID ' 0x30
CompiledState As Integer ' 0x40
ObjectCount As Integer ' 0x42
CompiledObjects As Integer ' 0x44
ObjectsInUse As Integer ' 0x46
lpPublicObjectDescriptors As LongPtr ' 0x48
ReferenceCount As LongLong ' 0x50
lpReferenceTable As LongPtr ' 0x58
QWord1 As LongLong ' 0x60
lpProjectName As LongPtr ' 0x68 'Pointer to char[]
PrimaryLanguageCodeID As Long ' 0x70
SecondaryLangagueCodeID As Long ' 0x74
Ptr1 As LongPtr ' 0x78
QWord2 As LongLong ' 0x80
QWord3 As LongLong ' 0x88
QWord4 As LongLong ' 0x90
QWord5 As LongLong ' 0x98
QWord6 As LongLong ' 0xA0
QWord7 As LongLong ' 0xA8
QWord8 As LongLong ' 0xB0
QWord9 As LongLong ' 0xB8
End Type
Private Const CLASS_NAME As String = "VbaObjects"
Private mObjectTable As ObjectTable
Private mModules As Scripting.Dictionary
Private mModuleNames() As String
Private mObjectTableSize As Long
Private mProjectName As String
Private mObjectsLoaded As Boolean
Private mOriginalAddress As LongPtr
Implements ILoadedFromAddress
Implements IObjectTableData
Implements IMethodical
Private Sub Class_Initialize()
Const METHOD_NAME = CLASS_NAME & ".Class_Initialize"
On Error GoTo HandleError
mObjectTableSize = LenB(mObjectTable)
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 = "ILoadedFromAddress_LoadFromAddress[" & CLASS_NAME & "]"
On Error GoTo HandleError
mOriginalAddress = lpAddress
LoadObjectTable lpAddress
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 Property Get IObjectTableData_lpProjectInfo() As LongLong
#Else
Private Property Get IObjectTableData_lpProjectInfo() As Long
#End If
Const METHOD_NAME = "IObjectTableData_lpProjectInfo [" & CLASS_NAME & "]"
On Error GoTo HandleError
IObjectTableData_lpProjectInfo = mObjectTable.lpProjectInfo
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 LoadObjectTable(lpAddress As LongPtr)
Const METHOD_NAME = CLASS_NAME & ".LoadObjectTable"
On Error GoTo HandleError
Memory.FollowPointer VarPtr(mObjectTable), lpAddress, mObjectTableSize
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 Modules() As Scripting.Dictionary
Const METHOD_NAME = CLASS_NAME & ".get_Modules"
On Error GoTo HandleError
If mModules Is Nothing Then
Set mModules = New Scripting.Dictionary
mModules.CompareMode = TextCompare
End If
Set Modules = mModules
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 Count() As Long
Const METHOD_NAME = CLASS_NAME & ".get_Count"
On Error GoTo HandleError
Count = mObjectTable.ObjectCount
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 Function GetProjectName() As String
Dim n(0 To 1023) As Byte, l As Long
Const METHOD_NAME = CLASS_NAME & ".GetProjectName"
On Error GoTo HandleError
Memory.FollowPointer VarPtr(n(0)), mObjectTable.lpProjectName, MAX_VBA_OBJECT_NAME_LENGTH
GetProjectName = RTrimNull(VBA.StrConv(n, vbUnicode))
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
Private Property Get IObjectTableData_ProjectName() As String
Const METHOD_NAME = "get_IObjectTableData_ProjectName[" & CLASS_NAME & "]"
On Error GoTo HandleError
If mProjectName = vbNullString Then
mProjectName = GetProjectName()
End If
IObjectTableData_ProjectName = mProjectName
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 Item(Index As Variant) As VbaModule
Dim moduleName As String
Const METHOD_NAME = CLASS_NAME & ".get_Item"
On Error GoTo HandleError
If IsNull(Index) Then
Err.Raise 94, METHOD_NAME
End If
If Not mObjectsLoaded Then Call LoadObjects
If IsNumeric(Index) Then
If CLng(Index) < Count And Index > 0 Then
moduleName = mModuleNames(Index)
End If
Else
moduleName = Index
End If
If Modules.Exists(moduleName) Then
Set Item = Modules(moduleName)
Exit Property
End If
If IsNumeric(Index) Then
Err.Raise 381, METHOD_NAME, "Invalid module specified: the zero-based identifier you specified (" & Index & ") does not exist."
Else
Err.Raise 381, METHOD_NAME, "Invalid module specified: the module name """ & Index & """ could not be found."
End If
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 LoadObjects()
Dim i As Long
Dim thisModule As VbaModule, loader As ILoadedFromAddress
Const METHOD_NAME = CLASS_NAME & ".LoadObjects"
On Error GoTo HandleError
If Count <= 0 Then
mObjectsLoaded = True
Exit Sub
End If
Modules.RemoveAll
ReDim mModuleNames(0 To Count - 1)
For i = 1 To Count
Set thisModule = New VbaModule
Set loader = thisModule
Call loader.LoadFromAddress(mObjectTable.lpPublicObjectDescriptors, i - 1)
mModuleNames(i - 1) = thisModule.Name
Modules.Add mModuleNames(i - 1), thisModule
Next
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 Property Get ILoadedFromAddress_OriginalAddress() As LongLong
#Else
Private Property Get ILoadedFromAddress_OriginalAddress() As Long
#End If
Const METHOD_NAME = "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 = "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"
On Error GoTo HandleError
Dim firstPeriod As Long, callToPass As String, targetObjectName As String
Dim thisModule As VbaModule
firstPeriod = VBA.InStr(1, CallName, ".", vbBinaryCompare)
If firstPeriod <= 0 Then
Err.Raise INVALID_PROCEDURE_CALL_OR_ARGUMENT, METHOD_NAME, "The module name must be specified in calls to GetAddressByName."
Exit Function
End If
targetObjectName = VBA.Left$(CallName, firstPeriod - 1)
On Error GoTo HandleError
Set thisModule = Me.Item(targetObjectName)
callToPass = VBA.Mid$(CallName, firstPeriod + 1)
GetAddressByName = thisModule.GetAddressByName(callToPass)
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