Skip to content

Commit b6322a7

Browse files
joyfullservicejoyfullservice
committed
Implement hybrid module/class import
This takes the approach of loading an initial stub as a class or module through LoadFromText so that the object is created on the Access side, then uses VBE to replace the actual code module so that it can support hidden VBE properties. #236
1 parent 54543d5 commit b6322a7

File tree

4 files changed

+137
-26
lines changed

4 files changed

+137
-26
lines changed

‎Version Control.accda.src/dbs-properties.json

+1-1
Original file line numberDiff line numberDiff line change
@@ -41,7 +41,7 @@
4141
"Type": 10
4242
},
4343
"AppVersion": {
44-
"Value": "3.4.11",
44+
"Value": "3.4.12",
4545
"Type": 10
4646
},
4747
"Auto Compact": {

‎Version Control.accda.src/modules/clsDbModule.cls

+134-22
Original file line numberDiff line numberDiff line change
@@ -17,10 +17,17 @@ Attribute VB_Exposed = False
1717
Option Compare Database
1818
Option Explicit
1919

20+
Private Const ModuleName As String = "clsDbModule"
21+
2022
Private m_Module As VBComponent
2123
Private m_AllItems As Collection
2224
Private m_blnModifiedOnly As Boolean
2325

26+
Private Type udtVbaFileContent
27+
strContent As String
28+
blnIsClass As Boolean
29+
End Type
30+
2431
' This requires us to use all the public methods and properties of the implemented class
2532
' which keeps all the component classes consistent in how they are used in the export
2633
' and import process. The implemented functions should be kept private as they are called
@@ -67,19 +74,51 @@ End Sub
6774
'
6875
Private Sub IDbComponent_Import(strFile As String)
6976

70-
Dim proj As VBProject
77+
Dim strName As String
7178
Dim strTempFile As String
79+
Dim udtFile As udtVbaFileContent
80+
81+
' Only import files with the correct extension.
82+
If Not (strFile Like "*.bas" Or strFile Like "*.cls") Then Exit Sub
83+
84+
' Parse source file
85+
strName = GetObjectNameFromFileName(strFile)
86+
udtFile = ParseSourceFile(strFile, strName)
87+
88+
' Check to see if we have an Access object with this name
89+
If Not ModuleExists(strName) Then ImportModuleStub strName, udtFile.blnIsClass
90+
91+
' Write to a new file using system encoding (converting from UTF-8)
92+
strTempFile = GetTempFile
93+
WriteFile udtFile.strContent, strTempFile, GetSystemEncoding
94+
95+
' Import the source file to the code module
96+
LoadVbeModuleFromFile strTempFile, strName
97+
98+
' Save hash, update the index, and remove the temp file
99+
VCSIndex.Update Me, eatImport, GetCodeModuleHash(IDbComponent_ComponentType, m_Module.Name)
100+
DeleteFile strTempFile
101+
102+
End Sub
103+
104+
105+
'---------------------------------------------------------------------------------------
106+
' Procedure : ParseSourceFile
107+
' Author : Adam Waller
108+
' Date : 7/13/2021
109+
' Purpose : Parse the source file to build VBE content
110+
'---------------------------------------------------------------------------------------
111+
'
112+
Private Function ParseSourceFile(strFile As String, strName As String) As udtVbaFileContent
113+
72114
Dim strLines() As String
115+
Dim strTLine As String
73116
Dim lngLine As Long
74117
Dim cData As clsConcat
75118
Dim blnIsClass As Boolean
76119
Dim blnHasHeader As Boolean
77-
78-
' Only import files with the correct extension.
79-
If Not (strFile Like "*.bas" Or strFile Like "*.cls") Then Exit Sub
80-
81-
' Log performance of file conversion
82-
Perf.OperationStart "Enc. Module as " & GetSystemEncoding
120+
121+
Perf.OperationStart "Parse VBA Module"
83122

84123
' Read file contents into array of lines
85124
strLines = Split(ReadFile(strFile), vbCrLf)
@@ -117,7 +156,7 @@ Private Sub IDbComponent_Import(strFile As String)
117156
.Add " MultiUse = -1 'True"
118157
.Add "END"
119158
End If
120-
.Add "Attribute VB_Name = """, GetObjectNameFromFileName(strFile), """"
159+
.Add "Attribute VB_Name = """, strName, """"
121160
End If
122161

123162
' Add in file contents
@@ -129,33 +168,106 @@ Private Sub IDbComponent_Import(strFile As String)
129168
.Remove 2
130169
End With
131170

132-
' Write to a new file using system encoding (converting from UTF-8)
133-
strTempFile = GetTempFile
134-
With New ADODB.Stream
135-
.Type = adTypeText
136-
.Open
137-
.Charset = GetSystemEncoding
138-
.WriteText cData.GetStr
139-
' Write to disk
140-
.SaveToFile strTempFile, adSaveCreateOverWrite
141-
.Close
171+
' Return values
172+
With ParseSourceFile
173+
.blnIsClass = blnIsClass
174+
.strContent = cData.GetStr
142175
End With
143176

144177
Perf.OperationEnd
145178

146-
' Import the source file
179+
End Function
180+
181+
182+
'---------------------------------------------------------------------------------------
183+
' Procedure : LoadVbeModuleFromFile
184+
' Author : Adam Waller
185+
' Date : 7/12/2021
186+
' Purpose : Load the VBA standard/class module from a file through VBE. (This allows
187+
' : us to preserve hidden attributes not recognized in then LoadFromText
188+
' : import of code modules and classes.)
189+
'---------------------------------------------------------------------------------------
190+
'
191+
Private Sub LoadVbeModuleFromFile(strFile As String, strName As String)
192+
193+
Dim proj As VBProject
194+
195+
If DebugMode(True) Then On Error GoTo 0 Else On Error Resume Next
196+
147197
Set proj = GetVBProjectForCurrentDB
148198
Perf.OperationStart "Import VBE Module"
149-
Set m_Module = proj.VBComponents.Import(strTempFile)
199+
With proj.VBComponents
200+
201+
' Remove any existing component (In most cases the module will exist)
202+
If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
203+
.Remove .Item(strName)
204+
If DebugMode(False) Then On Error GoTo 0 Else On Error Resume Next
205+
206+
' Load from the file
207+
Set m_Module = .Import(strFile)
208+
End With
150209
Perf.OperationEnd
210+
211+
CatchAny eelError, "Error importing VBA code for " & strName, ModuleName & ".LoadVbeModuleFromFile"
151212

152-
' Save hash, update the index, and remove the temp file
153-
VCSIndex.Update Me, eatImport, GetCodeModuleHash(IDbComponent_ComponentType, m_Module.Name)
213+
End Sub
214+
215+
216+
'---------------------------------------------------------------------------------------
217+
' Procedure : ImportModuleStub
218+
' Author : Adam Waller
219+
' Date : 7/12/2021
220+
' Purpose : Import a blank code module as text so it can be loaded into Access before
221+
' : overlaying the content through VBE. (This allows us to use DoCmd.Save to
222+
' : save the code changes, which is not available when a new module is created
223+
' : through a VBE import.
224+
'---------------------------------------------------------------------------------------
225+
'
226+
Private Sub ImportModuleStub(strName As String, blnAsClass As Boolean)
227+
228+
Dim cContent As clsConcat
229+
Dim strTempFile As String
230+
231+
Set cContent = New clsConcat
232+
233+
' Save the template content as a file
234+
strTempFile = GetTempFile
235+
With New clsConcat
236+
.AppendOnAdd = vbCrLf
237+
If blnAsClass Then
238+
.Add "Attribute VB_GlobalNameSpace = False"
239+
.Add "Attribute VB_Creatable = False"
240+
.Add "Attribute VB_PredeclaredId = False"
241+
.Add "Attribute VB_Exposed = False"
242+
End If
243+
.Add "' Stub module for import by MSAccessVCS"
244+
.Add "noncompilingcode 'issue here"
245+
' Load as text without BOM
246+
WriteFile .GetStr, strTempFile, "Windows-1252"
247+
End With
248+
249+
LoadFromText acModule, strName, strTempFile
154250
DeleteFile strTempFile
155251

156252
End Sub
157253

158254

255+
'---------------------------------------------------------------------------------------
256+
' Procedure : ModuleExists
257+
' Author : Adam Waller
258+
' Date : 7/13/2021
259+
' Purpose : Returns true if the module or class exists in the current database
260+
'---------------------------------------------------------------------------------------
261+
'
262+
Private Function ModuleExists(strName As String) As Boolean
263+
Dim objTest As AccessObject
264+
If DebugMode(True) Then On Error Resume Next Else On Error Resume Next
265+
Set objTest = CurrentProject.AllModules(strName)
266+
CatchAny eelNoError, vbNullString, , False
267+
ModuleExists = Not objTest Is Nothing
268+
End Function
269+
270+
159271
'---------------------------------------------------------------------------------------
160272
' Procedure : Merge
161273
' Author : Adam Waller

‎Version Control.accda.src/modules/modFileAccess.bas

+2-2
Original file line numberDiff line numberDiff line change
@@ -88,7 +88,7 @@ End Function
8888
' : is found in the file. https://stackoverflow.com/a/53036838/4121863
8989
'---------------------------------------------------------------------------------------
9090
'
91-
Public Sub WriteFile(strText As String, strPath As String)
91+
Public Sub WriteFile(strText As String, strPath As String, Optional strEncoding As String = "utf-8")
9292

9393
Dim strContent As String
9494
Dim dblPos As Double
@@ -99,7 +99,7 @@ Public Sub WriteFile(strText As String, strPath As String)
9999
With New ADODB.Stream
100100
.Type = adTypeText
101101
.Open
102-
.Charset = "utf-8"
102+
.Charset = strEncoding
103103
.WriteText strText
104104
' Ensure that we are ending the content with a vbcrlf
105105
If Right(strText, 2) <> vbCrLf Then .WriteText vbCrLf

‎Version Control.accda.src/modules/modVCSUtility.bas

-1
Original file line numberDiff line numberDiff line change
@@ -577,4 +577,3 @@ Public Sub CompileAndSaveAllModules()
577577
DoEvents
578578
Perf.OperationEnd
579579
End Sub
580-

0 commit comments

Comments
 (0)