Invisible Basic, After "Debugging Save Invisibly As"

The "Debugging Save Invisibly As" command interleaves the original source code lines, as comments, with the obfuscated lines. This makes it easier to see how Invisible Basic has transformed your code (or, in this case, itself).

Return to Invisible Basic Home Page

''

'' 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
Option Explicit
'

'' 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 j As Integer = 1
'Private Const TT_STRING As Integer = 2  ' string literal ("myString")
Private Const k As Integer = 2
'Private Const TT_NUMBER As Integer = 3  ' numerical literal (1.23)
Private Const l As Integer = 3
'Private Const TT_COMMENT As Integer = 4 ' VBA comment text
Private Const m As Integer = 4
'Private Const TT_WHITESPACE As Integer = 5  ' space or tab
Private Const n As Integer = 5
'Private Const TT_GUID As Integer = 6 ' global universal identifier
Private Const o As Integer = 6
'                                     ' ({C62A69F0-16DC-11CE-9E98-00AA00574A4F})

'Private Const TT_OTHER As Integer = 7   ' everything else
Private Const p As Integer = 7
'

'' 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"
Private Const r = "visible_names.txt"
'

'' establish classes of characters helpful in tokenization:

'

'Private Const wsChars As String = " " & vbTab
Private Const t As String = " " & vbTab
'Private Const alphaChars As String = "abcdefghijklmnopqrstuvwxyz"
Private Const u As String = "abcdefghijklmnopqrstuvwxyz"
'Private Const underscore As String = "_"
Private Const v As String = "_"
'Private Const digits As String = "0123456789"
Private Const w As String = "0123456789"
'Private Const dQuote As String = """"
Private Const x As String = """"
'Private Const GUID_START As String = "{"  ' "Global Universal ID"
Private Const y As String = "{"
'Private Const GUID_END As String = "}"    ' (occurs in UserForm headers)
Private Const z As String = "}"
'Private Const firstNumericChars As String = digits
Private Const ab As String = w
'Private Const numericChars As String = firstNumericChars & "."
Private Const bb As String = ab & "."
'Private Const firstCommentChar As String = "'"
Private Const cb As String = "'"
'Private Const doubleComment As String = firstCommentChar & firstCommentChar
Private Const db As String = cb & cb
'Private Const line_continuation_chars As String = " " & underscore
Private Const eb As String = " " & v
'Private Const firstIdentifierChars As String = alphaChars
Private Const fb As String = u
'Private Const identifierChars As String = alphaChars & underscore & digits
Private Const gb As String = u & v & w
'' e.g. in the event procedure myButton_Click, "_" delimits the

'' control name from the event name:

'Private Const userform_event_delimiter As String = underscore
Private Const hb As String = v
'' 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 ib As String = v
'Private Const object_attribute_delimiter As String = "."  'object attribute delimiter (e.g. the "." in myLabel.Caption)
Private Const jb As String = "."
'

'' 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
Private Const visible_keyword As String = "#visible"
'' for delimiting visible blocks:

'Private Const BEGIN_VISIBLE_KEYWORD As String = "#begin_visible"
Private Const begin_visible_keyword As String = "#begin_visible"
'Private Const END_VISIBLE_KEYWORD As String = "#end_visible"
Private Const kb 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"
Private Const lb As String = "_ib"
'

'' depth of #begin_visible ... #end_visible nesting:

'Private m_visible_depth As Long
Private mb As Long
'

'' returned when a specified identifier isn't found:

'Private Const NO_SUCH_ID As String = ""
Private Const nb 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 ob As New Collection
'Private invisible_names As New Collection
Private pb 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
Private qb 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 rb As Boolean
'

'Private Const IB_NameOfInvisibleBasicMenu As String = "Invisible&Basic"
Private Const sb 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 tb As String = _
 "Worksheet Menu Bar"
'

'Private Const IB_TEMP_FILENAME_PREFIX = "InvBas_Temp_"    ' example temp filename: InvBas_Temp_1.tmp
Private Const ub = "InvBas_Temp_"
'

'' 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 vb 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 Declare Function xb Lib "shell32" _
 Alias "ShellExecuteA" _
 (ByVal yb As Long, _
 ByVal zb As String, _
 ByVal ac As String, _
 ByVal bc As String, _
 ByVal cc As String, _
 ByVal dc As Long) As Long
'

'Private Const SW_SHOWNORMAL As Long = 1
Private Const ec As Long = 1
'Private Const SW_SHOWMAXIMIZED As Long = 3
Private Const fc As Long = 3
'Private Const SW_SHOWDEFAULT As Long = 10
Private Const gc 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 hc As Long = 1
'Private Const IB_vbext_ct_ClassModule As Long = 2
Private Const ic As Long = 2
'Private Const IB_vbext_ct_MSForm As Long = 3
Private Const jc As Long = 3
'Private Const IB_vbext_ct_Document As Long = 100
Private Const kc 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 Const lc As Integer = 3
'Private prevTokens(0 To N_BUFFERED_TOKENS - 1) As String
Private mc(0 To lc - 1) As String
'Private tokenIndex As Integer
Private nc As Integer
'

'Private Function PS() As String  ' e.g. a "\" on Windows
Private Function oc() As String
'  PS = Application.PathSeparator
oc = Application.PathSeparator
'End Function
End Function
'

'Public Property Get interleave_original_code_as_comments() As Boolean
Public Property Get pc() As Boolean
'  interleave_original_code_as_comments = m_interleave_original_code_as_comments
pc = rb
'End Property
End Property
'

'Public Property Let interleave_original_code_as_comments(original_code_as_comments As Boolean)
Public Property Let pc(qc As Boolean)
'  m_interleave_original_code_as_comments = original_code_as_comments
rb = qc
'End Property
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)
Private Sub assert(rc As Boolean)
'  If (Not condition) Then Stop
If (Not rc) Then Stop
'End Sub
End Sub
'

'' 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
Private Function sc(tc As String, _
 uc As Integer) As Integer
'  Dim c As String
Dim vc As String
'  Dim result As Integer
Dim wc As Integer
'  assert 1 <= iStart And iStart <= Len(s)
assert 1 <= uc And uc <= Len(tc)
'  c = LCase(Mid(s, iStart, 1))
vc = LCase(Mid(tc, uc, 1))
'  If (InStr(1, wsChars, c) <> 0) Then
If (InStr(1, t, vc) <> 0) Then
'    result = TT_WHITESPACE
wc = n
'  ElseIf (InStr(1, firstIdentifierChars, c) <> 0) Then
ElseIf (InStr(1, fb, vc) <> 0) Then
'    result = TT_IDENTIFIER
wc = j
'  ElseIf (c = dQuote) Then
ElseIf (vc = x) Then
'    result = TT_STRING
wc = k
'  ElseIf (c = GUID_START) Then
ElseIf (vc = y) Then
'    result = TT_GUID
wc = o
'  ElseIf (InStr(1, firstNumericChars, c) <> 0) Then
ElseIf (InStr(1, ab, vc) <> 0) Then
'    result = TT_NUMBER
wc = l
'  ElseIf (firstCommentChar = c) Then
ElseIf (cb = vc) Then
'    result = TT_COMMENT
wc = m
'  Else
Else
'    result = TT_OTHER
wc = p
'  End If
End If
'

'  token_type = result
sc = wc
'

'End Function
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
Private Function xc(tc As String, _
 uc As Integer) As Integer
'  Dim iEnd As Integer
Dim yc As Integer
'  Dim tt As Integer
Dim zc As Integer
'  Dim matchChars As String
Dim ad As String
'  Dim invertMatch As Boolean
Dim bd As Boolean
'  Dim matched As Boolean
Dim cd As Boolean
'  Dim c As String
Dim vc As String
'

'  tt = token_type(s, iStart)
zc = sc(tc, uc)
'

'  Select Case (tt)
Select Case (zc)
'    Case TT_IDENTIFIER
Case j
'      matchChars = identifierChars
ad = gb
'      invertMatch = False
bd = False
'    Case TT_STRING
Case k
'      matchChars = dQuote
ad = x
'      invertMatch = True   ' all chars until next double quote
bd = True
'    Case TT_GUID
Case o
'      matchChars = GUID_END
ad = z
'      invertMatch = True
bd = True
'    Case TT_NUMBER
Case l
'      matchChars = numericChars
ad = bb
'      invertMatch = False
bd = False
'    Case TT_COMMENT
Case m
'      matchChars = ""
ad = ""
'      invertMatch = True  ' match everything until end of line
bd = True
'    Case TT_WHITESPACE
Case n
'      matchChars = wsChars
ad = t
'      invertMatch = False
bd = False
'    Case TT_OTHER
Case p
'      ' 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
ad = fb & ab & _
 cb & x & t & y
'      invertMatch = True
bd = True
'  End Select
End Select
'

'  iEnd = iStart + 1
yc = uc + 1
'

'  Do While (iEnd <= Len(s))
Do While (yc <= Len(tc))
'    c = LCase(Mid(s, iEnd, 1))
vc = LCase(Mid(tc, yc, 1))
'    matched = InStr(1, matchChars, c) <> 0
cd = InStr(1, ad, vc) <> 0
'    If (invertMatch) Then matched = Not matched
If (bd) Then cd = Not cd
'

'    If (Not matched) Then Exit Do
If (Not cd) Then Exit Do
'

'    iEnd = iEnd + 1
yc = yc + 1
'

'  Loop
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
If ((zc = k And vc = x) Or _
 (zc = o And vc = z)) Then
'    iEnd = iEnd + 1
yc = yc + 1
'  End If
End If
'

'  end_of_token = iEnd
xc = yc
'

'End Function
End Function
'

'

'' returns a meaningless, sequential, variable name (that is

'' also reasonably short).

'

'Private Function invisible_variable_name(var_id As Long) As String
Private Function dd(ed As Long) As String
'  Dim result As String
Dim wc As String
'  Dim i As Long
Dim fd As Long
'  Dim L1 As Integer
Dim gd As Integer
'  Dim L2 As Integer
Dim hd As Integer
'

'  assert var_id > 0
assert ed > 0
'  result = ""
wc = ""
''

'' 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
fd = ed
'  L1 = Len(firstIdentifierChars)
gd = Len(fb)
'  L2 = Len(identifierChars)
hd = Len(gb)
'  result = Mid(firstIdentifierChars, 1 + i Mod L1, 1)
wc = Mid(fb, 1 + fd Mod gd, 1)
'  i = Fix(i / L1)
fd = Fix(fd / gd)
'  Do While (i > 0)
Do While (fd > 0)
'    result = result & Mid(identifierChars, 1 + i Mod L2, 1)
wc = wc & Mid(gb, 1 + fd Mod hd, 1)
'    i = Fix(i / L2)
fd = Fix(fd / hd)
'  Loop
Loop
'

'  invisible_variable_name = result
dd = wc
'

'End Function
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()
Private Sub jd()
'  Dim iName As Long
Dim kd As Long
'  Dim vName As String
Dim ld As String
'  Dim cNew As New Collection
Dim md As New Collection
'  Dim iObfuscated_Name As Long
Dim nd As Long
'

'  iObfuscated_Name = 1
nd = 1
'  For iName = 1 To invisible_names.Count
For kd = 1 To pb.Count
'    If (lookup_identifier(visible_names, invisible_names.Item(iName)) _
        = NO_SUCH_ID) Then
If (od(ob, pb.Item(kd)) _
 = nb) Then
'      Do ' keep looking until we get a name that is not on either
Do
'         ' 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)
ld = dd(nd)
'        iObfuscated_Name = iObfuscated_Name + 1
nd = nd + 1
'      Loop Until _
         lookup_identifier(visible_names, vName) = NO_SUCH_ID And _
         lookup_identifier(invisible_names, vName) = NO_SUCH_ID
Loop Until _
 od(ob, ld) = nb And _
 od(pb, ld) = nb
'      add_identifier cNew, invisible_names.Item(iName), vName
pd md, pb.Item(kd), ld
'    'else identifier is on visible list, so elide it from invisible list

'    End If
End If
'  Next iName
Next kd
'

'  Set invisible_names = cNew
Set pb = md
'

'End Sub
End Sub
'

'' returns the (possibly obfuscated, transformed) variable

'' name given the original variable name

'

'Private Function var_name(plaintextVarname As String) As String
Private Function qd(rd As String) As String
'  Dim result As String
Dim wc As String
'  result = lookup_identifier(invisible_names, LCase(plaintextVarname))
wc = od(pb, LCase(rd))
'  If (result = NO_SUCH_ID) Then
If (wc = nb) Then
'  ' just keep the original name except converted to lowercase

'    result = LCase(plaintextVarname)
wc = LCase(rd)
'  End If
End If
'  var_name = result
qd = wc
'End Function
End Function
'

'' clears all of the elements in the lookup table

'Private Sub reset_lookup_table(lookup_table As Collection)
Private Sub sd(td As Collection)
'  Set lookup_table = New Collection
Set td = New Collection
'End Sub
End Sub
'

'' returns numeric id associated with given name, or NO_SUCH_ID

'Private Function lookup_identifier(c As Collection, sName As String) As String
Private Function od(vc As Collection, ud As String) As String
'  Dim result As String
Dim wc As String
'  On Error GoTo not_found
On Error GoTo vd
'  result = c.Item(LCase(sName))
wc = vc.Item(LCase(ud))
'  GoTo end_of_function
GoTo wd
'not_found:
vd:
'  result = NO_SUCH_ID
wc = nb
'end_of_function:
wd:
'  lookup_identifier = result
od = wc
'End Function
End Function
'

'Private Sub remove_identifier(c As Collection, sName As String)
Private Sub xd(vc As Collection, ud As String)
'  If (lookup_identifier(c, sName) <> NO_SUCH_ID) Then
If (od(vc, ud) <> nb) Then
'    c.Remove LCase(sName)
vc.Remove LCase(ud)
'  End If
End If
'End Sub
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)
Private Sub pd(vc As Collection, ud As String, yd As String)
'  If (NO_SUCH_ID = lookup_identifier(c, sName)) Then
If (nb = od(vc, ud)) Then
'    c.Add LCase(sValue), LCase(sName)
vc.Add LCase(yd), LCase(ud)
'  End If
End If
'End Sub
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
Private Function zd(tc As String, ae As String) As Integer
'   Dim iFound As Integer
Dim be As Integer
'   Dim iNext As Integer
Dim ce As Integer
'

'   iFound = 0
be = 0
'   iNext = InStr(1, s, subS)
ce = InStr(1, tc, ae)
'   Do While (iNext > 0)
Do While (ce > 0)
'     iFound = iNext
be = ce
'     iNext = InStr(iFound + 1, s, subS)
ce = InStr(be + 1, tc, ae)
'   Loop
Loop
'

'   last_substring_position = iFound
zd = be
'

'End Function
End Function
'

'' location of the event delimiter ("_") within the token, or 0 if none.

'

'Private Function event_delimiter_position(token As String) As Integer
Private Function de(ee As String) As Integer
'   event_delimiter_position = last_substring_position(token, userform_event_delimiter)
de = zd(ee, hb)
'End Function
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
Private Function fe(ee As String) As String
'  Dim iPosition As Integer
Dim ge As Integer
'  Dim result As String
Dim wc As String
'

'  iPosition = event_delimiter_position(token)
ge = de(ee)
'  If (iPosition = 0) Then
If (ge = 0) Then
'    result = NO_SUCH_ID
wc = nb
'  Else
Else
'    result = Right(token, Len(token) - (iPosition + Len(userform_event_delimiter) - 1))
wc = Right(ee, Len(ee) - (ge + Len(hb) - 1))
'  End If
End If
'

'  event_part = result
fe = wc
'

'End Function
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
Private Function he(ee As String) As String
'  Dim iPosition As Integer
Dim ge As Integer
'  Dim result As String
Dim wc As String
'

'  iPosition = event_delimiter_position(token)
ge = de(ee)
'  If (iPosition = 0) Then
If (ge = 0) Then
'    result = NO_SUCH_ID
wc = nb
'  Else
Else
'    result = Left(token, iPosition - 1)
wc = Left(ee, ge - 1)
'  End If
End If
'

'  object_part = result
he = wc
'

'End Function
End Function
'

'' does the token represent an event procedure name (e.g. myButton_Click) ?

'Private Function is_event_procedure(token As String) As Boolean
Private Function ie(ee As String) As Boolean
'   Dim sEvent As String
Dim je As String
'   Dim result As String
Dim wc As String
'   sEvent = event_part(token)
je = fe(ee)
'   If (sEvent = NO_SUCH_ID) Then
If (je = nb) Then
'     result = False
wc = False
'   ElseIf (NO_SUCH_ID = lookup_identifier(userform_attribute_names, sEvent)) Then
ElseIf (nb = od(qb, je)) Then
'      result = False
wc = False
'   Else
Else
'      result = True
wc = True
'   End If
End If
'   is_event_procedure = result
ie = wc
'End Function
End Function
'

'' does the given string begin with the specified prefix?

'Private Function has_prefix(s As String, prefix As String) As Boolean
Private Function ke(tc As String, le As String) As Boolean
'   has_prefix = (Left(s, Len(prefix)) = prefix)
ke = (Left(tc, Len(le)) = le)
'End Function
End Function
'

'' does the given string end with the specified suffix?

'Private Function has_suffix(s As String, suffix As String) As Boolean
Private Function ne(tc As String, oe As String) As Boolean
'   has_suffix = (Right(s, Len(suffix)) = suffix)
ne = (Right(tc, Len(oe)) = oe)
'End Function
End Function
'

'' sets token buffer to the default, "do nothing", token sequence

'Private Sub reset_token_buffer()
Private Sub pe()
'  Dim i As Integer
Dim fd As Integer
'  For i = LBound(prevTokens) To UBound(prevTokens)
For fd = LBound(mc) To UBound(mc)
'    prevTokens(i) = " "      ' use whitespace because leading whitespace cannot change how a program is parsed
mc(fd) = " "
'  Next i                     ' (the default "" isn't a valid token and can therefore cause problems)
Next fd
'  tokenIndex = LBound(prevTokens)
nc = LBound(mc)
'End Sub
End Sub
'

'' write the token into the circular token buffer

'Private Sub remember_token(token As String)
Private Sub qe(ee As String)
'  tokenIndex = (tokenIndex + 1) Mod N_BUFFERED_TOKENS
nc = (nc + 1) Mod lc
'  prevTokens(tokenIndex) = token
mc(nc) = ee
'End Sub
End Sub
'

'' returns the last token stored in the token buffer

'Private Function last_token() As String
Private Function re() As String
'  last_token = prevTokens(tokenIndex)
re = mc(nc)
'End Function
End Function
'

'' returns next-to-the-last token stored in the token buffer

'Private Function next_to_last_token() As String
Private Function se() As String
'   Dim result As String
Dim wc As String
'   If (tokenIndex = LBound(prevTokens)) Then
If (nc = LBound(mc)) Then
'      result = prevTokens(UBound(prevTokens))   ' wrap-around to last element
wc = mc(UBound(mc))
'   Else
Else
'      result = prevTokens(tokenIndex - 1)      ' no-wrap-around needed
wc = mc(nc - 1)
'   End If
End If
'  next_to_last_token = result
se = wc
'End Function
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
Private Function te(ee As String) As Boolean
'  is_userform_attribute = (NO_SUCH_ID <> lookup_identifier(userform_attribute_names, token))
te = (nb <> od(qb, ee))
'End Function
End Function
'

'' adds ids contained in the string 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)
Private Sub register_ids(tc As String)
'  Dim iStart As Integer
Dim uc As Integer
'  Dim iEnd As Integer
Dim yc As Integer
'  Dim visible As Boolean
Dim visible As Boolean
'  Dim obfuscated_id As Long
Dim ue As Long
'  Dim token As String
Dim ee As String
'

'  If InStr(1, LCase(s), BEGIN_VISIBLE_KEYWORD) <> 0 Then
If InStr(1, LCase(tc), begin_visible_keyword) <> 0 Then
'    m_visible_depth = m_visible_depth + 1
mb = mb + 1
'  End If
End If
'  If InStr(1, LCase(s), END_VISIBLE_KEYWORD) <> 0 Then
If InStr(1, LCase(tc), kb) <> 0 Then
'    m_visible_depth = m_visible_depth - 1
mb = mb - 1
'  End If
End If
'

'  If InStr(1, LCase(s), VISIBLE_KEYWORD) > 0 Then
If InStr(1, LCase(tc), visible_keyword) > 0 Then
'  ' single line #visible keyword makes ids on this line visible, no

'  ' matter what our visible depth is

'    visible = True
visible = True
'  Else
Else
'    ' no line specific keyword, so based on if we are within

'    ' a #begin_visible ... #end_visible bracketed region

'    visible = m_visible_depth > 0
visible = mb > 0
'  End If
End If
'

'  iStart = 1
uc = 1
'  Do While (iStart <= Len(s))
Do While (uc <= Len(tc))
'    iEnd = end_of_token(s, iStart)
yc = xc(tc, uc)
'    token = LCase(Mid(s, iStart, iEnd - iStart))
ee = LCase(Mid(tc, uc, yc - uc))
'

'    If (token_type(token, 1) = TT_IDENTIFIER) Then
If (sc(ee, 1) = j) Then
'

'      If (last_token() = userform_control_attribute_flag) Then
If (re() = ib) 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
pd qb, ee, ee
'        add_identifier visible_names, token, token
pd ob, ee, ee
'      ElseIf (is_event_procedure(token)) Then
ElseIf (ie(ee)) 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
pd ob, ee, ee
'        add_identifier visible_names, object_part(token), object_part(token)
pd ob, he(ee), he(ee)
'      ElseIf (is_userform_attribute(token) And _
                last_token() = object_attribute_delimiter And token_type(next_to_last_token(), 1) = TT_IDENTIFIER) Then
ElseIf (te(ee) And _
 re() = jb And sc(se(), 1) = j) 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()
pd ob, se(), se()
'      ElseIf (visible) Then
ElseIf (visible) Then
'        add_identifier visible_names, token, token
pd ob, ee, ee
'      Else
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).

'        add_identifier invisible_names, token, token
pd pb, ee, ee
'      End If
End If
'    ' else not an identifier, so it can never be added to lookup tables

'    ' used to determine token visibility.

'    End If
End If
'

'    remember_token token   ' stores last few token in a circular buffer for easier parsing
qe ee
'

'    iStart = iEnd
uc = yc
'  Loop
Loop
'

'End Sub
End Sub
'

'' the length of a string, excluding and leading/trailing double quotes

'Private Function length_sans_quotes(s As String) As Integer
Private Function ve(tc As String) As Integer
'  Dim result As Integer
Dim wc As Integer
'  result = Len(s)
wc = Len(tc)
'  If (has_prefix(s, dQuote)) Then result = result - Len(dQuote)
If (ke(tc, x)) Then wc = wc - Len(x)
'  If (has_suffix(s, dQuote)) Then result = result - Len(dQuote)
If (ne(tc, x)) Then wc = wc - Len(x)
'  length_sans_quotes = result
ve = wc
'End Function
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
Private Function we(tc As String, le As String) As Integer
'  Dim result As Integer
Dim wc As Integer
'  If (has_prefix(s, prefix)) Then
If (ke(tc, le)) Then
'     result = Len(prefix)
wc = Len(le)
'  Else
Else
'     result = 0
wc = 0
'  End If
End If
'  length_of_prefix = result
we = wc
'End Function
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
Private Function xe(tc As String) As String
'  NQ = Mid(s, 1 + length_of_prefix(s, dQuote), length_sans_quotes(s))
xe = Mid(tc, 1 + we(tc, x), ve(tc))
'End Function
End Function
'

'' adds double quotes around the given string

'Private Function Q(s As String) As String
Private Function ye(tc As String) As String
' Q = dQuote & s & dQuote
ye = x & tc & x
'End Function
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
Private Function ze(tc As String) As String
'  Dim result As String
Dim wc As String
'  Dim iStart As Integer
Dim uc As Integer
'  Dim iEnd As Integer
Dim yc As Integer
'  Dim token As String
Dim ee As String
'

'  result = ""
wc = ""
'

'  iStart = 1
uc = 1
'

'  Do While (iStart <= Len(s))
Do While (uc <= Len(tc))
'    iEnd = end_of_token(s, iStart)
yc = xc(tc, uc)
'    token = Mid(s, iStart, iEnd - iStart)
ee = Mid(tc, uc, yc - uc)
'    Select Case (token_type(token, 1))
Select Case (sc(ee, 1))
'      Case TT_IDENTIFIER
Case j
'        result = result & var_name(token)
wc = wc & qd(ee)
'      Case TT_WHITESPACE
Case n
'        result = result & " "
wc = wc & " "
'      Case TT_NUMBER
Case l
'        result = result & token
wc = wc & ee
'      Case TT_STRING
Case k
'        result = result & token
wc = wc & ee
'      Case TT_COMMENT
Case m
'        If (has_prefix(token, doubleComment)) Then
If (ke(ee, db)) Then
'          ' double comments are retained (for copywrite notices, etc.)

'          result = result & Right(token, Len(token) - Len(firstCommentChar))
wc = wc & Right(ee, Len(ee) - Len(cb))
'        ' else just ignore/elide the comment

'        End If
End If
'      Case TT_GUID
Case o
'        result = result & token
wc = wc & ee
'      Case TT_OTHER
Case p
'        result = result & token
wc = wc & ee
'      Case Else
Case Else
'         assert False  ' should have been type "other"
assert False
'    End Select
End Select
'    iStart = iEnd
uc = yc
'  Loop
Loop
'

'' trim to drop any leading whitespace (makes lines all flush left)

'  obfuscated_line = Trim(result)
ze = Trim(wc)
'

'End Function
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)
Private Sub af(cf As String)
'  Dim fid As Integer
Dim df As Integer
'  Dim sLine As String
Dim ef As String
'  Dim errNo As Long
Dim ff As Long
'  On Error GoTo error_exit
On Error GoTo error_exit
'

'' open file for reading

'  fid = freefile()
df = freefile()
'  Open fName For Input As #fid
Open cf For Input As #df
'

'' read each (possibly continued) line, registering its ids

'  Do While Not EOF(fid)
Do While Not EOF(df)
'    sLine = get_continued_line(fid)
ef = gf(df)
'    register_ids sLine
register_ids ef
'  Loop
Loop
'

'  Close fid
Close df
'  GoTo end_of_sub
GoTo hf
'error_exit:
error_exit:
'  errNo = Err.Number
ff = Err.Number
'  On Error Resume Next
On Error Resume Next
'  Close fid
Close df
'  Err.Raise errNo
Err.Raise ff
'

'end_of_sub:
hf:
'End 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
Private Function jf(ef As String) As Boolean
'  is_continued_line = has_suffix(sLine, line_continuation_chars)
jf = ne(ef, eb)
'End Function
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
Private Function kf(lf As String, mf As String) As String
'  Dim result As String
Dim wc As String
'  If (sOld = "") Then
If (lf = "") Then
'    result = sNew
wc = mf
'  Else
Else
'    result = sOld & vbNewLine & sNew
wc = lf & vbNewLine & mf
'  End If
End If
'  add_line = result
kf = wc
'End Function
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
Private Function gf(nf As Integer) As String
'  Dim result As String
Dim wc As String
'  Dim sTmp As String
Dim pf As String
'  result = ""
wc = ""
'  Do ' read & concatenate continued lines
Do
'    Line Input #f_in, sTmp
Line Input #nf, pf
'    result = add_line(result, sTmp)
wc = kf(wc, pf)
'  Loop Until EOF(f_in) Or Not is_continued_line(sTmp)
Loop Until EOF(nf) Or Not jf(pf)
'

'  get_continued_line = result
gf = wc
'

'End Function
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)
Private Sub qf( _
 rf As String, sf As String)
'  Dim f_in As Integer
Dim nf As Integer
'  Dim f_out As Integer
Dim tf As Integer
'  Dim sLine As String
Dim ef As String
'  Dim sObfuscated As String
Dim uf As String
'  Dim errNo As Long
Dim ff As Long
'  On Error GoTo error_exit
On Error GoTo error_exit
'

'  f_in = freefile()
nf = freefile()
'  Open f_plain For Input As #f_in
Open rf For Input As #nf
'  f_out = freefile()
tf = freefile()
'  Open f_obfuscated For Output As #f_out
Open sf For Output As #tf
'

'' obfuscate, and then write, each original input source code

'' file line into the obfuscated source code output file

'  Do While Not EOF(f_in)
Do While Not EOF(nf)
'    sLine = get_continued_line(f_in)
ef = gf(nf)
'    sObfuscated = obfuscated_line(sLine)
uf = ze(ef)
'    If (m_interleave_original_code_as_comments) Then
If (rb) Then
'      Print #f_out, firstCommentChar & sLine
Print #tf, cb & ef
'      Print #f_out, sObfuscated               ' empty obfuscated lines retained--helpful when debugging.
Print #tf, uf
'    ElseIf (sObfuscated <> "") Then
ElseIf (uf <> "") Then
'      Print #f_out, sObfuscated
Print #tf, uf
'    ' else elide lines that are empty after obfuscation

'    End If
End If
'

'  Loop
Loop
'

'  Close f_in
Close nf
'  Close f_out
Close tf
'  GoTo end_of_sub
GoTo hf
'error_exit:
error_exit:
'  errNo = Err.Number
ff = Err.Number
'  On Error Resume Next
On Error Resume Next
'  Close f_in
Close nf
'  On Error Resume Next
On Error Resume Next
'  Close f_out
Close tf
'  Err.Raise errNo
Err.Raise ff
'

'end_of_sub:
hf:
'

'End 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
Private Function vf(wf As Workbook, _
 xf As Integer, Optional yf = ".tmp") As String
'  temp_file_name = wb.Path & PS() & IB_TEMP_FILENAME_PREFIX & _
                   CStr(iFile) & extension
vf = wf.Path & oc() & ub & _
 CStr(xf) & yf
'End Function
End Function
'

'' returns a random module name suitable for use as a VBA code module

'Private Function random_module_name() As String
Private Function zf() 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")
zf = "qzx" & _
 Format(10 ^ 6 * Rnd(), "000000") & Format(10 ^ 6 * Rnd(), "000000")
'End Function
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)
Private Sub ag(vbc As Object, f As String)
'  Dim f_out As Integer
Dim tf As Integer
'  Dim iLine As Long
Dim bg As Long
'  Dim errNo As Long
Dim ff As Long
'  On Error GoTo error_exit
On Error GoTo error_exit
'

'  f_out = freefile()
tf = freefile()
'  Open f For Output As #f_out
Open f For Output As #tf
'

'  For iLine = 1 To vbc.CodeModule.CountOfLines
For bg = 1 To vbc.codemodule.countoflines
'    Print #f_out, vbc.CodeModule.Lines(startLine:=iLine, Count:=1)
Print #tf, vbc.codemodule.Lines(startline:=bg, Count:=1)
'  Next iLine
Next bg
'

'  Close f_out
Close tf
'  GoTo end_of_sub
GoTo hf
'error_exit:
error_exit:
'  errNo = Err.Number
ff = Err.Number
'  On Error Resume Next
On Error Resume Next
'  Close f_out
Close tf
'  Err.Raise errNo
Err.Raise ff
'

'end_of_sub:
hf:
'

'End 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)
Private Sub cg(vbc As Object, f As String)
'  Dim f_in As Integer
Dim nf As Integer
'  Dim sLine As String
Dim ef As String
'  Dim iLine As Long
Dim bg As Long
'  Dim errNo As Long
Dim ff As Long
'  On Error GoTo error_exit
On Error GoTo error_exit
'

'  vbc.CodeModule.DeleteLines startLine:=1, Count:=vbc.CodeModule.CountOfLines
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()
nf = freefile()
'  Open f For Input As #f_in
Open f For Input As #nf
'  iLine = 1
bg = 1
'  Do While Not EOF(f_in) ' read each source code line and insert into component
Do While Not EOF(nf)
'    Line Input #f_in, sLine
Line Input #nf, ef
'    vbc.CodeModule.InsertLines iLine, sLine
vbc.codemodule.insertlines bg, ef
'    iLine = iLine + 1
bg = bg + 1
'  Loop
Loop
'

'  Close f_in
Close nf
'  GoTo end_of_sub
GoTo hf
'error_exit:
error_exit:
'  errNo = Err.Number
ff = Err.Number
'  On Error Resume Next
On Error Resume Next
'  Close f_in
Close nf
'  Err.Raise errNo
Err.Raise ff
'

'end_of_sub:
hf:
'

'End Sub
End Sub
'

'' obfuscates all VBA source code modules, classes and UserForms

'

'Private Sub obfuscate_workbook(wb As Workbook)
Private Sub dg(wf As Workbook)
'  Dim vbc As Object
Dim vbc As Object
'  Dim iFile As Integer
Dim xf As Integer
'  Dim tmpFile As String
Dim eg As String
'  Dim old_display_status_bar As Boolean
Dim fg As Boolean
'  Dim newName As String
Dim newname As String
'

'  old_display_status_bar = Application.DisplayStatusBar
fg = Application.DisplayStatusBar
'  Application.DisplayStatusBar = True
Application.DisplayStatusBar = True
'

'  Application.StatusBar = "Saving Invisibly: initializing..."
Application.StatusBar = "Saving Invisibly: initializing..."
'' start with empty variable name identifier tables

'  reset_lookup_table visible_names
sd ob
'  reset_lookup_table invisible_names
sd pb
'  reset_lookup_table userform_attribute_names
sd qb
'  reset_token_buffer
pe
'' 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_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) <> ""
assert Dir(ThisWorkbook.Path & oc() & r) <> ""
'  m_visible_depth = 1
mb = 1
'  register_identifiers ThisWorkbook.Path & PS() & IB_VISIBLE_KEYWORDS_FILENAME
af ThisWorkbook.Path & oc() & r
'  m_visible_depth = 0
mb = 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
For xf = 1 To wf.VBProject.vbcomponents.Count
'    Set vbc = wb.VBProject.VBComponents(iFile)
Set vbc = wf.VBProject.vbcomponents(xf)
'    Select Case vbc.Type
Select Case vbc.Type
'      Case IB_vbext_ct_StdModule, IB_vbext_ct_ClassModule, IB_vbext_ct_MSForm
Case hc, ic, jc
'      ' the name of a module, class, or userform is obfuscated

'      ' (normal case). Register the name as "invisible"

'        m_visible_depth = 0
mb = 0
'        register_ids vbc.Name
register_ids vbc.Name
'      Case IB_vbext_ct_Document
Case kc
'      ' 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"
register_ids vbc.Name & " '#visible"
'      Case Else
Case Else
'         ' if Microsoft adds a new type, play it safe by keeping

'         ' names unchanged ("visible").

'         register_ids vbc.Name & " '#visible"
register_ids vbc.Name & " '#visible"
'    End Select
End Select
'    Application.StatusBar = "Saving Invisibly: Pass 1 of 2, VBComponent " & CStr(iFile) & " of " & CStr(wb.VBProject.VBComponents.Count)
Application.StatusBar = "Saving Invisibly: Pass 1 of 2, VBComponent " & CStr(xf) & " of " & CStr(wf.VBProject.vbcomponents.Count)
'    write_component_code vbc, temp_file_name(wb, iFile)
ag vbc, vf(wf, xf)
'    m_visible_depth = 0 ' invisible unless otherwise noted
mb = 0
'    reset_token_buffer
pe
'    register_identifiers temp_file_name(wb, iFile)
af vf(wf, xf)
'  Next iFile
Next xf
'

'  define_obfuscated_names  'choose obscure ids for invisible names
jd
'

'' 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)
eg = vf(wf, wf.VBProject.vbcomponents.Count + 1)
'  For iFile = 1 To wb.VBProject.VBComponents.Count
For xf = 1 To wf.VBProject.vbcomponents.Count
'    Set vbc = wb.VBProject.VBComponents(iFile)
Set vbc = wf.VBProject.vbcomponents(xf)
'

'    newName = obfuscated_line(vbc.Name)
newname = ze(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
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)
Application.StatusBar = "Saving Invisibly: Pass 2 of 2, VBComponent " & CStr(xf) & " of " & CStr(wf.VBProject.vbcomponents.Count)
'    reset_token_buffer
pe
'    obfuscate_sourcecode_file temp_file_name(wb, iFile), tmpFile
qf vf(wf, xf), eg
'    read_component_code vbc, tmpFile
cg vbc, eg
'    Kill tmpFile
Kill eg
'    Kill temp_file_name(wb, iFile)
Kill vf(wf, xf)
'  Next iFile
Next xf
'

'  Application.StatusBar = False  ' restore status bar status quo
Application.StatusBar = False
'  Application.DisplayStatusBar = old_display_status_bar
Application.DisplayStatusBar = fg
'

'End Sub
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
Private Function gg(hg As String, ig As String) As Boolean
'  Dim f1 As String
Dim jg As String
'  Dim f2 As String
Dim kg As String
'  Dim result As Boolean
Dim wc As Boolean
'

'  f1 = Trim(LCase(f1_in))
jg = Trim(LCase(hg))
'  f2 = Trim(LCase(f2_in))
kg = Trim(LCase(ig))
'

'' making each filename start with path separator simplifies the tests:

'  If (Not has_prefix(f1, PS())) Then f1 = PS() & f1
If (Not ke(jg, oc())) Then jg = oc() & jg
'  If (Not has_prefix(f2, PS())) Then f2 = PS() & f2
If (Not ke(kg, oc())) Then kg = oc() & kg
'

'' 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
If (ne(jg, kg) Or ne(kg, jg)) Then
'    result = False
wc = False
'  Else
Else
'    ' filenames definitely represent different files

'    result = True
wc = True
'  End If
End If
'

'  are_different_files = result
gg = wc
'

'End Function
End Function
'

'' obfuscates the given workbook, saving it into the specified file

'

'Public Sub obfuscate_workbook_as(wb As Workbook, fileName As String)
Public Sub lg(wf As Workbook, filename As String)
'

'  assert are_different_files(wb.fullName, fileName)
assert gg(wf.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
wf.SaveAs filename
'  obfuscate_workbook wb
dg wf
'  Application.DisplayAlerts = False
Application.DisplayAlerts = False
'  wb.SaveAs fileName     ' save again under the new name
wf.SaveAs filename
'  Application.DisplayAlerts = True
Application.DisplayAlerts = True
'

'End Sub
End Sub
'

'' default filename in which to store "invisible" version

'Private Function ib_initial_filename(wb As Workbook) As String
Private Function mg(wf As Workbook) As String
'  Dim dot_position As Integer
Dim ng As Integer
'  Dim result As String
Dim wc As String
'  dot_position = last_substring_position(wb.Name, ".")
ng = zd(wf.Name, ".")
'  If (dot_position = 0) Then
If (ng = 0) Then
'    result = wb.Path & PS() & wb.Name & IB_FILENAME_SUFFIX
wc = wf.Path & oc() & wf.Name & lb
'  Else
Else
'    result = wb.Path & PS() & Left(wb.Name, dot_position - 1) & _
      IB_FILENAME_SUFFIX & Right(wb.Name, Len(wb.Name) - (dot_position - 1))
wc = wf.Path & oc() & Left(wf.Name, ng - 1) & _
 lb & Right(wf.Name, Len(wf.Name) - (ng - 1))
'  End If
End If
'  ib_initial_filename = result
mg = wc
'End Function
End Function
'

'' Save the active workbook invisibly in a user-selected workbook

'

'Private Sub ib_save_invisibly_as()
Private Sub og()
'  Dim fileName As String
Dim filename As String
'  Dim wb As Workbook
Dim wf As Workbook
'  On Error GoTo error_exit
On Error GoTo error_exit
'

'  Set wb = ActiveWorkbook
Set wf = ActiveWorkbook
'  If (Not wb.saved) Then
If (Not wf.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."
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
GoTo hf
'  End If
End If
'' present a "save as" type filename dialog

'  fileName = Application.GetSaveAsFilename( _
             InitialFilename:=ib_initial_filename(wb), _
             FileFilter:="Microsoft Excel Workbook (*.xls),*.xls,All Files (*.*),*.*", _
             Title:="Select file into which workbook will be saved invisibly")
filename = Application.GetSaveAsFilename( _
 initialfilename:=mg(wf), _
 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
If (Not gg(wf.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"
MsgBox "The selected filename (" & filename & _
 ") must be clearly different from the current workbook's filename (" & wf.FullName & _
 "). Try again, next time choosing a different name.", _
 vbCritical, "Save Invisibly As Filename Must Differ from Original Filename"
'  ElseIf (fileName <> "False") Then
ElseIf (filename <> "False") Then
'    obfuscate_workbook_as wb, fileName
lg wf, filename
'  End If
End If
'

'  GoTo end_of_sub
GoTo hf
'error_exit:
error_exit:
'  Application.DisplayAlerts = True
Application.DisplayAlerts = True
'  Application.StatusBar = False  ' resume default status bar behavior
Application.StatusBar = False
'  MsgBox "Error #" & CStr(Err.Number) & " during ""Save Invisibly As"": " & Err.Description, _
           vbCritical, "Invisible Basic Save Invisibly As Error"
MsgBox "Error #" & CStr(Err.Number) & " during ""Save Invisibly As"": " & Err.Description, _
 vbCritical, "Invisible Basic Save Invisibly As Error"
'end_of_sub:
hf:
'

'

'End Sub
End Sub
'

'' Top level "Save Invisibly As..." command

'

'Public Sub invisible_basic_save_invisibly_as()
Public Sub pg()
'  m_interleave_original_code_as_comments = False
rb = False
'  ib_save_invisibly_as
og
'End Sub
End Sub
'

'

'' Top level "Debugging Save Invisibly As..." command

'

'Public Sub invisible_basic_debugging_save_invisibly_as()
Public Sub qg()
'  m_interleave_original_code_as_comments = True
rb = True
'  ib_save_invisibly_as
og
'End Sub
End Sub
'

'Private Sub visit_url(url As String)
Private Sub rg(sg As String)
'  ShellExecute GetDesktopWindow(), "Open", url, 0, 0, SW_SHOWMAXIMIZED
xb vb(), "Open", sg, 0, 0, fc
'End Sub
End Sub
'

'' Just shows the HTML file that contains the InvisibleBasic help file

'Public Sub invisible_basic_show_help()
Public Sub tg()
'  visit_url ThisWorkbook.Path & PS() & "InvisibleBasic.html"
rg ThisWorkbook.Path & oc() & "InvisibleBasic.html"
'End Sub
End Sub
'

'Public Sub invisible_basic_add_menu()
Public Sub d()
'  Dim cbp As CommandBarPopup   ' new invisible basic menu bar
Dim cbp As ug
'  Dim cbb As CommandBarButton  ' new menu item added to this bar
Dim cbb As vg
'

'  Call invisible_basic_remove_menu  ' to prevent adding menu twice
Call g
'

'  Set cbp = Application.CommandBars(IB_NameOfExcelWorksheetMenubar).Controls.Add( _
    Type:=msoControlPopup)
Set cbp = Application.wg(tb).xg.Add( _
 Type:=yg)
'

'  cbp.caption = IB_NameOfInvisibleBasicMenu
cbp.caption = sb
'  cbp.tooltiptext = _
"Source code obfuscation utility for Excel/VBA applications."
cbp.zg = _
"Source code obfuscation utility for Excel/VBA applications."
'

' Set cbb = cbp.Controls.Add(Type:=msoControlButton)
Set cbb = cbp.xg.Add(Type:=ah)
' cbb.caption = "&Save Invisibly As..."
cbb.caption = "&Save Invisibly As..."
' cbb.DescriptionText = "Saves copy of workbook whose VBA code is replaced with equivalant, but hard-to-read, code."
cbb.bh = "Saves copy of workbook whose VBA code is replaced with equivalant, but hard-to-read, code."
' cbb.onAction = "invisible_basic_save_invisibly_as"
cbb.OnAction = "invisible_basic_save_invisibly_as"
'

' Set cbb = cbp.Controls.Add(Type:=msoControlButton)
Set cbb = cbp.xg.Add(Type:=ah)
' cbb.caption = "&Debugging Save Invisibly As..."
cbb.caption = "&Debugging Save Invisibly As..."
' cbb.DescriptionText = "Same as Save Invisibly As except interleaves original source code as comments (for debugging)."
cbb.bh = "Same as Save Invisibly As except interleaves original source code as comments (for debugging)."
' cbb.onAction = "invisible_basic_debugging_save_invisibly_as"
cbb.OnAction = "invisible_basic_debugging_save_invisibly_as"
'

' Set cbb = cbp.Controls.Add(Type:=msoControlButton)
Set cbb = cbp.xg.Add(Type:=ah)
' cbb.caption = "&Help..."
cbb.caption = "&Help..."
' cbb.DescriptionText = "Invisible Basic Help"
cbb.bh = "Invisible Basic Help"
' cbb.onAction = "invisible_basic_show_help"
cbb.OnAction = "invisible_basic_show_help"
'

'End Sub
End Sub
'

'Public Sub invisible_basic_remove_menu()
Public Sub g()
'  On Error Resume Next
On Error Resume Next
'  Application.CommandBars(IB_NameOfExcelWorksheetMenubar).Controls( _
    IB_NameOfInvisibleBasicMenu).Delete
Application.wg(tb).xg( _
 sb).Delete
'End Sub
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()
Public Sub ch()
'  Dim wb As Workbook
Dim wf As Workbook
'  Dim fTest As String
Dim dh As String
'  Dim fObf As String
Dim eh As String
'  Dim iPass As Integer
Dim fh As Integer
'

'  assert event_part("myButton_Click") = "Click"
assert fe("myButton_Click") = "Click"
'  assert object_part("myButton_Click") = "myButton"
assert he("myButton_Click") = "myButton"
'  assert event_part("myButtonClick") = ""
assert fe("myButtonClick") = ""
'  assert event_part("myButton_20_Click") = "Click"
assert fe("myButton_20_Click") = "Click"
'  assert object_part("myButton_20_Click") = "myButton_20"
assert he("myButton_20_Click") = "myButton_20"
'

'  For iPass = 1 To 2
For fh = 1 To 2
'

'    If (iPass = 1) Then
If (fh = 1) Then
'      invisiblebasic.interleave_original_code_as_comments = False
h.pc = False
'    Else
Else
'      invisiblebasic.interleave_original_code_as_comments = True
h.pc = True
'    End If
End If
'

'    fTest = ThisWorkbook.Path & PS() & "IB_Test.xls"
dh = ThisWorkbook.Path & oc() & "IB_Test.xls"
'    fObf = ThisWorkbook.Path & PS() & "IB_Test_Obf.xls"
eh = ThisWorkbook.Path & oc() & "IB_Test_Obf.xls"
'' Open the test workbook

'    Workbooks.Open fTest
Workbooks.Open dh
'    Set wb = Workbooks(Workbooks.Count)
Set wf = Workbooks(Workbooks.Count)
'

'    ' Save it invisibly as a new workbook

'

'    obfuscate_workbook_as wb, fObf
lg wf, eh
'

'    ' the test module exercies code in the obfuscated modules in IB_Test

'    ' and compares results with expected results.

'

'    Evaluate "IBTest.testModule.ibt_test()"
Evaluate "IBTest.testModule.ibt_test()"
'

'    wb.Close SaveChanges:=False
wf.Close savechanges:=False
'

'  Next iPass
Next fh
'End Sub
End Sub
'

'

'

'

'

'