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
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