Results 1 to 6 of 6

Print out vba module with color highlighting

This is a discussion on Print out vba module with color highlighting within the Excel Questions forums, part of the Question Forums category; Win7, XL2007 Could not find any free code for printing out code modules in color, so I wrote one. For ...

  1. #1
    New Member
    Join Date
    Sep 2012
    Location
    Texas
    Posts
    25

    Smile Print out vba module with color highlighting

    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

  2. #2
    New Member
    Join Date
    Jun 2007
    Posts
    4

    Default Re: Print out vba module with color highlighting

    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.

  3. #3
    New Member
    Join Date
    Jun 2007
    Posts
    4

    Thumbs up Re: Print out vba module with color highlighting

    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.

  4. #4
    New Member
    Join Date
    Sep 2012
    Location
    Texas
    Posts
    25

    Smile Re: Print out vba module with color highlighting

    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.

    Quote Originally Posted by WmColwell View Post
    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.

  5. #5
    New Member
    Join Date
    Jun 2013
    Posts
    1

    Thumbs up Re: Print out vba module with color highlighting

    Quote Originally Posted by WaltzAir View Post
    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 !

  6. #6
    New Member
    Join Date
    Sep 2012
    Location
    Texas
    Posts
    25

    Default Re: Print out vba module with color highlighting

    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.

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  


DMCA.com