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