Skip to content

Commit 3116ef5

Browse files
hilkochilkoc
committed
Code formatting functionality added
1 parent e9cdc04 commit 3116ef5

File tree

4 files changed

+344
-10
lines changed

4 files changed

+344
-10
lines changed

‎README.md

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,8 @@ It will automatically export all your classes and modules to plain text, wheneve
66

77
VbaDeveloper can also import the code again into your excel workbook. This is particularly useful after reverting an earlier commit or after merging branches. When you open an excel workbook it will ask if you want to import the code for that project.
88

9+
A code formatter for VBA is also included. It is implemented in VBA and can be directly run as a macro within the VBA Editor, so you can format your code as you write it. The most convenient way to run it is by opening the immediate window and then typing 'format'. This will format the active codepane.
10+
911
Building the addin
1012
-----------------------
1113

‎src/vbaDeveloper.xlam/Build.bas

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -100,9 +100,9 @@ End Sub
100100

101101
Private Function hasCodeToExport(component As VBComponent) As Boolean
102102
hasCodeToExport = True
103-
If component.CodeModule.CountOfLines <= 2 Then
103+
If component.codeModule.CountOfLines <= 2 Then
104104
Dim firstLine As String
105-
firstLine = Trim(component.CodeModule.Lines(1, 1))
105+
firstLine = Trim(component.codeModule.Lines(1, 1))
106106
'Debug.Print firstLine
107107
hasCodeToExport = Not (firstLine = "" Or firstLine = "Option Explicit")
108108
End If
@@ -126,7 +126,7 @@ Private Sub exportLines(exportPath As String, component As VBComponent)
126126
Dim fso As New Scripting.FileSystemObject
127127
Dim outStream As TextStream
128128
Set outStream = fso.CreateTextFile(fileName, True, False)
129-
outStream.Write (component.CodeModule.Lines(1, component.CodeModule.CountOfLines))
129+
outStream.Write (component.codeModule.Lines(1, component.codeModule.CountOfLines))
130130
outStream.Close
131131
End Sub
132132

@@ -193,17 +193,17 @@ Private Sub checkHowToImport(file As Object)
193193
Dim fileName As String
194194
fileName = file.name
195195
Dim componentName As String
196-
componentName = Left(fileName, InStr(fileName, ".") - 1)
196+
componentName = left(fileName, InStr(fileName, ".") - 1)
197197
If componentName = "Build" Then '"don't remove or import ourself
198198
Exit Sub
199199
End If
200200

201201
If Len(fileName) > 4 Then
202202
Dim lastPart As String
203-
lastPart = Right(fileName, 4)
203+
lastPart = right(fileName, 4)
204204
Select Case lastPart
205205
Case ".cls" ' 10 == Len(".sheet.cls")
206-
If Len(fileName) > 10 And Right(fileName, 10) = ".sheet.cls" Then
206+
If Len(fileName) > 10 And right(fileName, 10) = ".sheet.cls" Then
207207
'import lines into sheet: importLines vbaProjectToImport, file
208208
sheetsToImport.Add componentName, file
209209
Else
@@ -263,7 +263,7 @@ End Sub
263263

264264
Private Sub importLines(vbaProject As VBProject, file As Object)
265265
Dim componentName As String
266-
componentName = Left(file.name, InStr(file.name, ".") - 1)
266+
componentName = left(file.name, InStr(file.name, ".") - 1)
267267
Dim c As VBComponent
268268
If Not componentExists(vbaProject, componentName) Then
269269
'Create a sheet to import this code into. We cannot set the ws.codeName property which is read-only,
@@ -278,8 +278,8 @@ Private Sub importLines(vbaProject As VBProject, file As Object)
278278

279279
' At this point compilation errors may cause a crash, so we ignore those
280280
On Error Resume Next
281-
c.CodeModule.DeleteLines 1, c.CodeModule.CountOfLines
282-
c.CodeModule.AddFromFile file.Path
281+
c.codeModule.DeleteLines 1, c.codeModule.CountOfLines
282+
c.codeModule.AddFromFile file.Path
283283
On Error GoTo 0
284284
End Sub
285285

‎src/vbaDeveloper.xlam/Formatter.bas

Lines changed: 223 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,223 @@
1+
Attribute VB_Name = "Formatter"
2+
Option Explicit
3+
4+
Private Const BEG_SUB = "Sub "
5+
Private Const END_SUB = "End Sub"
6+
Private Const BEG_PB_SUB = "Public Sub "
7+
Private Const BEG_PV_SUB = "Private Sub "
8+
9+
Private Const BEG_FUN = "Function "
10+
Private Const END_FUN = "End Function"
11+
Private Const BEG_PB_FUN = "Public Function "
12+
Private Const BEG_PV_FUN = "Private Function "
13+
14+
Private Const BEG_PROP = "Property "
15+
Private Const END_PROP = "End Property"
16+
Private Const BEG_PB_PROP = "Public Property "
17+
Private Const BEG_PV_PROP = "Private Property "
18+
19+
Private Const BEG_IF = "If "
20+
Private Const END_IF = "End If"
21+
Private Const BEG_WITH = "With "
22+
Private Const END_WITH = "End With"
23+
24+
Private Const BEG_FOR = "For "
25+
Private Const END_FOR = "Next "
26+
Private Const BEG_DOWHILE = "Do While "
27+
Private Const BEG_DOUNTIL = "Do Until "
28+
29+
Private Const BEG_TYPE = "Type "
30+
Private Const END_TYPE = "End Type"
31+
Private Const BEG_PB_TYPE = "Public Type "
32+
Private Const BEG_PV_TYPE = "Private Type "
33+
34+
' Single words that must exactly match the entire line
35+
Private Const ONEWORD_ELSE = "Else"
36+
Private Const BEG_END_ELSEIF = "ElseIf"
37+
Private Const ONEWORD_END_FOR = "Next"
38+
Private Const ONEWORD_END_LOOP = "Loop"
39+
40+
Private Const INDENT = " "
41+
42+
Private words As Dictionary 'Keys are Strings, Value is an Integer indicating change in indentation
43+
Private indentation(0 To 20) As Variant ' Prevent repeatedly building the same strings by looking them up in here
44+
45+
Private Sub initialize()
46+
initializeWords
47+
initializeIndentation
48+
End Sub
49+
50+
Private Sub initializeIndentation()
51+
Dim indentString As String
52+
indentString = ""
53+
Dim i As Integer
54+
For i = 0 To UBound(indentation)
55+
indentation(i) = indentString
56+
indentString = indentString & INDENT
57+
Next
58+
End Sub
59+
60+
Private Sub initializeWords()
61+
Dim w As Dictionary
62+
Set w = New Dictionary
63+
64+
w.Add BEG_SUB, 1
65+
w.Add END_SUB, -1
66+
w.Add BEG_PB_SUB, 1
67+
w.Add BEG_PV_SUB, 1
68+
69+
w.Add BEG_FUN, 1
70+
w.Add END_FUN, -1
71+
w.Add BEG_PB_FUN, 1
72+
w.Add BEG_PV_FUN, 1
73+
74+
w.Add BEG_PROP, 1
75+
w.Add END_PROP, -1
76+
w.Add BEG_PB_PROP, 1
77+
w.Add BEG_PV_PROP, 1
78+
79+
w.Add BEG_IF, 1
80+
w.Add END_IF, -1
81+
w.Add BEG_WITH, 1
82+
w.Add END_WITH, -1
83+
84+
w.Add BEG_FOR, 1
85+
w.Add END_FOR, -1
86+
w.Add BEG_DOWHILE, 1
87+
w.Add BEG_DOUNTIL, 1
88+
89+
w.Add BEG_TYPE, 1
90+
w.Add END_TYPE, -1
91+
w.Add BEG_PB_TYPE, 1
92+
w.Add BEG_PV_TYPE, 1
93+
94+
Set words = w
95+
End Sub
96+
97+
98+
Private Property Get vbaWords() As Dictionary
99+
If words Is Nothing Then
100+
initialize
101+
End If
102+
Set vbaWords = words
103+
End Property
104+
105+
Public Sub format()
106+
'Debug.Print Application.VBE.ActiveCodePane.codeModule.Parent.Name
107+
'Debug.Print Application.VBE.ActiveWindow.caption
108+
formatCode Application.VBE.ActiveCodePane.codeModule
109+
Debug.Print "format"
110+
End Sub
111+
112+
Public Sub testFormatting()
113+
If words Is Nothing Then
114+
initialize
115+
End If
116+
117+
Dim projName As String, moduleName As String
118+
projName = "vbaDeveloper"
119+
moduleName = "Test2"
120+
Dim vbaProject As VBProject
121+
Set vbaProject = Application.VBE.VBProjects(projName)
122+
Dim code As codeModule
123+
Set code = vbaProject.VBComponents(moduleName).codeModule
124+
125+
'removeIndentation code
126+
formatCode code
127+
End Sub
128+
129+
Public Sub formatCode(codeModule As codeModule)
130+
On Error GoTo formatCodeError
131+
Dim lineCount As Integer
132+
lineCount = codeModule.CountOfLines
133+
134+
Dim indentLevel As Integer, nextLevel As Integer, levelChange As Integer
135+
indentLevel = 0
136+
Dim lineNr As Integer
137+
For lineNr = 1 To lineCount
138+
Dim line As String
139+
line = Trim(codeModule.Lines(lineNr, 1))
140+
If Not line = "" Then
141+
If isEqual(ONEWORD_ELSE, line) Or lineStartsWith(BEG_END_ELSEIF, line) Then
142+
levelChange = 1
143+
indentLevel = -1 + indentLevel
144+
ElseIf isLabel(line) Then
145+
levelChange = indentLevel
146+
indentLevel = 0
147+
ElseIf isEqual(ONEWORD_END_FOR, line) Or isEqual(ONEWORD_END_LOOP, line) Then
148+
levelChange = -1
149+
Else
150+
levelChange = indentChange(line)
151+
End If
152+
153+
nextLevel = indentLevel + levelChange
154+
If levelChange = -1 Then
155+
indentLevel = nextLevel
156+
End If
157+
158+
line = indentation(indentLevel) + line
159+
indentLevel = nextLevel
160+
End If
161+
Call codeModule.ReplaceLine(lineNr, line)
162+
Next
163+
Exit Sub
164+
formatCodeError:
165+
Debug.Print "Error while formatting " & codeModule.Parent.name
166+
Debug.Print Err.Number & " " & Err.Description
167+
Debug.Print " on line " & lineNr & ": " & line
168+
Debug.Print "indentLevel: " & indentLevel & " , levelChange: " & levelChange
169+
End Sub
170+
171+
172+
Public Sub removeIndentation(codeModule As codeModule)
173+
Dim lineCount As Integer
174+
lineCount = codeModule.CountOfLines
175+
176+
Dim lineNr As Integer
177+
For lineNr = 1 To lineCount
178+
Dim line As String
179+
line = codeModule.Lines(lineNr, 1)
180+
line = Trim(line)
181+
Call codeModule.ReplaceLine(lineNr, line)
182+
Next
183+
End Sub
184+
185+
Private Function indentChange(ByVal line As String) As Integer
186+
indentChange = 0
187+
Dim w As Dictionary
188+
Set w = vbaWords
189+
190+
If isEqual(line, ONEWORD_END_FOR) Or isEqual(line, ONEWORD_END_LOOP) Then
191+
indentChange = -1 'vbaWords(ONEWORD_END_FOR)
192+
End If
193+
Dim word As String
194+
Dim vord As Variant
195+
For Each vord In w.Keys
196+
word = vord
197+
If lineStartsWith(word, line) Then
198+
indentChange = vbaWords(word)
199+
GoTo hell
200+
End If
201+
Next
202+
hell:
203+
End Function
204+
205+
' Returns true if both strings are equal, ignoring case
206+
Private Function isEqual(first As String, second As String) As Boolean
207+
isEqual = (StrComp(first, second, vbTextCompare) = 0)
208+
End Function
209+
210+
' Returns True if strToCheck begins with begin, ignoring case
211+
Private Function lineStartsWith(begin As String, strToCheck As String) As Boolean
212+
lineStartsWith = False
213+
Dim beginLength As Integer
214+
beginLength = Len(begin)
215+
If Len(strToCheck) >= beginLength Then
216+
lineStartsWith = isEqual(begin, left(strToCheck, beginLength))
217+
End If
218+
End Function
219+
220+
221+
Private Function isLabel(line As String) As Boolean
222+
isLabel = (right(line, 1) = ":")
223+
End Function

0 commit comments

Comments
 (0)