Here is a module “Invisible Basic”, writen by John C. Gunther, that identifies procedures in modules. From there on, they can be ported.
' Invisible Basic: A utility for the obfuscation of VBA code
' in Excel Workbooks. See the Invisible Basic User's Guide
' (InvisibleBasic.html) for a detailed description of why
' this is useful.
'
' Copyright (c) 2005, John C. Gunther.
' All rights reserved.
'
' Redistribution and use in source and binary forms, with
' or without modification, are permitted provided that the
' following conditions are met:
'
' - Redistributions of source code must retain the above
' copyright notice, this list of conditions and the following
' disclaimer.
'
' - Redistributions in binary form must reproduce the above
' copyright notice, this list of conditions and the following
' disclaimer in the documentation and/or other materials
' provided with the distribution
'
' - Neither the name of the Invisible Basic Consortium nor
' the names of its contributors may be used to endorse or
' promote products derived from this software without
' specific prior written permission.
'
' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
' CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED
' WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
' WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
' PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
' COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
' INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
' DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
' SUBSTITURE GOODS OR SERVICES; LOSS OF USE, DATA, OR
' PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
' ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
' LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
' ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
' IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
'
' Note: the licence conditions above were copied from the
' BSD open source license template available at
' http://www.opensource.org.licenses/bsd-license.php.
'
Option Explicit
Public Const INVISIBLE_BASIC_VERSION As Double = 3#
Public Const INVISIBLE_BASIC_URL As String = "http://invisiblebasic.sourceforge.net"
' Token types: as a program's source code is scanned, it is
' separated into a stream of tokens each with one of these
' types:
Private Const TT_IDENTIFIER As Integer = 1 'variable names, keywords, etc.
Private Const TT_STRING As Integer = 2 ' string literal ("myString")
Private Const TT_NUMBER As Integer = 3 ' numerical literal (1.23)
Private Const TT_COMMENT As Integer = 4 ' VBA comment text
Private Const TT_WHITESPACE As Integer = 5 ' space or tab
Private Const TT_GUID As Integer = 6 ' global universal identifier
' ({C62A69F0-16DC-11CE-9E98-00AA00574A4F})
Private Const TT_OTHER As Integer = 7 ' everything else
' Name of the file that contains the list of visible (not obfuscated)
' Excel/VBA keywords, reserved Excel object model names, etc.
Private Const IB_VISIBLE_KEYWORDS_FILENAME = "visible_names.txt"
' establish classes of characters helpful in tokenization:
Private Const alphaChars As String = "abcdefghijklmnopqrstuvwxyz"
Private Const underscore As String = "_"
Private Const digits As String = "0123456789"
Private Const dQuote As String = """"
Private Const GUID_START As String = "{" ' "Global Universal ID"
Private Const GUID_END As String = "}" ' (occurs in UserForm headers)
' Note: by including underscore as whitespace, parsing of continued
' lines (ending in " _") is facilitated. VBA does not allow identifiers to begin with
' underscores, so this does not cause ambiguities with the lexical
' analysis of identifiers.
Private Const wsChars As String = " " & vbTab & vbNewLine & underscore
Private Const firstNumericChars As String = digits
Private Const numericChars As String = firstNumericChars & "."
Private Const firstCommentChar As String = "'"
Private Const doubleComment As String = firstCommentChar & firstCommentChar
Private Const line_continuation_chars As String = " " & underscore
Private Const firstIdentifierChars As String = alphaChars
Private Const identifierChars As String = alphaChars & underscore & digits
' e.g. in the event procedure myButton_Click, "_" delimits the
' control name from the event name:
Private Const userform_event_delimiter As String = underscore
' if this character preceeds an indentifier within visible_names.txt, it flags
' that identifier as a userform control attribute.
Private Const userform_control_attribute_flag As String = underscore
Private Const object_attribute_delimiter As String = "." 'object attribute delimiter (e.g. the "." in myLabel.Caption)
' These keywords, when encountered in source code, are
' recognized by Invisible Basic as directives that define if
' identifiers will be obfucated ("invisible") or retained as is
' ("visible")
Private Const VISIBLE_KEYWORD As String = "#visible" ' for single lines
' for delimiting visible blocks:
Private Const BEGIN_VISIBLE_KEYWORD As String = "#begin_visible"
Private Const END_VISIBLE_KEYWORD As String = "#end_visible"
' this is added to the end of the workbook file name to get
' the default new, obfuscated, workbook's filename (e.g.
' myWorkbook.xls becomes saved invisibly, if user accepts
' the initial default name, as myWorkbook_ib.xls):
Private Const IB_FILENAME_SUFFIX As String = "_ib.xls"
' invisible basic overwrites this file without confirmation, so using
' the .tmp (temporary file) file type is essential.
Private Const IB_SECRET_DECODER_SUFFIX As String = "_secretDecoder.tmp"
' depth of #begin_visible ... #end_visible nesting:
Private m_visible_depth As Long
' returned when a specified identifier isn't found:
Private Const NO_SUCH_ID As String = ""
' lists of names that will remain in original format
' (visible), and of those that will be obuscated (made invisible)
Private visible_names As New Collection
Private invisible_names As New Collection
' lists of userform attribute names; userform attributes are used to
' identify userform control names either 1) via their use in event
' procedure names (e.g. the Click attribute identifies myButton as a
' control name in the event procedure myButton_Click) or 2) via the
' direct use of the attribute in code (e.g., the Caption attribute
' identifies myLabel as a control name in the code line:
' myLabel.Caption = "myLable Caption"). Such control names are
' automatically declared as "visible names" by Invisible Basic,
' and not obfuscated.
'
' Why do we even need this, you ask. Unlike most VBA variables,
' UserForm control names are NOT defined in the source code; because I
' could not figure out how to change these (non-source defined) names
' programmatically, I instead must be sure they are NOT changed in the
' source code (or else names would get out of synch, breaking the
' UserForm). Hence the need for these special "visible attribute"
' rules to recognize such control names.
'
' Pre 2.0 versions didn't have this feature, and thus required manual
' user intervention to declare such control names visible.
Private userform_attribute_names As New Collection
' if True, each obfuscated final code line will be preceeded with
' a comment containing the original, unobfuscated, line
' it came from (for trouble-shooting).
Private m_interleave_original_code_as_comments As Boolean
Private Const IB_NameOfInvisibleBasicMenu As String = "Invisible&Basic"
' Excel menu on which the Invisible Basic menu is placed:
Private Const IB_NameOfExcelWorksheetMenubar As String = _
"Worksheet Menu Bar"
Private Const IB_TEMP_FILENAME_PREFIX = "InvBas_Temp_" ' example temp filename: InvBas_Temp_1.tmp
' these declarations are used only by the visit_url function,
' used by the help command to open the Help file. Help command
' only works on Windows platforms.
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function ShellExecute Lib "shell32" _
Alias "ShellExecuteA" _
(ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Private Const SW_SHOWNORMAL As Long = 1
Private Const SW_SHOWMAXIMIZED As Long = 3
Private Const SW_SHOWDEFAULT As Long = 10
' end of declarations for visit_url
' These constants (sans the "IB_" prefix) are defined in the
' Microsoft Visual Basic for Applications Extensibility Library.
' So that users do not have to add a reference to that library, we
' define copies of those constants here. Another reason for doing this
' is that there can be more than one of these libraries on a single
' machine, and if a reference to the wrong version is employed, the
' code breaks with a rather cryptic "type mismatch" error (the type of
' VBComponent used by Excel differs from the type used by the
' VBComponent in the Extensibility library if the extensibility
' library is from a newer version of Excel)
' If (as seems very unlikely) Microsoft ever changes these constants,
' these lines would have to be changed.
Private Const IB_vbext_ct_StdModule As Long = 1
Private Const IB_vbext_ct_ClassModule As Long = 2
Private Const IB_vbext_ct_MSForm As Long = 3
Private Const IB_vbext_ct_Document As Long = 100
' End of Microsoft VBA Extensibility library constants
' circular buffer of recently seen tokens (facilitates
' recognition of userform control names):
Private Const N_BUFFERED_TOKENS As Integer = 3
Private prevTokens(0 To N_BUFFERED_TOKENS - 1) As String
Private tokenIndex As Integer
' These are used for encoding name, value pairs into VB collections
Private Const NAME_ID As Integer = 1 ' represent the offsets into an array storing name, value pair
Private Const VALUE_ID As Integer = 2 ' (VB collections will not allow you to store user defined types)
Private Function PS() As String ' e.g. a "\" on Windows
PS = Application.PathSeparator
End Function
Public Property Get interleave_original_code_as_comments() As Boolean
interleave_original_code_as_comments = m_interleave_original_code_as_comments
End Property
Public Property Let interleave_original_code_as_comments(original_code_as_comments As Boolean)
m_interleave_original_code_as_comments = original_code_as_comments
End Property
' VBA within Excel 97 lacks "Debug.Assert". For compatibility with
' all major Excel versions, we therefore emulate it:
Private Sub assert(condition As Boolean)
If (Not condition) Then Stop
End Sub
' Does an old-style "Rem" comment begin at the specified position in the string?
'
' Note: Rem is a keyword, and thus cannot be used as a variable name
' in compilable VBA code--this fact simplifies the test below.
Private Function isRemComment(s As String, iStart As Integer) As Boolean
isRemComment = ("rem" = LCase(Trim(Mid(s, iStart, Len("rem ")))))
End Function
' Returns integer type of a token assumed to start at give
' position in the given string
' Note: Invisible Basic's lexical analysis is, by design, very simple
' and suitable only for this code obfuscation task. For example, the
' "E" in scientific notation numeric literals will be treated like a
' variable that is always visible (e.g. 1.2E10 is analyzed as the number
' 1.2, the always-visible name E, and the number 10). It all comes out OK in
' the end, but just be aware that the string of tokens seen by
' Invisible Basic is NOT the same as what Visual Basic sees.
Private Function token_type(s As String, _
iStart As Integer) As Integer
Dim c As String
Dim result As Integer
assert 1 <= iStart And iStart <= Len(s)
c = LCase(Mid(s, iStart, 1))
If (InStr(1, wsChars, c) <> 0) Then
result = TT_WHITESPACE
ElseIf (firstCommentChar = c Or isRemComment(s, iStart)) Then
' this branch must preceed identifier branch or "Rem" comments will look like identifiers
result = TT_COMMENT
ElseIf (InStr(1, firstIdentifierChars, c) <> 0) Then
result = TT_IDENTIFIER
ElseIf (c = dQuote) Then
result = TT_STRING
ElseIf (c = GUID_START) Then
result = TT_GUID
ElseIf (InStr(1, firstNumericChars, c) <> 0) Then
result = TT_NUMBER
Else
result = TT_OTHER
End If
token_type = result
End Function
' Returns the string position 1 character past the end of the
' token that starts at the given position in the given string.
Private Function end_of_token(s As String, _
iStart As Integer) As Integer
Dim iEnd As Integer
Dim tt As Integer
Dim matchChars As String
Dim invertMatch As Boolean
Dim matched As Boolean
Dim c As String
tt = token_type(s, iStart)
Select Case (tt)
Case TT_IDENTIFIER
matchChars = identifierChars
invertMatch = False
Case TT_STRING
matchChars = dQuote
invertMatch = True ' all chars until next double quote
Case TT_GUID
matchChars = GUID_END
invertMatch = True
Case TT_NUMBER
matchChars = numericChars
invertMatch = False
Case TT_COMMENT
matchChars = ""
invertMatch = True ' match everything until end of line
Case TT_WHITESPACE
matchChars = wsChars
invertMatch = False
Case TT_OTHER
' any character that can NOT be viewed as the first char of
' one of the above token types
matchChars = firstIdentifierChars & firstNumericChars & _
firstCommentChar & dQuote & wsChars & GUID_START
invertMatch = True
End Select
iEnd = iStart + 1
Do While (iEnd <= Len(s))
c = LCase(Mid(s, iEnd, 1))
matched = InStr(1, matchChars, c) <> 0
If (invertMatch) Then matched = Not matched
If (Not matched) Then Exit Do
iEnd = iEnd + 1
Loop
' end of string or GUID should include the closing double
' quote or end of GUID character (close curley brace), so
' increase by one to include these final characters.
' Note: improperly terminated quotes or GUIDs should be impossible
' in "compilable" VBA source code. In the event that the closing
' character is missing, iEnd will already be one past the last
' character of the input line/string, so no need to advance it.
If ((tt = TT_STRING And c = dQuote) Or _
(tt = TT_GUID And c = GUID_END)) Then
iEnd = iEnd + 1
End If
end_of_token = iEnd
End Function
' returns a meaningless, sequential, variable name (that is
' also reasonably short).
Private Function invisible_variable_name(var_id As Long) As String
Dim result As String
Dim i As Long
Dim L1 As Integer
Dim L2 As Integer
assert var_id > 0
result = ""
'
' this algorithm obtains a valid, short, and meaningless identifier by
' expressing the given integer variable id as a "mixed base"
' number whose "digits" are the characters valid in an identifier.
' Specifically, if you think of the variable id integer as expressed as:
' var_id = i0 + L1* (i1 + L2*i2 + L2^2*i3 + L2^3*i4 + ... )
' (by a slight generalization of the basic ideas of "base X" numbers
' you can show that any positive integer can be expressed in such a
' "mixed L1/L2 base" form)
' where L1 is the length of the valid initial identifier characters
' string; L2 is the length of the valid non-initial identifier
' character string; i0 is an integer index (0..L1-1) into the initial
' identifier char string, and i1, i2, ... are indexes (0...L2-1) into
' the non-initial identifier char string. Then the chars associated
' with these indexes determine the chars in a valid identifier (variable
' name) uniquely determined by var_id.
i = var_id
L1 = Len(firstIdentifierChars)
L2 = Len(identifierChars)
result = Mid(firstIdentifierChars, 1 + i Mod L1, 1)
i = Fix(i / L1)
Do While (i > 0)
result = result & Mid(identifierChars, 1 + i Mod L2, 1)
i = Fix(i / L2)
Loop
invisible_variable_name = result
End Function
' Associates an appropriate obfuscated name with each member
' of the invisible names collection
'
' Also excludes names from the invisible names collection
' that are also on the visible names collection.
Private Sub define_obfuscated_names()
Dim iName As Long
Dim vName As String
Dim cNew As New Collection
Dim iObfuscated_Name As Long
iObfuscated_Name = 1
For iName = 1 To invisible_names.Count
If (lookup_identifier(visible_names, CStr(invisible_names.Item(iName)(NAME_ID))) _
= NO_SUCH_ID) Then
Do ' keep looking until we get a name that is not on either
' the visible or invisible list; this loop executes once, on
' average, because collisions are unlikely Note: Assuring the
' new name isn't on the invisible list is required to avoid
' errors when renaming module, class and userform names.
vName = invisible_variable_name(iObfuscated_Name)
iObfuscated_Name = iObfuscated_Name + 1
Loop Until _
lookup_identifier(visible_names, vName) = NO_SUCH_ID And _
lookup_identifier(invisible_names, vName) = NO_SUCH_ID
add_identifier cNew, CStr(invisible_names.Item(iName)(NAME_ID)), vName
'else identifier is on visible list, so elide it from invisible list
End If
Next iName
Set invisible_names = cNew
End Sub
' returns the (possibly obfuscated, transformed) variable
' name given the original variable name
Private Function var_name(plaintextVarname As String) As String
Dim result As String
result = lookup_identifier(invisible_names, LCase(plaintextVarname))
If (result = NO_SUCH_ID) Then
' just keep the original name except converted to lowercase
result = LCase(plaintextVarname)
End If
var_name = result
End Function
' clears all of the elements in the lookup table
Private Sub reset_lookup_table(lookup_table As Collection)
Set lookup_table = New Collection
End Sub
' returns the value associated with given name, or NO_SUCH_ID if there
' is not such a (name, value) pair in the collection.
Private Function lookup_identifier(c As Collection, sName As String) As String
Dim result As String
On Error GoTo not_found
result = c.Item(LCase(sName))(VALUE_ID)
GoTo end_of_function
not_found:
result = NO_SUCH_ID
end_of_function:
lookup_identifier = result
End Function
Private Sub remove_identifier(c As Collection, sName As String)
If (lookup_identifier(c, sName) <> NO_SUCH_ID) Then
c.Remove LCase(sName)
End If
End Sub
' adds the name, value pair to the collection if the name is
' not already on the collection.
Private Sub add_identifier(c As Collection, sName As String, sValue As String)
Dim name_value_pair(NAME_ID To VALUE_ID) As String
If (NO_SUCH_ID = lookup_identifier(c, sName)) Then
name_value_pair(NAME_ID) = sName
name_value_pair(VALUE_ID) = LCase(sValue)
c.Add name_value_pair, LCase(sName)
End If
End Sub
' location of the last substring within the given string, or 0 if
' substring doesn't occur within given string.
Private Function last_substring_position(s As String, subS As String) As Integer
Dim iFound As Integer
Dim iNext As Integer
iFound = 0
iNext = InStr(1, s, subS)
Do While (iNext > 0)
iFound = iNext
iNext = InStr(iFound + 1, s, subS)
Loop
last_substring_position = iFound
End Function
' location of the event delimiter ("_") within the token, or 0 if none.
Private Function event_delimiter_position(token As String) As Integer
event_delimiter_position = last_substring_position(token, userform_event_delimiter)
End Function
' Returns the part of an event procedure token associated with the
' name of an event. For example, with an event procedure token of
' "myButton_Click", returns "Click"
' if the token isn't in the general format of an event procedure name,
' (e.g. it doesn't contain an underscore) it returns NO_SUCH_ID
Private Function event_part(token As String) As String
Dim iPosition As Integer
Dim result As String
iPosition = event_delimiter_position(token)
If (iPosition = 0) Then
result = NO_SUCH_ID
Else
result = Right(token, Len(token) - (iPosition + Len(userform_event_delimiter) - 1))
End If
event_part = result
End Function
' returns the part of an event procedure name associated with the
' name of the object (e.g. myButton_Click as token would return myButton)
Private Function object_part(token As String) As String
Dim iPosition As Integer
Dim result As String
iPosition = event_delimiter_position(token)
If (iPosition = 0) Then
result = NO_SUCH_ID
Else
result = Left(token, iPosition - 1)
End If
object_part = result
End Function
' does the token represent an event procedure name (e.g. myButton_Click) ?
Private Function is_event_procedure(token As String) As Boolean
Dim sEvent As String
Dim result As String
sEvent = event_part(token)
If (sEvent = NO_SUCH_ID) Then
result = False
ElseIf (NO_SUCH_ID = lookup_identifier(userform_attribute_names, sEvent)) Then
result = False
Else
result = True
End If
is_event_procedure = result
End Function
' does the given string begin with the specified prefix?
Private Function has_prefix(s As String, prefix As String) As Boolean
has_prefix = (Left(s, Len(prefix)) = prefix)
End Function
' does the given string end with the specified suffix?
Private Function has_suffix(s As String, suffix As String) As Boolean
has_suffix = (Right(s, Len(suffix)) = suffix)
End Function
' sets token buffer to the default, "do nothing", token sequence
Private Sub reset_token_buffer()
Dim i As Integer
For i = LBound(prevTokens) To UBound(prevTokens)
prevTokens(i) = " " ' use whitespace because leading whitespace cannot change how a program is parsed
Next i ' (the default "" isn't a valid token and can therefore cause problems)
tokenIndex = LBound(prevTokens)
End Sub
' write the token into the circular token buffer
Private Sub remember_token(token As String)
tokenIndex = (tokenIndex + 1) Mod N_BUFFERED_TOKENS
prevTokens(tokenIndex) = token
End Sub
' returns the last token stored in the token buffer
Private Function last_token() As String
last_token = prevTokens(tokenIndex)
End Function
' returns next-to-the-last token stored in the token buffer
Private Function next_to_last_token() As String
Dim result As String
If (tokenIndex = LBound(prevTokens)) Then
result = prevTokens(UBound(prevTokens)) ' wrap-around to last element
Else
result = prevTokens(tokenIndex - 1) ' no-wrap-around needed
End If
next_to_last_token = result
End Function
' does the token represent an attribute (event or property) of a
' control contained on a userform?
Private Function is_userform_attribute(token As String) As Boolean
is_userform_attribute = (NO_SUCH_ID <> lookup_identifier(userform_attribute_names, token))
End Function
' Is the token one that, when it preceeds another token (separated
' only by whitespace) indicates that that token represents an
' explicitly declared name.
'
' Examples (the variable x is explicitly declared because it is
' preceeded by Dim, Private, or Function):
'
' dim x as Double
' private x as Variant
' private function x()
Private Function preceeds_declared_name(token As String) As Boolean
Dim result As Boolean
Select Case LCase(token)
Case "friend", "enum", "declare", "static", "byref", "byval", "get", "let", "set", "dim", _
"function", "sub", "type", "const", "private", "public", "global", "paramarray", _
"optional", "property"
result = True
Case Else
result = False
End Select
preceeds_declared_name = result
End Function
' is the token one that, when it follows another token separated only
' by whitespace, implies that token is an explicitly declared name?
' Example (the name x is explicitly declared because it is followed
' by "as"):
'
' type myType
' x as Integer
' end type
Private Function follows_declared_name(token As String) As Boolean
Dim result As Boolean
Select Case LCase(token)
Case "as", "lib"
result = True
Case Else
result = False
End Select
follows_declared_name = result
End Function
' adds ids contained in the string (representing a single, though possibly
' continued, line of input source text) to appropriate lookup tables
' used to determine which variable names remain unchanged, and which
' are obfuscated (replaced with variable names meaningless to humans).
Private Sub register_ids(s As String)
Dim iStart As Integer
Dim iEnd As Integer
Dim visible As Boolean
Dim obfuscated_id As Long
Dim token As String
reset_token_buffer ' cross-source-statement token sequences are not of interest
If InStr(1, LCase(s), BEGIN_VISIBLE_KEYWORD) <> 0 Then
m_visible_depth = m_visible_depth + 1
End If
If InStr(1, LCase(s), END_VISIBLE_KEYWORD) <> 0 Then
m_visible_depth = m_visible_depth - 1
End If
If InStr(1, LCase(s), VISIBLE_KEYWORD) > 0 Then
' single line #visible keyword makes ids on this line visible, no
' matter what our visible depth is
visible = True
Else
' no line specific keyword, so based on if we are within
' a #begin_visible ... #end_visible bracketed region
visible = m_visible_depth > 0
End If
iStart = 1
Do While (iStart <= Len(s))
iEnd = end_of_token(s, iStart)
token = LCase(Mid(s, iStart, iEnd - iStart))
If (token_type(token, 1) = TT_IDENTIFIER) Then
If (last_token() = userform_control_attribute_flag) Then
' token is flagged as representing a userform-related event,
' such as Click (or control property such as Caption)
'
' Example token sequence: "_" followed by "Click" will
' register "Click" as a userform attribute. Note that "_Click"
' isn't processed as a single token because "_" isn't a valid
' first character of a variable name in VBA.
add_identifier userform_attribute_names, token, token
add_identifier visible_names, token, token
ElseIf (is_event_procedure(token)) Then
' example token: myButton_Click will make itself and myButton visible if _Click is listed in visible_names.txt
add_identifier visible_names, token, token
add_identifier visible_names, object_part(token), object_part(token)
ElseIf (is_userform_attribute(token) And _
last_token() = object_attribute_delimiter And token_type(next_to_last_token(), 1) = TT_IDENTIFIER) Then
' example: myLabel.Caption will make myLabel a visible name if
' "_Caption" is listed in visible_names.txt (the leading _
' flags Caption as a userform control attribute (event or property))
add_identifier visible_names, next_to_last_token(), next_to_last_token()
ElseIf (visible) Then
add_identifier visible_names, token, token
Else
' note: if an identifier gets added to both visible and
' invisible lists, it will considered visible (and get removed
' from the invisible list in a separate step later on).
If (token_type(last_token(), 1) = TT_WHITESPACE) Then
If (preceeds_declared_name(next_to_last_token())) Then
add_identifier invisible_names, token, token
End If
If (follows_declared_name(token) And _
token_type(next_to_last_token(), 1) = TT_IDENTIFIER) Then
add_identifier invisible_names, next_to_last_token(), next_to_last_token()
End If
End If
End If
' else not an identifier, so it can never be added to lookup tables
' used to determine token visibility.
End If
remember_token token ' stores last few token in a circular buffer for easier parsing
iStart = iEnd
Loop
End Sub
' the length of a string, excluding and leading/trailing double quotes
Private Function length_sans_quotes(s As String) As Integer
Dim result As Integer
result = Len(s)
If (has_prefix(s, dQuote)) Then result = result - Len(dQuote)
If (has_suffix(s, dQuote)) Then result = result - Len(dQuote)
length_sans_quotes = result
End Function
' length of the given prefix within a specified string, or 0 if that
' prefix is not at the beginning of the specified string
Private Function length_of_prefix(s As String, prefix As String) As Integer
Dim result As Integer
If (has_prefix(s, prefix)) Then
result = Len(prefix)
Else
result = 0
End If
length_of_prefix = result
End Function
' strips leading, trailing, double quotes from a given string
' (if no such quotes present, returns original string)
Private Function NQ(s As String) As String
NQ = Mid(s, 1 + length_of_prefix(s, dQuote), length_sans_quotes(s))
End Function
' adds double quotes around the given string
Private Function Q(s As String) As String
Q = dQuote & s & dQuote
End Function
' returns an obfuscated, functionally equivalent, source code line
' for the given source code line
Private Function obfuscated_line(s As String) As String
Dim result As String
Dim iStart As Integer
Dim iEnd As Integer
Dim token As String
result = ""
iStart = 1
Do While (iStart <= Len(s)) iEnd = end_of_token(s, iStart) token = Mid(s, iStart, iEnd - iStart) Select Case (token_type(token, 1)) Case TT_IDENTIFIER result = result & var_name(token) Case TT_WHITESPACE If (InStr(token, line_continuation_chars & vbNewLine) > 0) Then
' line continuation characters and newlines are analyzed as
' part of whitespace tokens, but they need to be preserved
' because VBA has line length constraints that could break code
' if long continued lines were collapsed into a single line.
result = result & line_continuation_chars & vbNewLine
Else
result = result & " "
End If
Case TT_NUMBER
result = result & token
Case TT_STRING
result = result & token
Case TT_COMMENT
If (has_prefix(token, doubleComment)) Then
' double comments are retained (for copywrite notices, etc.)
result = result & Right(token, Len(token) - Len(firstCommentChar))
' else just ignore/elide the comment
End If
Case TT_GUID
result = result & token
Case TT_OTHER
result = result & token
Case Else
assert False ' should have been type "other"
End Select
iStart = iEnd
Loop
' trim to drop any leading whitespace (makes lines all flush left)
obfuscated_line = Trim(result)
End Function
' reads each line from the specified sourcecode file, and
' registers any identifiers contained in the file on the
' appropriate (visible or invisible) lookup table.
Private Sub register_identifiers(fName As String)
Dim fid As Integer
Dim sLine As String
Dim errNo As Long
On Error GoTo error_exit
' open file for reading
fid = freefile()
Open fName For Input As #fid
' read each (possibly continued) line, registering its ids
Do While Not EOF(fid)
sLine = get_continued_line(fid)
register_ids sLine
Loop
Close fid
GoTo end_of_sub
error_exit:
errNo = Err.Number
On Error Resume Next
Close fid
Err.Raise errNo
end_of_sub:
End Sub
' is the line one that is continued on the next line (ends in
' the VBA line continuation character sequence, " _")
Private Function is_continued_line(sLine As String) As Boolean
is_continued_line = has_suffix(sLine, line_continuation_chars)
End Function
' adds another line to an existing series of "vbNewLine
' separated" lines, returning the so-extended series of lines.
Private Function add_line(sOld As String, sNew As String) As String
Dim result As String
If (sOld = "") Then
result = sNew
Else
result = sOld & vbNewLine & sNew
End If
add_line = result
End Function
' returns a (possibly continued) source code line from the given
' input file.
Private Function get_continued_line(f_in As Integer) As String
Dim result As String
Dim sTmp As String
result = ""
Do ' read & concatenate continued lines
Line Input #f_in, sTmp
result = add_line(result, sTmp)
Loop Until EOF(f_in) Or Not is_continued_line(sTmp)
get_continued_line = result
End Function
' obfuscates the given sourcecode file by removing comments,
' replacing meaningful names with meaningless names, etc.
' A side benefit: it tends to reduce the size of the source code
' files, due to comment elimination and the fact that
' obfuscated names are usually substantially shorter than
' the original names.
Private Sub obfuscate_sourcecode_file( _
f_plain As String, f_obfuscated As String)
Dim f_in As Integer
Dim f_out As Integer
Dim sLine As String
Dim sObfuscated As String
Dim errNo As Long
On Error GoTo error_exit
f_in = freefile()
Open f_plain For Input As #f_in
f_out = freefile()
Open f_obfuscated For Output As #f_out
' obfuscate, and then write, each original input source code
' file line into the obfuscated source code output file
Do While Not EOF(f_in)
sLine = get_continued_line(f_in)
sObfuscated = obfuscated_line(sLine)
If (m_interleave_original_code_as_comments) Then
Print #f_out, firstCommentChar & sLine
Print #f_out, sObfuscated ' empty obfuscated lines retained--helpful when debugging.
ElseIf (sObfuscated <> "") Then
Print #f_out, sObfuscated
' else elide lines that are empty after obfuscation
End If
Loop
Close f_in
Close f_out
GoTo end_of_sub
error_exit:
errNo = Err.Number
On Error Resume Next
Close f_in
On Error Resume Next
Close f_out
Err.Raise errNo
end_of_sub:
End Sub
' returns a temporary file name given a file number
Private Function temp_file_name(wb As Workbook, _
iFile As Integer, Optional extension = ".tmp") As String
temp_file_name = wb.Path & PS() & IB_TEMP_FILENAME_PREFIX & _
CStr(iFile) & extension
End Function
' returns a random module name suitable for use as a VBA code module
Private Function random_module_name() As String
' highly unlike this name will conflict with any existing names
random_module_name = "qzx" & _
Format(10 ^ 6 * Rnd(), "000000") & Format(10 ^ 6 * Rnd(), "000000")
End Function
' writes source code in a given VBComponent into a specified file
' (overwrites any existing file contents)
Private Sub write_component_code(vbc As Object, f As String)
Dim f_out As Integer
Dim iLine As Long
Dim errNo As Long
On Error GoTo error_exit
f_out = freefile()
Open f For Output As #f_out
For iLine = 1 To vbc.CodeModule.CountOfLines
Print #f_out, vbc.CodeModule.Lines(startLine:=iLine, Count:=1)
Next iLine
Close f_out
GoTo end_of_sub
error_exit:
errNo = Err.Number
On Error Resume Next
Close f_out
Err.Raise errNo
end_of_sub:
End Sub
' reads source code in a given file into the specified component
' (overwrites any existing code in the component)
Private Sub read_component_code(vbc As Object, f As String)
Dim f_in As Integer
Dim sLine As String
Dim iLine As Long
Dim errNo As Long
On Error GoTo error_exit
vbc.CodeModule.DeleteLines startLine:=1, Count:=vbc.CodeModule.CountOfLines
' vbc.CodeModule.AddFromFile has unpleasant side-effects related to module name
' changes, so we just add the lines one at a time instead:
f_in = freefile()
Open f For Input As #f_in
iLine = 1
Do While Not EOF(f_in) ' read each source code line and insert into component
Line Input #f_in, sLine
vbc.CodeModule.InsertLines iLine, sLine
iLine = iLine + 1
Loop
Close f_in
GoTo end_of_sub
error_exit:
errNo = Err.Number
On Error Resume Next
Close f_in
Err.Raise errNo
end_of_sub:
End Sub
' Writes out a "cheat sheet" that gives you the original name of each
' obfuscated name in an obfuscated workbook.
'
' The cheat sheet is helpful in debugging obfuscated programs (allows
' you to translate the names that appear on a single obfuscated line,
' etc.).
'
' Assumes that invisible_names list is fully populated.
'
Private Sub write_invisible_names(wb As Workbook, fName As String)
Dim iPair As Long ' index of name, value pair on invisible names list
Dim f_out As Integer
Dim errNo As Long
On Error GoTo error_exit
f_out = freefile()
Open fName For Output As #f_out
Print #f_out, "Hidden" & vbTab & "Original"
For iPair = 1 To invisible_names.Count ' for each name, value pair on invisible names list
Print #f_out, invisible_names(iPair)(VALUE_ID) & vbTab & invisible_names(iPair)(NAME_ID)
Next iPair
Close f_out
GoTo end_of_sub
error_exit:
errNo = Err.Number
On Error Resume Next
Close f_out
Err.Raise errNo
end_of_sub:
End Sub
' obfuscates all VBA source code modules, classes and UserForms
Private Sub obfuscate_workbook(wb As Workbook)
Dim vbc As Object
Dim iFile As Integer
Dim tmpFile As String
Dim old_display_status_bar As Boolean
Dim newName As String
old_display_status_bar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.StatusBar = "Saving Invisibly: initializing..."
' start with empty variable name identifier tables
reset_lookup_table visible_names
reset_lookup_table invisible_names
reset_lookup_table userform_attribute_names
reset_token_buffer
' the E "identifier" appears within numeric literals
' expressed in scientific notation, and thus must never be
' obfuscated (this "non-obfuscation of e" is needed because
' our lexical analysis of numbers is otherwise too simple to
' get numeric literals expressed in scientific notation right).
register_ids "e '#visible"
' register all built-in visible identifiers stored in
' a special text file shipped with the application
' (Excel/VBA keywords and user defined universal keywords)
assert Dir(ThisWorkbook.Path & PS() & IB_VISIBLE_KEYWORDS_FILENAME) <> ""
m_visible_depth = 1
register_identifiers ThisWorkbook.Path & PS() & IB_VISIBLE_KEYWORDS_FILENAME
m_visible_depth = 0
' first pass: store each code module in a temp file,
' register that file's visible identifiers, and then delete
' the code component.
For iFile = 1 To wb.VBProject.VBComponents.Count
Set vbc = wb.VBProject.VBComponents(iFile)
Select Case vbc.Type
Case IB_vbext_ct_StdModule, IB_vbext_ct_ClassModule, IB_vbext_ct_MSForm
' the name of a module, class, or userform is obfuscated
' (normal case). Register the name as "invisible"
m_visible_depth = 0
register_ids "Dim " & vbc.Name ' Dim makes it look like name is "user declared"
Case IB_vbext_ct_Document
' document (e.g. Worksheet) code names remain visible because
' there isn't an easy way to RELIABLY change them
' programmatically (surprisingly, setting vbc.Name doesn't do it)
register_ids vbc.Name & " '#visible"
Case Else
' if Microsoft adds a new type, play it safe by keeping
' names unchanged ("visible").
register_ids vbc.Name & " '#visible"
End Select
Application.StatusBar = "Saving Invisibly: Pass 1 of 2, VBComponent " & CStr(iFile) & " of " & CStr(wb.VBProject.VBComponents.Count)
write_component_code vbc, temp_file_name(wb, iFile)
m_visible_depth = 0 ' invisible unless otherwise noted
reset_token_buffer
register_identifiers temp_file_name(wb, iFile)
Next iFile
define_obfuscated_names 'choose obscure ids for invisible names
' second pass obfuscates by replacing registered, non-visible
' variable ids with meaningless ids, stripping comments, etc, and
' then reading the so-obfuscated code back into each component.
tmpFile = temp_file_name(wb, wb.VBProject.VBComponents.Count + 1)
For iFile = 1 To wb.VBProject.VBComponents.Count
Set vbc = wb.VBProject.VBComponents(iFile)
newName = obfuscated_line(vbc.Name)
' this "if" (to prevent changing name when name isn't obfuscated)
' was added because I don't trust that name changes in such cases, even to the same
' name, are reliable.
If (LCase(newName) <> LCase(vbc.Name)) Then vbc.Name = newName
Application.StatusBar = "Saving Invisibly: Pass 2 of 2, VBComponent " & CStr(iFile) & " of " & CStr(wb.VBProject.VBComponents.Count)
reset_token_buffer
obfuscate_sourcecode_file temp_file_name(wb, iFile), tmpFile
read_component_code vbc, tmpFile
Kill tmpFile
Kill temp_file_name(wb, iFile)
Next iFile
Application.StatusBar = _
"Writing ""secret decoder"" file: " & ib_suffixed_filename(wb, IB_SECRET_DECODER_SUFFIX) & "..."
write_invisible_names wb, ib_suffixed_filename(wb, IB_SECRET_DECODER_SUFFIX)
Application.StatusBar = False ' restore status bar status quo
Application.DisplayStatusBar = old_display_status_bar
End Sub
' If this function returns True, the two strings are guaranteed
' to represent different physical files (regardless of what
' default paths might be added to any file name strings that do not
' have explicitly specified full pathnames)
Private Function are_different_files(f1_in As String, f2_in As String) As Boolean
Dim f1 As String
Dim f2 As String
Dim result As Boolean
f1 = Trim(LCase(f1_in))
f2 = Trim(LCase(f2_in))
' making each filename start with path separator simplifies the tests:
If (Not has_prefix(f1, PS())) Then f1 = PS() & f1
If (Not has_prefix(f2, PS())) Then f2 = PS() & f2
' if the last half of either filename string equals the other,
' the filename COULD represent the same physical file
If (has_suffix(f1, f2) Or has_suffix(f2, f1)) Then
result = False
Else
' filenames definitely represent different files
result = True
End If
are_different_files = result
End Function
' obfuscates the given workbook, saving it into the specified file
Public Sub obfuscate_workbook_as(wb As Workbook, fileName As String)
assert are_different_files(wb.fullName, fileName)
' saving under a new name breaks connection with original file,
' assuring that original unobfuscated workbook isn't damaged.
' (even if we crash and user then accidentally saves the
' so-damaged workbook, originally named file is still safe)
wb.SaveAs fileName
obfuscate_workbook wb
Application.DisplayAlerts = False
wb.SaveAs fileName ' save again under the new name
Application.DisplayAlerts = True
End Sub
' default filename in which to store "invisible" version
Private Function ib_suffixed_filename(wb As Workbook, suffix As String) As String
Dim dot_position As Integer
Dim result As String
dot_position = last_substring_position(wb.Name, ".")
If (dot_position = 0) Then
result = wb.Path & PS() & wb.Name & suffix
Else
result = wb.Path & PS() & Left(wb.Name, dot_position - 1) & suffix
End If
ib_suffixed_filename = result
End Function
' Save the active workbook invisibly in a user-selected workbook
Private Sub ib_save_invisibly_as()
Dim fileName As String
Dim wb As Workbook
On Error GoTo error_exit
Set wb = ActiveWorkbook
If (Not wb.saved) Then
MsgBox "Workbook """ & ActiveWorkbook.Name & """ has unsaved changes. " & _
"To help prevent accidental source code losses, workbooks " & _
"with unsaved changes cannot be saved invisibly. " & vbNewLine & vbNewLine & _
"Save your original workbook, then try again. ", _
vbCritical, "Workbooks with unsaved changes cannot be saved invisibly."
GoTo end_of_sub
End If
' present a "save as" type filename dialog
fileName = Application.GetSaveAsFilename( _
InitialFilename:=ib_suffixed_filename(wb, IB_FILENAME_SUFFIX), _
FileFilter:="Microsoft Excel Workbook (*.xls),*.xls,All Files (*.*),*.*", _
Title:="Select file into which workbook will be saved invisibly")
' Because there is too much potential for total code loss, we do not
' allow user to overwrite the original workbook with the obfuscated
' workbook:
If (Not are_different_files(wb.fullName, fileName)) Then
MsgBox "The selected filename (" & fileName & _
") must be clearly different from the current workbook's filename (" & wb.fullName & _
"). Try again, next time choosing a different name.", _
vbCritical, "Save Invisibly As Filename Must Differ from Original Filename"
ElseIf (fileName <> "False") Then
obfuscate_workbook_as wb, fileName
End If
GoTo end_of_sub
error_exit:
Application.DisplayAlerts = True
Application.StatusBar = False ' resume default status bar behavior
MsgBox "Error #" & CStr(Err.Number) & " during ""Save Invisibly As"": " & Err.Description, _
vbCritical, "Invisible Basic Save Invisibly As Error"
end_of_sub:
End Sub
' Top level "Save Invisibly As..." command
Public Sub invisible_basic_save_invisibly_as() '#visible
m_interleave_original_code_as_comments = False
ib_save_invisibly_as
End Sub
' Top level "Debugging Save Invisibly As..." command
Public Sub invisible_basic_debugging_save_invisibly_as() '#visible
m_interleave_original_code_as_comments = True
ib_save_invisibly_as
End Sub
Private Sub visit_url(url As String)
ShellExecute GetDesktopWindow(), "Open", url, 0, 0, SW_SHOWMAXIMIZED
End Sub
' Just shows the HTML file that contains the InvisibleBasic help file
Public Sub invisible_basic_show_help() '#visible
visit_url ThisWorkbook.Path & PS() & "InvisibleBasic.html"
End Sub
Public Sub invisible_basic_web_site() '#visible
visit_url INVISIBLE_BASIC_URL
End Sub
Public Sub invisible_basic_about() '#visible
MsgBox "Invisible Basic Version " & CStr(INVISIBLE_BASIC_VERSION) & vbNewLine & _
"A Source Code Obfuscator for Excel/VBA" & vbNewLine & _
"Share you spreadsheets. Not your source code." & vbNewLine & _
vbNewLine & _
"Copyright 2006, John C. Gunther. All Rights Reserved." & vbNewLine & _
"Distributed under the terms of the BSD open source license." & vbNewLine & _
vbNewLine & _
"Web Site: " & INVISIBLE_BASIC_URL & vbNewLine _
, vbOKOnly, "About Invisible Basic"
End Sub
' adds or updates the Invisible Basic menu within Excel
Public Sub invisible_basic_add_menu()
Dim cbp As CommandBarPopup ' new invisible basic menu bar
Dim cbb As CommandBarButton ' new menu item added to this bar
Call invisible_basic_remove_menu ' to prevent adding menu twice
Set cbp = Application.CommandBars(IB_NameOfExcelWorksheetMenubar).Controls.Add( _
Type:=msoControlPopup)
cbp.caption = IB_NameOfInvisibleBasicMenu
cbp.tooltiptext = _
"Source code obfuscation utility for Excel/VBA applications."
Set cbb = cbp.Controls.Add(Type:=msoControlButton)
cbb.caption = "&Save Invisibly As..."
cbb.DescriptionText = "Saves copy of workbook whose VBA code is replaced with equivalant, but hard-to-read, code."
cbb.onAction = "invisible_basic_save_invisibly_as"
Set cbb = cbp.Controls.Add(Type:=msoControlButton)
cbb.caption = "&Debugging Save Invisibly As..."
cbb.DescriptionText = "Same as Save Invisibly As except interleaves original source code as comments (for debugging)."
cbb.onAction = "invisible_basic_debugging_save_invisibly_as"
Set cbb = cbp.Controls.Add(Type:=msoControlButton)
cbb.caption = "&Help..."
cbb.DescriptionText = "Invisible Basic Help"
cbb.onAction = "invisible_basic_show_help"
Set cbb = cbp.Controls.Add(Type:=msoControlButton)
cbb.caption = "Invisible Basic &Web Site"
cbb.DescriptionText = "Invisible Basic Web Site"
cbb.onAction = "invisible_basic_web_site"
Set cbb = cbp.Controls.Add(Type:=msoControlButton)
cbb.caption = "&About Invisible Basic..."
cbb.DescriptionText = "About Invisible Basic"
cbb.onAction = "invisible_basic_about"
End Sub
' removes the Invisible Basic menu from Excel
Public Sub invisible_basic_remove_menu()
On Error Resume Next
Application.CommandBars(IB_NameOfExcelWorksheetMenubar).Controls( _
IB_NameOfInvisibleBasicMenu).Delete
End Sub
' Simple test of Invisible Basic. Test requires that the test
' workbook, IB_Test.xls, be in the same folder as the Add-in is.
'
' The test makes the test workbook invisible, then runs a test
' routine within the (then obfuscated) test workbook.
'
' You may see two "OK to overwrite" prompts (answer Yes)
' and you should see "Hello Invisible Basic" (four times)
' if the test passes. If you don't see "Hello Visible Basic",
' four times, the test has failed.
'
Public Sub ib_test()
Dim wb As Workbook
Dim fTest As String
Dim fObf As String
Dim iPass As Integer
assert event_part("myButton_Click") = "Click"
assert object_part("myButton_Click") = "myButton"
assert event_part("myButtonClick") = ""
assert event_part("myButton_20_Click") = "Click"
assert object_part("myButton_20_Click") = "myButton_20"
For iPass = 1 To 2
If (iPass = 1) Then
invisiblebasic.interleave_original_code_as_comments = False
Else
invisiblebasic.interleave_original_code_as_comments = True
End If
fTest = ThisWorkbook.Path & PS() & "IB_Test.xls"
fObf = ThisWorkbook.Path & PS() & "IB_Test_Obf.xls"
' Open the test workbook
Workbooks.Open fTest
Set wb = Workbooks(Workbooks.Count)
' Save it invisibly as a new workbook
obfuscate_workbook_as wb, fObf
' the test module exercies code in the obfuscated modules in IB_Test
' and compares results with expected results.
Evaluate "IBTest.testModule.ibt_test()"
wb.close SaveChanges:=False
Next iPass
End Sub