VBA Code Colors

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

Is there a way to change the color of a couple of lines of code. Each year I
have to search through a lot of code to modify specific lines. I was
wondering if there is a way to change s line or two of code to a different
color (say red), so next year I can scroll through the code and look for the
red lines?

I've looked at the options in the VB Editor but couldn't find a way to
change a line and keep it that color when I re-open the Editor.

Thanks for the help.....Mike
 
You can't change the color of specific lines of code in the editor. You
could mark with comments the code that needs to be changed and search for
those comments when you need to change the code. Better yet, of course,
would be to properly write the code such that it doesn't need to be changed
from one year to the next.


--
Cordially,
Chip Pearson
Microsoft MVP - Excel, 10 Years
Pearson Software Consulting
www.cpearson.com
(email on the web site)
 
Is there a way to change the color of a couple of lines of code. Each year I
have to search through a lot of code to modify specific lines. I was
wondering if there is a way to change s line or two of code to a different
color (say red), so next year I can scroll through the code and look for the
red lines?

I've looked at the options in the VB Editor but couldn't find a way to
change a line and keep it that color when I re-open the Editor.

Thanks for the help.....Mike
Click to expand...

I can't say if this is proper coding but normal I'll box in parts so I
can easily find them. ie


'====================================================

write code in here

'====================================================
 
this isn't a free solution, maybe something like this would help. you could
print to a pdf and use it for a reference


http://www.starprint2000.com/product_vbacodeprint.aspx


http://submain.com/?nav=products.pcp

Color Schemes a.. Quick way to switch the colors for syntax highlighting,
you can choose predefined
b.. Default scheme for color printer
c.. Scheme for B&W printer
d.. Standard VB IDE colors
e.. You can even import your current color scheme from VB IDE
 
Another, trivial way is to convert the code, module by module, into the text
file, where it can be deliberately colored. It may be also a proper backup,
because it is again retransportable by parts back in the modules.
 
I totally agree with Chip.

Somehow your code has some problems if you have to change it every
year.
As a workaround, you could also put the values you need to change in a
sheet, protect it with a password and hide it, and then refer to that
sheet in your code.

If you want to keep it in your code do something like that:

'UpdateCodeHere---------------------------------------------------------------------------------------------
which is followed by your code.

then you can press ctrl+f and search the whole project (checkbox) for
"UpdateCode".

hth

Carlo
 
I totally agree with Chip.

Somehow yourcodehas some problems if you have to change it every
year.
As a workaround, you could also put the values you need to change in a
sheet, protect it with a password and hide it, and then refer to that
sheet in yourcode.

If you want to keep it in yourcodedo something like that:

'UpdateCodeHere---------------------------------------------------------------------------------------------
which is followed by yourcode.

then you can press ctrl+f and search the whole project (checkbox) for
"UpdateCode".

hth

Carlo
Click to expand...

Have thought of using a Script Control (msscript.ocx) or similar to
replace this altering logic with a piece of static code with calls
your own customised scripts?
I find it very handy for using with financial formulas which can
change each year.

Regards,

Kev K
 
If this doesn't cover it, then I made my a code formatting user
control for viewing VBScript, though it can be easily changed to suit
your needs.

You just need to create a new user control with a Rich Text Box on it
(called txtScriptContents), then use the following code.
Note, CUSTOM_KEYWORDS is specific to my code, but can be replaced with
the keywords that you require.

Cheers,

Kev K

'---------------------------------------------------------------------------------------
' Module : ucCodeText
' DateTime : 28 May 2005
' Author : Kevin Kitchen
' Purpose : Contains the functionality for displaying formatted code
'
' This code is free to copy and use, but if using this code, please do
not remove the
' author comments as this is my intellectual property
'
' If you are fixing bugs in this code and feeling charitable please
also send the changes
' to me at:
' kevkitchen AT G MAIL DOT COM (changed to avoid address harvesters,
but you get the drift)
'---------------------------------------------------------------------------------------
Private Const MODULE_NAME = "ucCodeText"

Option Explicit

Private m_bFormatScriptOnChange As Boolean

Private Const VBS_KEYWORDS =
":addhandler:addressof:andalso:alias:and:ansi:as:assembly:attribute:auto:"
& _

"begin:boolean:byref:byte:byval:call:case:catch:cbool:cbyte:cchar:cdate:"
& _

"cdec:cdbl:char:cint:class:clng:cobj:compare:const:continue:cshort:csng:"
& _

"cstr:ctype:currency:date:decimal:declare:default:delegate:dim:do:double:"
& _

"each:else:elseif:end:enum:erase:error:event:exit:explicit:false:finally:"
& _

"for:friend:function:get:gettype:global:gosub:goto:handles:if:implement:"
& _

"implements:imports:in:inherits:integer:interface:is:let:lib:like:load:"
& _

"long:loop:lset:me:mid:mod:module:mustinherit:mustoverride:mybase:myclass:"
& _

"namespace:new:next:not:nothing:notinheritable:notoverridable:object:on:"
& _

"option:optional:or:orelse:overloads:overridable:overrides:paramarray:"
& _

"preserve:private:property:protected:public:raiseevent:readonly:redim:rem:"
& _

"removehandler:rset:resume:return:select:set:shadows:shared:short:single:"
& _

"static:step:stop:string:structure:sub:synclock:then:throw:to:true:try:"
& _

"type:typeof:unload:unicode:until:variant:wend:when:while:with:withevents:"
& _
"writeonly:"

Private Const CUSTOM_KEYWORDS =
":ScriptStart:Sleep:ExitNumber:LastExitNumber:Quit:" & _
"NTUserName:LogDebugMessage:KillProcess:Shell:AppActivate:"

' Comment (Green), Keyword (Blue), String (Teal), Custom Keyword
(Reddish-Brown)
Private Const RTF_COLOUR_TABLE = "{\colortbl;" & _
"\red0\green128\blue0;" & _
"\red0\green0\blue255;" & _
"\red0\green128\blue128;" & _
"\red128\green64\blue0;}"

Private Const RTF_FONT_TABLE = "{\fonttbl{\f0\fnil\fcharset0 Courier
New;}"

'Event Declarations:
Event Click()
'MappingInfo=txtScriptContents,txtScriptContents,-1,Click
Event DblClick()
'MappingInfo=txtScriptContents,txtScriptContents,-1,DblClick
Event KeyDown(KeyCode As Integer, Shift As Integer)
'MappingInfo=txtScriptContents,txtScriptContents,-1,KeyDown
Event KeyPress(KeyAscii As Integer)
'MappingInfo=txtScriptContents,txtScriptContents,-1,KeyPress
Event KeyUp(KeyCode As Integer, Shift As Integer)
'MappingInfo=txtScriptContents,txtScriptContents,-1,KeyUp
Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As
Single) 'MappingInfo=txtScriptContents,txtScriptContents,-1,MouseDown
Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As
Single) 'MappingInfo=txtScriptContents,txtScriptContents,-1,MouseMove
Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As
Single) 'MappingInfo=txtScriptContents,txtScriptContents,-1,MouseUp
Event Change()
'MappingInfo=txtScriptContents,txtScriptContents,-1,Change
Event SelChange()
'MappingInfo=txtScriptContents,txtScriptContents,-1,SelChange
Event Validate(Cancel As Boolean)
'MappingInfo=txtScriptContents,txtScriptContents,-1,Validate



Private Sub UserControl_GotFocus()
Call txtScriptContents.SetFocus
End Sub

Private Sub UserControl_Initialize()
txtScriptContents.Move 0, 0, UserControl.Width, UserControl.Height
End Sub

'---------------------------------------------------------------------------------------
' Procedure : txtScriptContents_Change
' DateTime : 26 May 2007
' Author : Kevin Kitchen
' Purpose :
'---------------------------------------------------------------------------------------
Private Sub txtScriptContents_Change()
On Error GoTo ErrorHandler

Const PROCEDURE_NAME = "txtScriptContents_Change"

Dim lPostition As Long

If m_bFormatScriptOnChange Then
lPostition = txtScriptContents.SelStart

FormatScript

txtScriptContents.SelStart = lPostition
m_bFormatScriptOnChange = False
End If

RaiseEvent Change

Exit Sub
ErrorHandler:
End Sub

'---------------------------------------------------------------------------------------
' Procedure : txtScriptContents_KeyDown
' DateTime : 26 May 2007
' Author : Kevin Kitchen
' Purpose :
'---------------------------------------------------------------------------------------
Private Sub txtScriptContents_KeyDown(KeyCode As Integer, Shift As
Integer)
On Error GoTo ErrorHandler

Const PROCEDURE_NAME = "txtScriptContents_KeyDown"

Select Case KeyCode
Case 96 To 105 ' Numeric Keypad
m_bFormatScriptOnChange = False
Case 48 To 57 ' Normal numbers
If Shift = 0 Then ' No shift alteration
m_bFormatScriptOnChange = True
Else
m_bFormatScriptOnChange = False
End If
Case 65 To 90 ' Alpha keys
m_bFormatScriptOnChange = True
Case Else
m_bFormatScriptOnChange = False
End Select

RaiseEvent KeyDown(KeyCode, Shift)

Exit Sub
ErrorHandler:
End Sub

Private Sub txtScriptContents_Validate(Cancel As Boolean)
Call FormatScript
RaiseEvent Validate(Cancel)
End Sub

Private Sub UserControl_Resize()
txtScriptContents.Move 0, 0, UserControl.Width, UserControl.Height
End Sub
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=txtScriptContents,txtScriptContents,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
BackColor = txtScriptContents.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
txtScriptContents.BackColor() = New_BackColor
PropertyChanged "BackColor"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=txtScriptContents,txtScriptContents,-1,Enabled
Public Property Get Enabled() As Boolean
Enabled = txtScriptContents.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
txtScriptContents.Enabled() = New_Enabled
PropertyChanged "Enabled"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=txtScriptContents,txtScriptContents,-1,Font
Public Property Get Font() As Font
Set Font = txtScriptContents.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
Set txtScriptContents.Font = New_Font
PropertyChanged "Font"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=txtScriptContents,txtScriptContents,-1,Refresh
Public Sub Refresh()
txtScriptContents.Refresh
End Sub

Private Sub txtScriptContents_Click()
RaiseEvent Click
End Sub

Private Sub txtScriptContents_DblClick()
RaiseEvent DblClick
End Sub

Private Sub txtScriptContents_KeyPress(KeyAscii As Integer)
RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub txtScriptContents_KeyUp(KeyCode As Integer, Shift As
Integer)
RaiseEvent KeyUp(KeyCode, Shift)
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=txtScriptContents,txtScriptContents,-1,Locked
Public Property Get Locked() As Boolean
Locked = txtScriptContents.Locked
End Property

Public Property Let Locked(ByVal New_Locked As Boolean)
txtScriptContents.Locked() = New_Locked
PropertyChanged "Locked"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=txtScriptContents,txtScriptContents,-1,MaxLength
Public Property Get MaxLength() As Long
MaxLength = txtScriptContents.MaxLength
End Property

Public Property Let MaxLength(ByVal New_MaxLength As Long)
txtScriptContents.MaxLength() = New_MaxLength
PropertyChanged "MaxLength"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=txtScriptContents,txtScriptContents,-1,MouseIcon
Public Property Get MouseIcon() As Picture
Set MouseIcon = txtScriptContents.MouseIcon
End Property

Public Property Set MouseIcon(ByVal New_MouseIcon As Picture)
Set txtScriptContents.MouseIcon = New_MouseIcon
PropertyChanged "MouseIcon"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=txtScriptContents,txtScriptContents,-1,MousePointer
Public Property Get MousePointer() As MousePointerConstants
MousePointer = txtScriptContents.MousePointer
End Property

Public Property Let MousePointer(ByVal New_MousePointer As
MousePointerConstants)
txtScriptContents.MousePointer() = New_MousePointer
PropertyChanged "MousePointer"
End Property

Private Sub txtScriptContents_SelChange()
RaiseEvent SelChange
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=txtScriptContents,txtScriptContents,-1,SelPrint
Public Sub SelPrint(ByVal lHDC As Long, Optional ByVal vStartDoc As
Variant)
txtScriptContents.SelPrint lHDC, vStartDoc
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=txtScriptContents,txtScriptContents,-1,Text
Public Property Get Text() As String
Text = txtScriptContents.Text
End Property

Public Property Let Text(ByVal New_Text As String)
m_bFormatScriptOnChange = True
txtScriptContents.Text() = New_Text
PropertyChanged "Text"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=txtScriptContents,txtScriptContents,-1,ToolTipText
Public Property Get ToolTipText() As String
ToolTipText = txtScriptContents.ToolTipText
End Property

Public Property Let ToolTipText(ByVal New_ToolTipText As String)
txtScriptContents.ToolTipText() = New_ToolTipText
PropertyChanged "ToolTipText"
End Property

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

txtScriptContents.BackColor = PropBag.ReadProperty("BackColor",
&H80000005)
txtScriptContents.Enabled = PropBag.ReadProperty("Enabled", True)
Set txtScriptContents.Font = PropBag.ReadProperty("Font",
Ambient.Font)
txtScriptContents.HideSelection =
PropBag.ReadProperty("HideSelection", True)
txtScriptContents.Locked = PropBag.ReadProperty("Locked", False)
txtScriptContents.MaxLength = PropBag.ReadProperty("MaxLength", 0)
Set MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing)
txtScriptContents.MousePointer =
PropBag.ReadProperty("MousePointer", 0)
txtScriptContents.Text = PropBag.ReadProperty("Text", "txtCode")
txtScriptContents.ToolTipText =
PropBag.ReadProperty("ToolTipText", "")
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

Call PropBag.WriteProperty("BackColor",
txtScriptContents.BackColor, &H80000005)
Call PropBag.WriteProperty("Enabled", txtScriptContents.Enabled,
True)
Call PropBag.WriteProperty("Font", txtScriptContents.Font,
Ambient.Font)
Call PropBag.WriteProperty("HideSelection",
txtScriptContents.HideSelection, True)
Call PropBag.WriteProperty("Locked", txtScriptContents.Locked,
False)
Call PropBag.WriteProperty("MaxLength",
txtScriptContents.MaxLength, 0)
Call PropBag.WriteProperty("MouseIcon", MouseIcon, Nothing)
Call PropBag.WriteProperty("MousePointer",
txtScriptContents.MousePointer, 0)
Call PropBag.WriteProperty("Text", txtScriptContents.Text,
"txtCode")
Call PropBag.WriteProperty("ToolTipText",
txtScriptContents.ToolTipText, "")
End Sub

'---------------------------------------------------------------------------------------
' Procedure : FormatScript
' DateTime : 26 May 2007
' Author : Kevin Kitchen
' Purpose : Formats the current script contents
'---------------------------------------------------------------------------------------
Private Sub FormatScript()
On Error GoTo ErrorHandler

Const PROCEDURE_NAME = "FormatScript"

Dim sScript As String
Dim sLines() As String
Dim lLineIndex As Long
Dim sNewScript As String
Dim sScriptLine As String

txtScriptContents.Text = vbNewLine & txtScriptContents.Text '
Should also remove formatting

sScript = Replace(txtScriptContents.TextRTF, Chr$(10), Chr$(13))
sScript = Replace(sScript, Chr$(13) & Chr$(13), Chr$(13))

sLines = Split(sScript, Chr$(13))

For lLineIndex = LBound(sLines) To UBound(sLines)
If (Left$(sLines(lLineIndex), 4) = "\par") Then
sScriptLine = Right$(sLines(lLineIndex),
Len(sLines(lLineIndex)) - 5)
sNewScript = sNewScript & FormatLine(sScriptLine) & _
"\par "
End If
Next lLineIndex

sNewScript = "{\rtf1\ansi\deff0" & RTF_COLOUR_TABLE &
RTF_FONT_TABLE & "}" & vbNewLine & _
"\viewkind4\uc1\pard\lang6153\f0\fs17
" & sNewScript

txtScriptContents.TextRTF = sNewScript

Exit Sub
ErrorHandler:
End Sub


'---------------------------------------------------------------------------------------
' Procedure : FormatLine
' DateTime : 26 May 2007
' Author : Kevin Kitchen
' Purpose : Formats a VBScript line and adds formatting
'---------------------------------------------------------------------------------------
Private Function FormatLine(ByVal p_sScriptLine As String) As String
Dim bInComment As Boolean
Dim bInString As Boolean
Dim bInWord As Boolean
Dim lSectionStart As Long
Dim lLineIndex As Long
Dim sNewLine As String
Dim sCurrentChar As String * 1
Dim lSectionLength As Long
Dim sSectionContents As String

Dim sScriptLineLeft As String
Dim sScriptLineRight As String

On Error GoTo ErrorHandler

Const PROCEDURE_NAME = "FormatLine"

p_sScriptLine = p_sScriptLine & " "
For lLineIndex = 1 To Len(p_sScriptLine)
sCurrentChar = Mid$(p_sScriptLine, lLineIndex, 1)
Select Case sCurrentChar
Case "'"
If bInWord Then
lSectionLength = lLineIndex - lSectionStart
bInWord = False
sSectionContents = Mid$(p_sScriptLine,
lSectionStart, lSectionLength)
sNewLine = sNewLine & FormatWord(sSectionContents)
End If
If Not bInString Then
bInComment = True
lSectionLength = Len(p_sScriptLine) - lLineIndex
sSectionContents = RTrim$(Mid$(p_sScriptLine,
lLineIndex, lSectionLength))
sNewLine = sNewLine & "{\cf1 " & sSectionContents
& "}"
Exit For
End If
Case """"
If bInString Then
bInString = False
lSectionLength = lLineIndex - lSectionStart
sSectionContents = Mid$(p_sScriptLine,
lSectionStart, lSectionLength + 1)
sNewLine = sNewLine & "{\cf3 " & sSectionContents
& "}"
Else
If bInWord Then
lSectionLength = lLineIndex - lSectionStart
bInWord = False
sSectionContents = Mid$(p_sScriptLine,
lSectionStart, lSectionLength)
sNewLine = sNewLine &
FormatWord(sSectionContents)
End If
bInString = True
lSectionStart = lLineIndex
End If
Case "a" To "z", "A" To "Z", "0" To "9"
If Not (bInWord Or bInComment Or bInString) Then
bInWord = True
lSectionStart = lLineIndex
End If
Case Else
If Not bInString Then
If bInWord Then
lSectionLength = lLineIndex - lSectionStart
bInWord = False
sSectionContents = Mid$(p_sScriptLine,
lSectionStart, lSectionLength)
sNewLine = sNewLine &
FormatWord(sSectionContents)
End If

sNewLine = sNewLine & sCurrentChar
lSectionStart = lLineIndex
End If
End Select
Next lLineIndex

If bInString Then ' We are in an unclosed string, so close it
bInString = False
lSectionLength = Len(p_sScriptLine) - lSectionStart
sSectionContents = Trim$(Mid$(p_sScriptLine, lSectionStart,
lSectionLength + 1))
sNewLine = sNewLine & "{\cf3 " & sSectionContents & "}"
End If

FormatLine = RTrim$(sNewLine)

Exit Function
ErrorHandler:
End Function

'---------------------------------------------------------------------------------------
' Procedure : FormatWord
' DateTime : 26 May 2007
' Author : Kevin Kitchen
' Purpose : Formats control words
'---------------------------------------------------------------------------------------
Private Function FormatWord(ByVal p_sWord As String) As String
On Error GoTo ErrorHandler

Const PROCEDURE_NAME = "FormatWord"

Dim sFormattedWord As String
Dim sWordSearch As String

sWordSearch = ":" & p_sWord & ":"

If InStr(1, VBS_KEYWORDS, sWordSearch, vbTextCompare) > 0 Then
sFormattedWord = "{\cf2 " & p_sWord & "}"
ElseIf InStr(1, CUSTOM_KEYWORDS, sWordSearch, vbTextCompare) > 0
Then
sFormattedWord = "{\cf4 " & p_sWord & "}"
Else
sFormattedWord = p_sWord
End If

FormatWord = sFormattedWord

Exit Function
ErrorHandler:
End Function
 
Back
Top