The code below was produced by saving the Workbook used to implement the Invisible Basic Add-in via Invisible Basic's "Save Invisibly As" command.
This version illustrates the kind of thing a competitor would see if they cracked your password. However, it's easier to understand what Invisible Basic is doing if you look at the output from the "Debugging Save Invisibly As" command, which interleaves the original code as comments for troubleshooting purposes. Or check out the original invisblebasic.bas code itself in the CVS repository.
Return to Invisible Basic Home Page
Note: the code on these "dog food" pages is from an earlier version of Invisible Basic. For the latest code, download Invisible Basic or browse the CVS repository.
Option Explicit
Private Const j As Integer = 1
Private Const k As Integer = 2
Private Const l As Integer = 3
Private Const m As Integer = 4
Private Const n As Integer = 5
Private Const o As Integer = 6
Private Const p As Integer = 7
Private Const r = "visible_names.txt"
Private Const t As String = " " & vbTab
Private Const u As String = "abcdefghijklmnopqrstuvwxyz"
Private Const v As String = "_"
Private Const w As String = "0123456789"
Private Const x As String = """"
Private Const y As String = "{"
Private Const z As String = "}"
Private Const ab As String = w
Private Const bb As String = ab & "."
Private Const cb As String = "'"
Private Const db As String = cb & cb
Private Const eb As String = " " & v
Private Const fb As String = u
Private Const gb As String = u & v & w
Private Const hb As String = v
Private Const ib As String = v
Private Const jb As String = "."
Private Const visible_keyword As String = "#visible"
Private Const begin_visible_keyword As String = "#begin_visible"
Private Const kb As String = "#end_visible"
Private Const lb As String = "_ib"
Private mb As Long
Private Const nb As String = ""
Private ob As New Collection
Private pb As New Collection
Private qb As New Collection
Private rb As Boolean
Private Const sb As String = "Invisible&Basic"
Private Const tb As String = _
"Worksheet Menu Bar"
Private Const ub = "InvBas_Temp_"
Private Declare Function vb Lib "user32" () 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 ec As Long = 1
Private Const fc As Long = 3
Private Const gc As Long = 10
Private Const hc As Long = 1
Private Const ic As Long = 2
Private Const jc As Long = 3
Private Const kc As Long = 100
Private Const lc As Integer = 3
Private mc(0 To lc - 1) As String
Private nc As Integer
Private Function oc() As String
oc = Application.PathSeparator
End Function
Public Property Get pc() As Boolean
pc = rb
End Property
Public Property Let pc(qc As Boolean)
rb = qc
End Property
Private Sub assert(rc As Boolean)
If (Not rc) Then Stop
End Sub
Private Function sc(tc As String, _
uc As Integer) As Integer
Dim vc As String
Dim wc As Integer
assert 1 <= uc And uc <= Len(tc)
vc = LCase(Mid(tc, uc, 1))
If (InStr(1, t, vc) <> 0) Then
wc = n
ElseIf (InStr(1, fb, vc) <> 0) Then
wc = j
ElseIf (vc = x) Then
wc = k
ElseIf (vc = y) Then
wc = o
ElseIf (InStr(1, ab, vc) <> 0) Then
wc = l
ElseIf (cb = vc) Then
wc = m
Else
wc = p
End If
sc = wc
End Function
Private Function xc(tc As String, _
uc As Integer) As Integer
Dim yc As Integer
Dim zc As Integer
Dim ad As String
Dim bd As Boolean
Dim cd As Boolean
Dim vc As String
zc = sc(tc, uc)
Select Case (zc)
Case j
ad = gb
bd = False
Case k
ad = x
bd = True
Case o
ad = z
bd = True
Case l
ad = bb
bd = False
Case m
ad = ""
bd = True
Case n
ad = t
bd = False
Case p
ad = fb & ab & _
cb & x & t & y
bd = True
End Select
yc = uc + 1
Do While (yc <= Len(tc))
vc = LCase(Mid(tc, yc, 1))
cd = InStr(1, ad, vc) <> 0
If (bd) Then cd = Not cd
If (Not cd) Then Exit Do
yc = yc + 1
Loop
If ((zc = k And vc = x) Or _
(zc = o And vc = z)) Then
yc = yc + 1
End If
xc = yc
End Function
Private Function dd(ed As Long) As String
Dim wc As String
Dim fd As Long
Dim gd As Integer
Dim hd As Integer
assert ed > 0
wc = ""
fd = ed
gd = Len(fb)
hd = Len(gb)
wc = Mid(fb, 1 + fd Mod gd, 1)
fd = Fix(fd / gd)
Do While (fd > 0)
wc = wc & Mid(gb, 1 + fd Mod hd, 1)
fd = Fix(fd / hd)
Loop
dd = wc
End Function
Private Sub jd()
Dim kd As Long
Dim ld As String
Dim md As New Collection
Dim nd As Long
nd = 1
For kd = 1 To pb.Count
If (od(ob, pb.Item(kd)) _
= nb) Then
Do
ld = dd(nd)
nd = nd + 1
Loop Until _
od(ob, ld) = nb And _
od(pb, ld) = nb
pd md, pb.Item(kd), ld
End If
Next kd
Set pb = md
End Sub
Private Function qd(rd As String) As String
Dim wc As String
wc = od(pb, LCase(rd))
If (wc = nb) Then
wc = LCase(rd)
End If
qd = wc
End Function
Private Sub sd(td As Collection)
Set td = New Collection
End Sub
Private Function od(vc As Collection, ud As String) As String
Dim wc As String
On Error GoTo vd
wc = vc.Item(LCase(ud))
GoTo wd
vd:
wc = nb
wd:
od = wc
End Function
Private Sub xd(vc As Collection, ud As String)
If (od(vc, ud) <> nb) Then
vc.Remove LCase(ud)
End If
End Sub
Private Sub pd(vc As Collection, ud As String, yd As String)
If (nb = od(vc, ud)) Then
vc.Add LCase(yd), LCase(ud)
End If
End Sub
Private Function zd(tc As String, ae As String) As Integer
Dim be As Integer
Dim ce As Integer
be = 0
ce = InStr(1, tc, ae)
Do While (ce > 0)
be = ce
ce = InStr(be + 1, tc, ae)
Loop
zd = be
End Function
Private Function de(ee As String) As Integer
de = zd(ee, hb)
End Function
Private Function fe(ee As String) As String
Dim ge As Integer
Dim wc As String
ge = de(ee)
If (ge = 0) Then
wc = nb
Else
wc = Right(ee, Len(ee) - (ge + Len(hb) - 1))
End If
fe = wc
End Function
Private Function he(ee As String) As String
Dim ge As Integer
Dim wc As String
ge = de(ee)
If (ge = 0) Then
wc = nb
Else
wc = Left(ee, ge - 1)
End If
he = wc
End Function
Private Function ie(ee As String) As Boolean
Dim je As String
Dim wc As String
je = fe(ee)
If (je = nb) Then
wc = False
ElseIf (nb = od(qb, je)) Then
wc = False
Else
wc = True
End If
ie = wc
End Function
Private Function ke(tc As String, le As String) As Boolean
ke = (Left(tc, Len(le)) = le)
End Function
Private Function ne(tc As String, oe As String) As Boolean
ne = (Right(tc, Len(oe)) = oe)
End Function
Private Sub pe()
Dim fd As Integer
For fd = LBound(mc) To UBound(mc)
mc(fd) = " "
Next fd
nc = LBound(mc)
End Sub
Private Sub qe(ee As String)
nc = (nc + 1) Mod lc
mc(nc) = ee
End Sub
Private Function re() As String
re = mc(nc)
End Function
Private Function se() As String
Dim wc As String
If (nc = LBound(mc)) Then
wc = mc(UBound(mc))
Else
wc = mc(nc - 1)
End If
se = wc
End Function
Private Function te(ee As String) As Boolean
te = (nb <> od(qb, ee))
End Function
Private Sub register_ids(tc As String)
Dim uc As Integer
Dim yc As Integer
Dim visible As Boolean
Dim ue As Long
Dim ee As String
If InStr(1, LCase(tc), begin_visible_keyword) <> 0 Then
mb = mb + 1
End If
If InStr(1, LCase(tc), kb) <> 0 Then
mb = mb - 1
End If
If InStr(1, LCase(tc), visible_keyword) > 0 Then
visible = True
Else
visible = mb > 0
End If
uc = 1
Do While (uc <= Len(tc))
yc = xc(tc, uc)
ee = LCase(Mid(tc, uc, yc - uc))
If (sc(ee, 1) = j) Then
If (re() = ib) Then
pd qb, ee, ee
pd ob, ee, ee
ElseIf (ie(ee)) Then
pd ob, ee, ee
pd ob, he(ee), he(ee)
ElseIf (te(ee) And _
re() = jb And sc(se(), 1) = j) Then
pd ob, se(), se()
ElseIf (visible) Then
pd ob, ee, ee
Else
pd pb, ee, ee
End If
End If
qe ee
uc = yc
Loop
End Sub
Private Function ve(tc As String) As Integer
Dim wc As Integer
wc = Len(tc)
If (ke(tc, x)) Then wc = wc - Len(x)
If (ne(tc, x)) Then wc = wc - Len(x)
ve = wc
End Function
Private Function we(tc As String, le As String) As Integer
Dim wc As Integer
If (ke(tc, le)) Then
wc = Len(le)
Else
wc = 0
End If
we = wc
End Function
Private Function xe(tc As String) As String
xe = Mid(tc, 1 + we(tc, x), ve(tc))
End Function
Private Function ye(tc As String) As String
ye = x & tc & x
End Function
Private Function ze(tc As String) As String
Dim wc As String
Dim uc As Integer
Dim yc As Integer
Dim ee As String
wc = ""
uc = 1
Do While (uc <= Len(tc))
yc = xc(tc, uc)
ee = Mid(tc, uc, yc - uc)
Select Case (sc(ee, 1))
Case j
wc = wc & qd(ee)
Case n
wc = wc & " "
Case l
wc = wc & ee
Case k
wc = wc & ee
Case m
If (ke(ee, db)) Then
wc = wc & Right(ee, Len(ee) - Len(cb))
End If
Case o
wc = wc & ee
Case p
wc = wc & ee
Case Else
assert False
End Select
uc = yc
Loop
ze = Trim(wc)
End Function
Private Sub af(cf As String)
Dim df As Integer
Dim ef As String
Dim ff As Long
On Error GoTo error_exit
df = freefile()
Open cf For Input As #df
Do While Not EOF(df)
ef = gf(df)
register_ids ef
Loop
Close df
GoTo hf
error_exit:
ff = Err.Number
On Error Resume Next
Close df
Err.Raise ff
hf:
End Sub
Private Function jf(ef As String) As Boolean
jf = ne(ef, eb)
End Function
Private Function kf(lf As String, mf As String) As String
Dim wc As String
If (lf = "") Then
wc = mf
Else
wc = lf & vbNewLine & mf
End If
kf = wc
End Function
Private Function gf(nf As Integer) As String
Dim wc As String
Dim pf As String
wc = ""
Do
Line Input #nf, pf
wc = kf(wc, pf)
Loop Until EOF(nf) Or Not jf(pf)
gf = wc
End Function
Private Sub qf( _
rf As String, sf As String)
Dim nf As Integer
Dim tf As Integer
Dim ef As String
Dim uf As String
Dim ff As Long
On Error GoTo error_exit
nf = freefile()
Open rf For Input As #nf
tf = freefile()
Open sf For Output As #tf
Do While Not EOF(nf)
ef = gf(nf)
uf = ze(ef)
If (rb) Then
Print #tf, cb & ef
Print #tf, uf
ElseIf (uf <> "") Then
Print #tf, uf
End If
Loop
Close nf
Close tf
GoTo hf
error_exit:
ff = Err.Number
On Error Resume Next
Close nf
On Error Resume Next
Close tf
Err.Raise ff
hf:
End Sub
Private Function vf(wf As Workbook, _
xf As Integer, Optional yf = ".tmp") As String
vf = wf.Path & oc() & ub & _
CStr(xf) & yf
End Function
Private Function zf() As String
zf = "qzx" & _
Format(10 ^ 6 * Rnd(), "000000") & Format(10 ^ 6 * Rnd(), "000000")
End Function
Private Sub ag(vbc As Object, f As String)
Dim tf As Integer
Dim bg As Long
Dim ff As Long
On Error GoTo error_exit
tf = freefile()
Open f For Output As #tf
For bg = 1 To vbc.codemodule.countoflines
Print #tf, vbc.codemodule.Lines(startline:=bg, Count:=1)
Next bg
Close tf
GoTo hf
error_exit:
ff = Err.Number
On Error Resume Next
Close tf
Err.Raise ff
hf:
End Sub
Private Sub cg(vbc As Object, f As String)
Dim nf As Integer
Dim ef As String
Dim bg As Long
Dim ff As Long
On Error GoTo error_exit
vbc.codemodule.deletelines startline:=1, Count:=vbc.codemodule.countoflines
nf = freefile()
Open f For Input As #nf
bg = 1
Do While Not EOF(nf)
Line Input #nf, ef
vbc.codemodule.insertlines bg, ef
bg = bg + 1
Loop
Close nf
GoTo hf
error_exit:
ff = Err.Number
On Error Resume Next
Close nf
Err.Raise ff
hf:
End Sub
Private Sub dg(wf As Workbook)
Dim vbc As Object
Dim xf As Integer
Dim eg As String
Dim fg As Boolean
Dim newname As String
fg = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.StatusBar = "Saving Invisibly: initializing..."
sd ob
sd pb
sd qb
pe
register_ids "e '#visible"
assert Dir(ThisWorkbook.Path & oc() & r) <> ""
mb = 1
af ThisWorkbook.Path & oc() & r
mb = 0
For xf = 1 To wf.VBProject.vbcomponents.Count
Set vbc = wf.VBProject.vbcomponents(xf)
Select Case vbc.Type
Case hc, ic, jc
mb = 0
register_ids vbc.Name
Case kc
register_ids vbc.Name & " '#visible"
Case Else
register_ids vbc.Name & " '#visible"
End Select
Application.StatusBar = "Saving Invisibly: Pass 1 of 2, VBComponent " & CStr(xf) & " of " & CStr(wf.VBProject.vbcomponents.Count)
ag vbc, vf(wf, xf)
mb = 0
pe
af vf(wf, xf)
Next xf
jd
eg = vf(wf, wf.VBProject.vbcomponents.Count + 1)
For xf = 1 To wf.VBProject.vbcomponents.Count
Set vbc = wf.VBProject.vbcomponents(xf)
newname = ze(vbc.Name)
If (LCase(newname) <> LCase(vbc.Name)) Then vbc.Name = newname
Application.StatusBar = "Saving Invisibly: Pass 2 of 2, VBComponent " & CStr(xf) & " of " & CStr(wf.VBProject.vbcomponents.Count)
pe
qf vf(wf, xf), eg
cg vbc, eg
Kill eg
Kill vf(wf, xf)
Next xf
Application.StatusBar = False
Application.DisplayStatusBar = fg
End Sub
Private Function gg(hg As String, ig As String) As Boolean
Dim jg As String
Dim kg As String
Dim wc As Boolean
jg = Trim(LCase(hg))
kg = Trim(LCase(ig))
If (Not ke(jg, oc())) Then jg = oc() & jg
If (Not ke(kg, oc())) Then kg = oc() & kg
If (ne(jg, kg) Or ne(kg, jg)) Then
wc = False
Else
wc = True
End If
gg = wc
End Function
Public Sub lg(wf As Workbook, filename As String)
assert gg(wf.FullName, filename)
wf.SaveAs filename
dg wf
Application.DisplayAlerts = False
wf.SaveAs filename
Application.DisplayAlerts = True
End Sub
Private Function mg(wf As Workbook) As String
Dim ng As Integer
Dim wc As String
ng = zd(wf.Name, ".")
If (ng = 0) Then
wc = wf.Path & oc() & wf.Name & lb
Else
wc = wf.Path & oc() & Left(wf.Name, ng - 1) & _
lb & Right(wf.Name, Len(wf.Name) - (ng - 1))
End If
mg = wc
End Function
Private Sub og()
Dim filename As String
Dim wf As Workbook
On Error GoTo error_exit
Set wf = ActiveWorkbook
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."
GoTo hf
End If
filename = Application.GetSaveAsFilename( _
initialfilename:=mg(wf), _
filefilter:="Microsoft Excel Workbook (*.xls),*.xls,All Files (*.*),*.*", _
Title:="Select file into which workbook will be saved invisibly")
If (Not gg(wf.FullName, filename)) Then
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
lg wf, filename
End If
GoTo hf
error_exit:
Application.DisplayAlerts = True
Application.StatusBar = False
MsgBox "Error #" & CStr(Err.Number) & " during ""Save Invisibly As"": " & Err.Description, _
vbCritical, "Invisible Basic Save Invisibly As Error"
hf:
End Sub
Public Sub pg()
rb = False
og
End Sub
Public Sub qg()
rb = True
og
End Sub
Private Sub rg(sg As String)
xb vb(), "Open", sg, 0, 0, fc
End Sub
Public Sub tg()
rg ThisWorkbook.Path & oc() & "InvisibleBasic.html"
End Sub
Public Sub d()
Dim cbp As ug
Dim cbb As vg
Call g
Set cbp = Application.wg(tb).xg.Add( _
Type:=yg)
cbp.caption = sb
cbp.zg = _
"Source code obfuscation utility for Excel/VBA applications."
Set cbb = cbp.xg.Add(Type:=ah)
cbb.caption = "&Save Invisibly As..."
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"
Set cbb = cbp.xg.Add(Type:=ah)
cbb.caption = "&Debugging Save Invisibly As..."
cbb.bh = "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.xg.Add(Type:=ah)
cbb.caption = "&Help..."
cbb.bh = "Invisible Basic Help"
cbb.OnAction = "invisible_basic_show_help"
End Sub
Public Sub g()
On Error Resume Next
Application.wg(tb).xg( _
sb).Delete
End Sub
Public Sub ch()
Dim wf As Workbook
Dim dh As String
Dim eh As String
Dim fh As Integer
assert fe("myButton_Click") = "Click"
assert he("myButton_Click") = "myButton"
assert fe("myButtonClick") = ""
assert fe("myButton_20_Click") = "Click"
assert he("myButton_20_Click") = "myButton_20"
For fh = 1 To 2
If (fh = 1) Then
h.pc = False
Else
h.pc = True
End If
dh = ThisWorkbook.Path & oc() & "IB_Test.xls"
eh = ThisWorkbook.Path & oc() & "IB_Test_Obf.xls"
Workbooks.Open dh
Set wf = Workbooks(Workbooks.Count)
lg wf, eh
Evaluate "IBTest.testModule.ibt_test()"
wf.Close savechanges:=False
Next fh
End Sub