Print out vba module with color highlighting

WaltzAir

New Member
Joined
Sep 19, 2012
Messages
33
Win7, XL2007
Could not find any free code for printing out code modules in color, so I wrote one.
For anyone else who needs a simple highlighter, here is one: (code follows)

Option Compare Text
Sub Highlight_Code()
'
' comments are highlighted in green, italics, and font size 8
' text string literals are highlighted in brown and italics
' procedure (Sub, Function) statements are bolded and double-underlined
' end statements are highlighted in red; End Sub font size 12 and bolded
' call keyword is double-underlined
' program flow keywords are single-underlined (Goto, On Error, Exit)
' loop init keywords are highlighted in blue; loop end keywords in red
' conditional keywords are highlighted in blue
'
' keywords embedded in named variables may produce unintended highlighting
'
Dim J As Integer, LineIn As String, EndofCode As Integer, MaxL As Integer
Dim Asterisk As String, Ampersand As String, Quote As String, Txt As String
Dim Ap As Integer, Apostrophe As String, Co As Integer, Colon As String
Dim Hi As Integer, L As Integer, Response As Integer, CodeName As String
Dim Literal As Range, FirstAddr As String, LQ As Integer, RQ As Integer
Dim Zm As Integer
'
' *** USER ACTION REQUIRED: select and copy code to blank workbook beforehand ***
' *** sheet containing code must be active, and code must be in column A ***
' *** Cell B1 should contain default file name for prefix-labeling printout ***
'
Application.ScreenUpdating = False
'
On Error GoTo Tidy
'
Quote = Chr(34)
Ampersand = Chr(38)
Apostrophe = Chr(39)
Asterisk = Chr(42)
Colon = Chr(58)
Txt = Quote & Asterisk & Quote
EndofCode = ActiveSheet.UsedRange.Rows.Count
'
With ActiveWorkbook.Styles("Normal").Font ' necessary for width determinations
.Name = "Courier New"
.Size = 10
.Bold = False
.Italic = False
.Underline = xlUnderlineStyleNone
.Strikethrough = False
.ThemeColor = 2
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
'
ActiveSheet.Columns(1).ClearFormats ' clears all
ActiveSheet.Columns(1).Font.Underline = xlUnderlineStyleSingle ' well, almost all
ActiveSheet.Columns(1).Font.Underline = xlUnderlineStyleNone ' clears partials
ActiveSheet.Columns(1).Font.ColorIndex = 0 ' clears colors
ActiveSheet.Columns(1).Font.Name = "Courier New" ' non-proportional
ActiveSheet.Columns(1).Font.Size = 10 ' width reasonable
'
'
For J = 1 To EndofCode
'
LineIn = ActiveSheet.Cells(J, 1).Value
L = Len(LineIn)
If L > MaxL Then MaxL = L ' keep track of maximum line length for printing
'
' **** mark subs and functions ****
'
Hi = InStr(1, LineIn, "Sub ")
If Hi = 1 Or (Hi > 0 And Left(LineIn, 1) = "P") Then ' Public or Private prefix
Cells(J, 1).Font.Bold = True
Cells(J, 1).Font.Underline = xlUnderlineStyleDouble ' major distinction
End If
'
Hi = InStr(1, LineIn, "Function ")
If Hi = 1 Or (Hi > 0 And Left(LineIn, 1) = "P") Then ' Public or Private prefix
Cells(J, 1).Font.Bold = True
Cells(J, 1).Font.Underline = xlUnderlineStyleDouble ' major distinction
End If
'
Hi = InStr(1, LineIn, "End Sub")
If Hi = 1 Then
Cells(J, 1).Font.Bold = True
Cells(J, 1).Font.Size = 12 ' extra highlighting for major separation
Cells(J, 1).Font.ColorIndex = 3 ' red
End If
'
Hi = InStr(1, LineIn, "End Function")
If Hi = 1 Then
Cells(J, 1).Font.Bold = True
Cells(J, 1).Font.Size = 12 ' extra highlighting for major separation
Cells(J, 1).Font.ColorIndex = 3 ' red
End If
'
' **** mark program flow keywords ****
'
Hi = InStr(1, LineIn, "Call ") ' double underline for extra code distinction
If Hi Then Cells(J, 1).Characters(Hi, 4).Font.Underline = xlUnderlineStyleDouble
'
Hi = InStr(1, LineIn, " Goto ")
If Hi Then Cells(J, 1).Characters(Hi + 1, 4).Font.Underline = xlUnderlineStyleSingle
'
Hi = InStr(1, LineIn, "On Error ")
If Hi Then Cells(J, 1).Characters(Hi, 8).Font.Underline = xlUnderlineStyleSingle
'
Hi = InStr(1, LineIn, "Resume ")
If Hi Then Cells(J, 1).Characters(Hi, 6).Font.Underline = xlUnderlineStyleSingle
'
Hi = InStr(1, LineIn, "Exit")
If Hi Then Cells(J, 1).Characters(Hi, 4).Font.Underline = xlUnderlineStyleSingle
'
' **** mark conditionals end keywords ****
'
Hi = InStr(1, LineIn, "Resume Next")
If Hi = 0 Then Hi = InStr(1, LineIn, "Next") Else Hi = 0
If Hi Then Cells(J, 1).Characters(Hi, 4).Font.ColorIndex = 3 ' red
'
Hi = InStr(1, LineIn, "Loop")
If Hi Then Cells(J, 1).Characters(Hi, 4).Font.ColorIndex = 3 ' red
'
Hi = InStr(1, LineIn, "Wend")
If Hi Then Cells(J, 1).Font.ColorIndex = 3 ' red
'
Hi = InStr(1, LineIn, "End While")
If Hi Then Cells(J, 1).Font.ColorIndex = 3 ' red
'
Hi = InStr(1, LineIn, "End Select")
If Hi Then Cells(J, 1).Font.ColorIndex = 3 ' red
'
Hi = InStr(1, LineIn, "End If")
If Hi Then Cells(J, 1).Font.ColorIndex = 3 ' red
'
Hi = InStr(1, LineIn, "End With")
If Hi Then Cells(J, 1).Font.ColorIndex = 3 ' red
'
Hi = InStr(1, LineIn, "End Function")
If Hi Then Cells(J, 1).Font.ColorIndex = 3 ' red
'
Hi = InStr(1, LineIn, "End Sub")
If Hi Then Cells(J, 1).Font.ColorIndex = 3 ' red
'
Co = InStr(1, LineIn, Colon)
If Co = L Then
Cells(J, 1).Font.Underline = xlUnderlineStyleSingle
Cells(J, 1).Font.ColorIndex = 0
End If
'
' **** mark conditionals start keywords ****
'
Hi = InStr(1, LineIn, "If ")
If Hi Then Cells(J, 1).Characters(Hi, 2).Font.ColorIndex = 5 ' blue
'
Hi = InStr(1, LineIn, "Else")
If Hi Then Cells(J, 1).Characters(Hi, 4).Font.ColorIndex = 5 ' blue
'
Hi = InStr(1, LineIn, "For ")
If Hi Then Cells(J, 1).Characters(Hi, 3).Font.ColorIndex = 5 ' blue
'
Hi = InStr(1, LineIn, "With ")
If Hi Then Cells(J, 1).Characters(Hi, 4).Font.ColorIndex = 5 ' blue
'
Hi = InStr(1, LineIn, "Case ")
If Hi Then Cells(J, 1).Characters(Hi, 4).Font.ColorIndex = 5 ' blue
'
Hi = InStr(1, LineIn, "Select ")
If Hi > 1 Then
If Mid(LineIn, Hi - 1, 1) <> "." Then _
Cells(J, 1).Characters(Hi, 6).Font.ColorIndex = 5 ' blue
End If
'
Hi = InStr(1, LineIn, "ElseIf ")
If Hi Then Cells(J, 1).Characters(Hi, 6).Font.ColorIndex = 5 ' blue
'
Hi = InStr(1, LineIn, "Do ")
If Hi Then Cells(J, 1).Characters(Hi, 2).Font.ColorIndex = 5 ' blue
'
Hi = InStr(1, LineIn, "While ")
If Hi Then Cells(J, 1).Characters(Hi, 5).Font.ColorIndex = 5 ' blue
'
Hi = InStr(1, LineIn, "Until ")
If Hi Then Cells(J, 1).Characters(Hi, 5).Font.ColorIndex = 5 ' blue
'
Hi = InStr(1, LineIn, "Each ")
If Hi Then Cells(J, 1).Characters(Hi, 4).Font.ColorIndex = 5 ' blue
'
Hi = InStr(1, LineIn, "Then")
If Hi Then Cells(J, 1).Characters(Hi, 4).Font.ColorIndex = 5 ' blue
'
Hi = InStr(1, LineIn, "Switch")
If Hi Then Cells(J, 1).Characters(Hi, 4).Font.ColorIndex = 5 ' blue
'
Hi = InStr(1, LineIn, "Choose")
If Hi Then Cells(J, 1).Characters(Hi, 4).Font.ColorIndex = 5 ' blue
'
Hi = InStr(1, LineIn, "Iif")
If Hi Then Cells(J, 1).Characters(Hi, 4).Font.ColorIndex = 5 ' blue
'
' **** mark text and comments ****
'
Ap = InStr(1, LineIn, Apostrophe) ' find comments, color & italicize text
If Ap = 1 Then
Cells(J, 1).Characters(Ap, L - Ap + 1).Font.Size = 8
Cells(J, 1).Characters(Ap, L - Ap + 1).Font.ColorIndex = 10 ' dark green
Cells(J, 1).Characters(Ap, L - Ap + 1).Font.Italic = True ' comments
End If
If Ap > 1 Then
If Mid(LineIn, Ap - 1, 1) = " " Then
Cells(J, 1).Characters(Ap, L - Ap + 1).Font.Size = 8
Cells(J, 1).Characters(Ap, L - Ap + 1).Font.ColorIndex = 10 ' dark green
Cells(J, 1).Characters(Ap, L - Ap + 1).Font.Italic = True ' comments
End If
End If
' text
Set Literal = Range("A" & J).Find(What:=Txt, LookIn:=xlValues, Lookat:=xlPart)
If Not Literal Is Nothing Then
RQ = 0
FindQ:
LQ = InStr(RQ + 1, LineIn, Quote)
If LQ = 0 Then GoTo NoQ
RQ = InStr(LQ + 1, LineIn, Quote)
Cells(J, 1).Characters(LQ, RQ - LQ + 1).Font.ColorIndex = 53 ' brown
Cells(J, 1).Characters(LQ, RQ - LQ + 1).Font.Italic = True
Cells(J, 1).Characters(LQ, RQ - LQ + 1).Font.Size = 10
GoTo FindQ
End If
NoQ:
'
Next J
'
' **** set up for printing ****
'
Zm = 100 ' no wrapping as-is
If MaxL < 160 Then
ActiveSheet.Columns(1).ColumnWidth = MaxL + 1
ActiveSheet.Columns(1).WrapText = False
If MaxL > 122 Then Zm = 123 * 100 / MaxL ' scale down moderate max widths
Else
ActiveSheet.Columns(1).ColumnWidth = 122 ' cannot avoid wrapping any wider
ActiveSheet.Columns(1).WrapText = True
End If
:)
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Waltz- Thanks for this fantastic macro. Was starting to document a recent project and this help greatly. The font effects make this SO readable.

BTW the label "Tidy" in the ON ERROR statement is undefined.
 
Upvote 0
Waltz- Thanks for this fantastic macro. Was starting to document a recent project and this help greatly. The font effects make this SO readable.

BTW the label "Tidy" in the ON ERROR statement is undefined.
 
Upvote 0
The label must have truncated. It's just at the end of the macro with an Application.ScreenUpdating = True statement before the End Sub.
Glad you found it useful.

Waltz- Thanks for this fantastic macro. Was starting to document a recent project and this help greatly. The font effects make this SO readable.

BTW the label "Tidy" in the ON ERROR statement is undefined.
 
Upvote 0
The label must have truncated. It's just at the end of the macro with an Application.ScreenUpdating = True statement before the End Sub.
Glad you found it useful.

It is the first time that I take the time to register to a site only to post a thank you note. This is what I call a nice gesture to the community to share your code.

I must include codes in our Admin Manuals and therefore, fot the readability, I took the time to color the code...

You will save me precious time !
 
Upvote 0
Sharing like this saves us all precious time. I am thankful for the code that I have garnered from other generous people.
Your note is appreciated. Feedback is rare, and I am remiss in doing likewise.
 
Upvote 0

Forum statistics

Threads
1,213,485
Messages
6,113,931
Members
448,533
Latest member
thietbibeboiwasaco

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top