Office (OLE) static analysis report

Attribute VB_Name = "Sheet1"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Attribute VB_Control = "buttonShowHideCoachTips, 46090, 2, MSForms, CommandButton"
Attribute VB_Control = "CommandButton1, 46110, 3, MSForms, CommandButton"
Attribute VB_Control = "btnAddToQBNow, 46112, 4, MSForms, CommandButton"
Option Explicit
Public suspendChecking As Boolean
Dim haveRemovedUI As Boolean, nCurrentColumn As Integer

Public Sub Init()
    
    HideAllBalloons
    nCurrentColumn = 0      ''' Company name column
    
    If (buttonShowHideCoachTips.Caption = QB_Hide_Coach_Caption) Then
        ShowCoachTip 2
    End If
    
End Sub

Public Sub HideAllBalloons()
    Dim i As Integer, MetaWS As Worksheet, sShapeName As String, oShape As Shape
    On Error Resume Next
    Set MetaWS = ThisWorkbook.Worksheets("Meta")
    
    For i = 1 To 17
        sShapeName = MetaWS.Cells(2, i).Value
        Sheet1.Shapes(sShapeName).Visible = False
        If (Err.Number <> 0) Then
            MsgBox GetErrorCommentText(ERR_TEMPLATE_TAMPERED, "", "", "", "")
            Exit Sub
        End If
    Next
End Sub

Sub ShowCoachTip(nColumnIndex As Integer)
    Dim r As Range, colRange As Range, oShape As Shape, MetaWS As Worksheet
    Dim sShapeName As String
    
    '' Check if template is fine
    If (Not DoesCodeNamedSheetExist("Data", "Sheet1")) Then
        MsgBox GetErrorCommentText(ERR_TEMPLATE_TAMPERED, "", "", "", "")
        Exit Sub
    Else
        If (nColumnIndex > 0 And nColumnIndex < 18) Then
            '' Check if the Meta sheet exists
            If (Not DoesCodeNamedSheetExist("Meta", "Sheet2")) Then
                MsgBox GetErrorCommentText(ERR_TEMPLATE_TAMPERED, "", "", "", "")
                Exit Sub
            End If
               
            '' Check if the target shape exists
            sShapeName = Sheet2.Cells(2, nColumnIndex).Value
            On Error Resume Next
            Set oShape = Sheet1.Shapes(sShapeName)
            If (oShape Is Nothing Or Err.Number <> 0) Then
                MsgBox GetErrorCommentText(ERR_TEMPLATE_TAMPERED, "", "", "", "")
                Exit Sub
            End If
        End If
    End If

    Set MetaWS = ThisWorkbook.Worksheets("Meta")
    
    If (buttonShowHideCoachTips.Caption = QB_Hide_Coach_Caption) Then
    
        ' Remember who has the focus right now, will have to restore the focus
        ' back to the same place
        Set r = Application.ActiveCell
        
        If (nColumnIndex > 0 And nColumnIndex < 18) Then
             ''' Hide the current shape(s)
             HideAllBalloons
             ''' Unless the shape is out of the current column, we provide default positioning
             Set oShape = Sheet1.Shapes(MetaWS.Cells(2, nColumnIndex).Value)
             With oShape
               Set colRange = Sheet1.Cells(7, nColumnIndex)
               If (.Left > (colRange.Left + colRange.Width) Or _
                  (.Left + .Width) < colRange.Left) Then
                   .Left = colRange.Left - (colRange.Width - 50) / 2
               End If
               .Top = colRange.Top + colRange.Height - .Height - COACH_TIP_BUBBLE_TAIL_HEIGHT
               .Visible = msoTrue
               
              End With
               
               nCurrentColumn = nColumnIndex
        End If
        
        If (Not r Is Nothing) Then
            r.Select
        End If
    End If
End Sub

''' Position the current coach tip bubble
Private Sub SetVerticalPositionCoachTipBubble()
    Dim colRange As Range, oShape As Shape, MetaWS As Worksheet
    Set MetaWS = ThisWorkbook.Worksheets("Meta")
    
    If (buttonShowHideCoachTips.Caption = QB_Hide_Coach_Caption) Then
        If (nCurrentColumn > 0 And nCurrentColumn < 18) Then
            Set oShape = Sheet1.Shapes(MetaWS.Cells(2, nCurrentColumn).Value)
             With oShape
               Set colRange = Sheet1.Cells(7, nCurrentColumn)
               .Top = colRange.Top + colRange.Height - .Height - COACH_TIP_BUBBLE_TAIL_HEIGHT
               
              End With
        End If
    End If
End Sub

Public Sub CloseAppForImport()
    If (ThisWorkbook.Saved) Then
        If (g_QBExlMediatorObject Is Nothing) Then
            MsgBox GetErrorCommentText(ERR_TEMPLATE_TAMPERED, "", "", "", "")
        Else
            Call g_QBExlMediatorObject.MarkForImport(ThisWorkbook.FullName, 2)
        End If
    Else
        MsgBox "Please save your data before adding your data to QuickBooks."
    End If
End Sub




Private Sub btnAddToQBNow_Click()
    Dim frmAlertBox1 As New SaveAndImportDialog, bSaved As Boolean, frmAlertBox2 As New ImportDialog
    
    If (g_QBExlMediatorObject Is Nothing) Then
        
        Dim frmAddFromQB As New AddFromQuickBooks
        frmAddFromQB.Show vbModal
        Exit Sub
    End If
    
    bSaved = ThisWorkbook.Saved
    If (Not bSaved) Then
        '' first dialog box
        If (ThisWorkbook.Path = "") Then
            frmAlertBox1.Show vbModal
            If (frmAlertBox1.PressedButtonIndex = 1) Then
               bSaved = ThisWorkbook.AskAndSaveWorkBook()
               bSaved = ThisWorkbook.Saved
            Else
                bSaved = False
            End If
        Else
            frmAlertBox1.Show vbModal
            If (frmAlertBox1.PressedButtonIndex = 1) Then
               ThisWorkbook.Save
               bSaved = True
            Else
                bSaved = False
            End If
        
        End If
        If (bSaved) Then
            If (g_QBExlMediatorObject Is Nothing) Then
                MsgBox GetErrorCommentText(ERR_TEMPLATE_TAMPERED, "", "", "", "")
            Else
                Call g_QBExlMediatorObject.MarkForImport(ThisWorkbook.FullName, 1)
            End If
        End If
    Else
        If (g_QBExlMediatorObject Is Nothing) Then
            MsgBox GetErrorCommentText(ERR_TEMPLATE_TAMPERED, "", "", "", "")
        Else
            Call g_QBExlMediatorObject.MarkForImport(ThisWorkbook.FullName, 1)
        End If
    End If
    
    
End Sub

Private Sub CommandButton1_Click()
On Error Resume Next
    UnprotectThisSheet
    suspendChecking = True
    If CommandButton1.Caption = "Hide Detailed Instructions" Then
        CopyNormalInstruction
        Me.Range("instructions").EntireRow.RowHeight = 125
        CommandButton1.Caption = "Show Detailed Instructions"
    Else
        CopyDetailedInstruction
        Me.Range("instructions").EntireRow.RowHeight = 245
        CommandButton1.Caption = "Hide Detailed Instructions"
    End If
    SetVerticalPositionCoachTipBubble
    suspendChecking = False
    ProtectThisSheet
End Sub


Private Sub buttonShowHideCoachTips_Click()
    Dim nCurrentColumnCopy As Integer
    
    If (buttonShowHideCoachTips.Caption = QB_Show_Coach_Caption) Then
        buttonShowHideCoachTips.Caption = QB_Hide_Coach_Caption
        buttonShowHideCoachTips.Width = 126
        nCurrentColumnCopy = nCurrentColumn
        ShowCoachTip nCurrentColumnCopy
        If (nCurrentColumn > 0) Then
            Sheet1.Cells(8, nCurrentColumn).Select
        End If
    Else
        HideAllBalloons
        buttonShowHideCoachTips.Caption = QB_Show_Coach_Caption
        buttonShowHideCoachTips.Width = 126
    End If
End Sub


Public Function checkDataOnFileClose() As Long
    suspendChecking = True
    checkDataOnFileClose = checkMyQBData(False, False, Me.UsedRange)
    suspendChecking = False
End Function


Public Sub CopyNormalInstruction()
    Dim r As Range
    Set r = Application.ActiveCell
    If (fileName <> "") Then
        Sheet1.Range("S3:T3").Copy
        Sheet1.Range("B2:C2").PasteSpecial xlPasteAll
        
        Sheet1.Range("U3:V3").Copy
        Sheet1.Range("D2:E2").PasteSpecial xlPasteAll
    
        Sheet1.Range("W3:X3").Copy
        Sheet1.Range("G2:H2").PasteSpecial xlPasteAll
    Else
        Sheet1.Range("S2:T2").Copy
        Sheet1.Range("B2:C2").PasteSpecial xlPasteAll
        
        Sheet1.Range("U2:V2").Copy
        Sheet1.Range("D2:E2").PasteSpecial xlPasteAll
    
        Sheet1.Range("W2:X2").Copy
        Sheet1.Range("G2:H2").PasteSpecial xlPasteAll
    
    End If
    
    If (Not r Is Nothing) Then
        r.Select
    End If
    Application.CutCopyMode = False
End Sub

Public Sub CopyDetailedInstruction()
    Dim r As Range
    Set r = Application.ActiveCell
    If (fileName <> "") Then
        Sheet1.Range("Y3:Z3").Copy
        Sheet1.Range("B2:C2").PasteSpecial xlPasteAll
            
        Sheet1.Range("AA3:AB3").Copy
        Sheet1.Range("D2:E2").PasteSpecial xlPasteAll
    
        Sheet1.Range("AC3:AD3").Copy
        Sheet1.Range("G2:H2").PasteSpecial xlPasteAll
    
    Else
        Sheet1.Range("Y2:Z2").Copy
        Sheet1.Range("B2:C2").PasteSpecial xlPasteAll
        
        Sheet1.Range("AA2:AB2").Copy
        Sheet1.Range("D2:E2").PasteSpecial xlPasteAll
    
        Sheet1.Range("AC2:AD2").Copy
        Sheet1.Range("G2:H2").PasteSpecial xlPasteAll
    End If
        
    If (Not r Is Nothing) Then
        r.Select
    End If
    Application.CutCopyMode = False
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
    Dim cl As Range
    
    If suspendChecking = False Then
        Sheet1.UnprotectThisSheet
        If (Not DoesCodeNamedSheetExist("Data", "Sheet1")) Then
            MsgBox GetErrorCommentText(ERR_TEMPLATE_TAMPERED, "", "", "", "")
        Else
            
            suspendChecking = True 'so we do not execute recursively, since checkmyQBData works on the whole worksheet
            'If haveRemovedUI = False Then removePubUI
            checkMyQBData False, True, Target
            suspendChecking = False
            
        End If
        ProtectThisSheet
    End If
End Sub

Public Sub DoAutoCorrection()
    UnprotectThisSheet
    suspendChecking = True
    checkMyQBData True, False, Me.UsedRange
    suspendChecking = False
    ProtectThisSheet
End Sub
    
Public Sub ProtectThisSheet()
    If (Application.Version < 11) Then
        Sheet1.Protect UserInterfaceOnly:=True, Password:=QB_TEMPLATE_PASSWORD, DrawingObjects:=True
    Else
        ProtectExcel2003Plus
    End If
End Sub

Public Sub UnprotectThisSheet()
    Sheet1.Unprotect Password:=QB_TEMPLATE_PASSWORD
End Sub

Sub ProtectExcel2003Plus()
    Sheet1.Protect Contents:=True, AllowInsertingRows:=True, AllowDeletingRows:=True, UserInterfaceOnly:=True, Password:=QB_TEMPLATE_PASSWORD, DrawingObjects:=True
End Sub
    
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim c As Integer, sShapeName As String, oShape As Shape
    
    If (Target.Columns.Count = 1) Then
        c = Target.Columns(1).Column
        If (c > 0 And c < 18 And c <> nCurrentColumn) Then
            ShowCoachTip c
        End If
    End If

End Sub

Attribute VB_Name = "ThisWorkbook"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Option Explicit
Public IsBeingProcessedByQB As Boolean
Dim alreadySaving As Boolean

Private Sub Workbook_Open()
    Sheet1.UnprotectThisSheet
    IsBeingProcessedByQB = False
    InitializeErrorTable
    showDataSheet
    SetContextMenuForRowDelete
    Sheet1.Init
    Sheet1.ProtectThisSheet
End Sub

Sub SetContextMenuForRowDelete()
    Dim cmdButton As CommandBarControl, cmdEditMenuBar
    
    If (Application.Version < 11) Then
        With Application.CommandBars("Row")
            Set cmdButton = .Controls.Add(Type:=msoControlButton, Before:=6)
            If (Not cmdButton Is Nothing) Then
                cmdButton.Caption = QB_DELETE_ROW_MENU_CAPTION
                cmdButton.OnAction = "QBDeleteRow"
            End If
        End With
        
        With Application.CommandBars("WorkSheet Menu Bar")
            Set cmdEditMenuBar = .Controls("&Edit")
            If (Not cmdEditMenuBar Is Nothing) Then
                Set cmdButton = cmdEditMenuBar.Controls.Add(Type:=msoControlButton, Before:=11)
                If (Not cmdButton Is Nothing) Then
                    cmdButton.Caption = QB_DELETE_ROW_MENU_CAPTION
                    cmdButton.OnAction = "QBDeleteRow"
                End If
            End If
        End With
    End If
    
End Sub

Sub ReSetContextMenuForRowDelete()
    Dim cmdEditMenuBar
    
    If (Application.Version < 11) Then
        With Application.CommandBars("Row")
            .Reset
        End With
        
        With Application.CommandBars("WorkSheet Menu Bar")
            Set cmdEditMenuBar = .Controls("&Edit")
            If (Not cmdEditMenuBar Is Nothing) Then
                cmdEditMenuBar.Reset
            End If
        End With
    End If
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim openErrors As Long, myAnswer As Long, b1 As Boolean, b2 As Boolean, b3 As Boolean
    Dim bShowSecondAlertBox As Boolean, sFilePathToSaveTo As String, bSaved As Boolean
    Dim frmAlertBox1 As New SaveAndImportDialog, frmAlertBox2 As New ImportDialog
    
    If (IsBeingProcessedByQB = False And Not (g_QBExlMediatorObject Is Nothing)) Then
        
        
        b1 = (Len(ThisWorkbook.Path) > 0)  '' Where is this workbook
        b2 = ThisWorkbook.Saved                '' Is it already saved
        b3 = (Len(fileName) > 0)               '' Any proposed filename
        '' Of the 8 possible combinations of b1,b2,b3 only 4 is interesting
        If (Not (b1 Or b2 Or b3)) Then
            '' first dialog box
            frmAlertBox1.Show vbModal
            If (frmAlertBox1.PressedButtonIndex = 1) Then
               bSaved = AskAndSaveWorkBook()
               
               If (bSaved) Then
                sFilePathToSaveTo = ThisWorkbook.FullName
                Sheet1.CloseAppForImport
               Else
                Cancel = True
               End If
            End If
        Else
            '' other wise
            bShowSecondAlertBox = True '' show anyway
            '' Second dialog box
            If (Not (b1) And Not (b2) And b3) Then
                bShowSecondAlertBox = True
                sFilePathToSaveTo = fileName
            End If
            
            If (b1 And Not (b2)) Then
                bShowSecondAlertBox = True
                sFilePathToSaveTo = ThisWorkbook.FullName
            End If
            
            If (bShowSecondAlertBox) Then
                frmAlertBox2.Show vbModal
                
                If (frmAlertBox2.PressedButtonIndex = 1) Then
                    If (Not (b2)) Then
                        SaveThisWorkBook sFilePathToSaveTo
                    End If
                    Sheet1.CloseAppForImport
                End If
            End If
        
        End If
    End If
        
    If (Cancel = False) Then
        ReSetContextMenuForRowDelete
    Else
        ' Excel is about to close, so try to release the handle to QB
        On Error Resume Next
        Set g_QBExlMediatorObject = Nothing
    End If
    'Sheet1.ProtectThisSheet
End Sub

Public Sub SaveThisWorkBook(fName As String)
    alreadySaving = True  'stops this code from running as we execute our saveAs below
    Err.Clear  'in case there is an error hanging about from some prior operation
    
    ' Call this again. BeforeSave does not let deletion of rows while saving programmatically
    Sheet1.DoAutoCorrection
    
    If (Application.Version >= 12) Then
        'do the work to save the file here, which will call Workbook_BeforeSave again.
        'File format 52 is "xlOpenXMLWorkbookMacroEnabled"
        'cannot use this constant as older Excel versions do not know about it and will not compile
        On Error Resume Next 'need to ignore errors as SaveAs rasies errors when it fails instead of returning values
        ThisWorkbook.SaveAs FileFormat:=52, fileName:=fName, AddToMru:=True
    Else
        On Error Resume Next 'need to ignore errors as SaveAs rasies errors when it fails instead of returning values
        ThisWorkbook.SaveAs fileName:=fName, AddToMru:=True
    End If
    
    
    'check to see if the user pressed cancel and ignore that
    'this is the odd way SaveAs responds to Cancelling
    If Err.Number = 1004 And _
        (Err.Description = "Application-defined or object-defined error" Or _
         Err.Description = "Method 'SaveAs' of object '_Workbook' failed") Then Err.Clear
    
    'put up a message if saving the file resulted in an error.
    If Err.Number <> 0 Then
        MsgBox "There was an error while saving the file. Please try again." & vbCrLf & vbCrLf & _
            "The error was: " & Err.Number & " - " & Err.Description, vbCritical
    End If
    Err.Clear
    alreadySaving = False
End Sub

Public Function AskAndSaveWorkBook() As Boolean
    Dim fName As String
    On Error Resume Next
    If (Len(fileName) > 0) Then
      SaveThisWorkBook fileName
      AskAndSaveWorkBook = True
      Exit Function
    Else
        fName = ThisWorkbook.Name
    End If
    
    If (Application.Version >= 12) Then '' Excel 2007
        If InStr(fName, ".") > 0 Then
            fName = Left(fName, InStr(fName, ".")) & "xlsm"
        Else
            fName = fName & ".xlsm"
        End If
        fName = Application.GetSaveAsFilename(fName, "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm")
    Else
        fName = Application.GetSaveAsFilename(fName, "Microsoft Office Excel Workbook (*.xls), *.xls")
    End If
    
    
    If fName <> "False" And fName <> "" Then
        SaveThisWorkBook fName
        AskAndSaveWorkBook = True
    Else
        AskAndSaveWorkBook = False
    End If

End Function


Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim fName As String, openErrors As Long, myAnswer As Long
    Dim saveResult As Variant
    On Error Resume Next 'need to ignore errors as SaveAs rasies errors when it fails instead of returning values
    Sheet1.DoAutoCorrection
        
    '' Check if needs error correction
    If (IsBeingProcessedByQB = False And alreadySaving = False) Then
       DoEvents  'may help excel 2007 not crash
        If (ThisWorkbook.Path = "" And fileName = "") Then
        If ThisWorkbook.Path = "" And Application.Version >= 12 And alreadySaving = False Then
            Cancel = True 'this stops Excel from doing it's save after we do ours
            fName = ThisWorkbook.Name
            If InStr(fName, ".") > 0 Then
                fName = Left(fName, InStr(fName, ".")) & "xlsm"
            Else
                fName = fName & ".xlsm"
            End If
            
            fName = Application.GetSaveAsFilename(fName, "Excel Macro-Enabled Workbook (*.xlsm), *.xlsm")
            
            If fName <> "False" And fName <> "" Then
                If Right(fName, 5) <> ".xlsm" Then fName = fName & ".xlsm"  'make sure we have a file name compatable with type 52
                
                alreadySaving = True  'stops this code from running as we execute our saveAs below
                Err.Clear  'in case there is an error hanging about from some prior operation
                
                'do the work to save the file here, which will call Workbook_BeforeSave again.
                'File format 52 is "xlOpenXMLWorkbookMacroEnabled"
                'cannot use this constant as older Excel versions do not know about it and will not compile
                ThisWorkbook.SaveAs FileFormat:=52, fileName:=fName, AddToMru:=True
                
                'check to see if the user pressed cancel and ignore that
                'this is the odd way SaveAs responds to Cancelling
                If Err.Number = 1004 And _
                    (Err.Description = "Application-defined or object-defined error" Or _
                     Err.Description = "Method 'SaveAs' of object '_Workbook' failed") Then Err.Clear
                
                'put up a message if saving the file resulted in an error.
                If Err.Number <> 0 Then
                    MsgBox "There was an error while saving the file. Please try again." & vbCrLf & vbCrLf & _
                        "The error was: " & Err.Number & " - " & Err.Description, vbCritical
                End If
                Err.Clear
                alreadySaving = False
            End If
        End If
        Else
            If (ThisWorkbook.Path = "" And alreadySaving = False) Then
                
                alreadySaving = True
                Cancel = True
                Err.Clear  'in case there is an error hanging about from some prior operation
                If (Application.Version >= 12) Then
                    ThisWorkbook.SaveAs FileFormat:=52, fileName:=fileName, AddToMru:=True
                Else
                    ThisWorkbook.SaveAs fileName:=fileName, AddToMru:=True
                End If
                If Err.Number = 1004 And _
                    (Err.Description = "Application-defined or object-defined error" Or _
                     Err.Description = "Method 'SaveAs' of object '_Workbook' failed") Then Err.Clear
                
                'put up a message if saving the file resulted in an error.
                If Err.Number <> 0 Then
                    MsgBox "There was an error while saving the file. Please try again." & vbCrLf & vbCrLf & _
                        "The error was: " & Err.Number & " - " & Err.Description, vbCritical
                End If
                Err.Clear
                alreadySaving = False
            End If
        
        End If
    Else
        Exit Sub
    End If
EndLabel:
    DoEvents  'may help excel 2007 not crash
    'Sheet1.ProtectThisSheet
    
End Sub



Attribute VB_Name = "AddFromQuickBooks"
Attribute VB_Base = "0{9EEB0DD9-F0E1-4883-BB2C-A6130589671A}{5F36AD32-3F1C-4A0D-8AFB-C655B451181C}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False


Private Sub OkBtn_Click()
    Unload Me
End Sub

Private Sub UserForm_Initialize()
 Label4.Caption = "1. Close this spreadsheet." & vbCrLf & "2. Open QuickBooks." & vbCrLf & _
        "3. Go to QuickBooks File menu and click Utilities > Import > Excel Files..." & vbCrLf & _
        "4. In the Add Your Excel Data to QuickBooks window, go to Step 2 by clicking Find It Now." & vbCrLf & _
        "5. Click Browse to find and open this spreadsheet." & vbCrLf & _
        "6. In the spreadsheet, click Add My Data Now."
End Sub

Attribute VB_Name = "Sheet15"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True


Attribute VB_Name = "startup"
Option Explicit
Option Private Module

'Sub Auto_Open()
'    showDataSheet
'End Sub

Sub showDataSheet()
    Dim mySheet As Worksheet
    On Error Resume Next
    If ThisWorkbook.Sheets("Please Turn on Macros").Visible = xlSheetVisible Then
        Set mySheet = ThisWorkbook.Sheets("Data")
        mySheet.Visible = xlSheetVisible
        ThisWorkbook.Sheets("Please Turn on Macros").Visible = xlHidden
        mySheet.Select
    End If
    DoEvents
End Sub


Attribute VB_Name = "StringTable"
Option Explicit

'' Each error message has a problem statement and a solution
'' ProblemText, SolutionText may have {x} (x being a number)
'' as parameters.
Public Type ErrorMessageType
    problemText  As String
    solutionText As String
End Type

Public Type FieldType
    fieldHeaderRangeName As String
    fieldColIndex As Integer
    fieldCharLimit As Integer
    IsPublic As Boolean
End Type


Public QBFields() As FieldType
'' ErrorTable having all error messages
Public ErrorTable() As ErrorMessageType
'' Invalid characters in a field value is maintained as ErrorMessageType
'' problemText will the character not allowed
'' solutionText will be the friendly name of the character
Public InvalidCharacters() As ErrorMessageType


Public Const QB_ERROR_CELL_BCK_COLOR_INDEX = 36
Public Const QB_REQ_CELL_BCK_COLOR_INDEX = 6

Public Const QB_VALIDATION_ERR_CHAR_EXCEED = "This field contains more text than is allowed."
Public Const QB_VALIDATION_ERR_BLANK_NOT_ALLOWED = "The blank is not allowed in this field."
Public Const QB_VALIDATION_ERR_HAS_INVALID_CHARS = "This field text contains an invalid character."
Public Const QB_VALIDATION_ERR_PARENT_NOT_PRESENT = "The specified parent does not exist."

Public Const ERR_EXCEL_RETURNED_ERROR = 0
Public Const ERR_CHARACTER_NOT_ALLOWED = 1
Public Const ERR_BLANK_NOT_ALLOWED = 2
Public Const ERR_EXCEEDS_CHAR_LIMIT = 3
Public Const ERR_NOTE_CHAR_REMOVED = 4
Public Const ERR_NOTE_DISPLAY_AS_TRUNCATED = 5
Public Const ERR_NOTE_DISPLAY_AS_DUP_FIXED = 6
Public Const ERR_NOTE_SPACES_REMOVED = 7
Public Const ERR_TEMPLATE_TAMPERED = 8
Public Const ERR_NOTE_DATA_TRUNCATED = 9

    
    
Public Const QB_FIELD_COMPANY_NAME_INDEX = 0
Public Const QB_FIELD_MR_MRS_INDEX = 1
Public Const QB_FIELD_FIRST_NAME_INDEX = 2
Public Const QB_FIELD_MI_INDEX = 3
Public Const QB_FIELD_LAST_NAME_INDEX = 4
Public Const QB_FIELD_DISPLAY_AS_INDEX = 5
Public Const QB_FIELD_PHONE_INDEX = 6
Public Const QB_FIELD_FAX_INDEX = 7
Public Const QB_FIELD_ALTERNATE_PHONE_INDEX = 8
Public Const QB_FIELD_EMAIL_INDEX = 9
Public Const QB_FIELD_ACC_NUMBER_INDEX = 10
Public Const QB_FIELD_STREET1_INDEX = 11
Public Const QB_FIELD_STREET2_INDEX = 12
Public Const QB_FIELD_CITY_INDEX = 13
Public Const QB_FIELD_STATE_INDEX = 14
Public Const QB_FIELD_ZIP_INDEX = 15

'''' Hidden fields
Public Const QB_FIELD_ADDRLINE1_INDEX = 16
Public Const QB_FIELD_ADDRLINE2_INDEX = 17
Public Const QB_FIELD_ADDRLINE3_INDEX = 18
Public Const QB_FIELD_ADDRLINE4_INDEX = 19
Public Const QB_FIELD_ADDRLINE5_INDEX = 20

Public Const QB_DELETE_ROW_MENU_CAPTION = "Delete Row(s)"
Public Const QB_Show_Coach_Caption = "Show Coach Tips"
Public Const QB_Hide_Coach_Caption = "Hide Coach Tips"
Public Const COACH_TIP_BUBBLE_TAIL_HEIGHT = 30
Public Const QB_TEMPLATE_PASSWORD = "QuickBooksExlTemplate"




Public Sub InitializeErrorTable()
    ReDim ErrorTable(0) As ErrorMessageType
    ReDim InvalidCharacters(0) As ErrorMessageType
    
    '' Following call order is important, do not change the order.
    '' The error constants must correspond to the order in which the errors are being added
    AddErrorToErrorTable ErrorTable, "Problem:" & vbLf & "Excel returned an error for this cell.", _
                                    "Solution:" & vbLf & "Review the data in this cell for the cause of the error."
    
    AddErrorToErrorTable ErrorTable, "Problem:" & vbLf & "The {0} character is not allowed for QuickBooks import.", _
                         "Solution:" & vbLf & "Remove {0} characters from this cell."
    
    AddErrorToErrorTable ErrorTable, "Problem:" & vbLf & "This required field is blank.", _
                         "Solution:" & vbLf & "Enter data in this cell. If you skipped a row, you may delete this entire row."
    
    AddErrorToErrorTable ErrorTable, "Problem:" & vbLf & "Text exceeds character limit." & vbLf & "There are {0} characters and the limit is {1}.", _
                         "Solution:" & vbLf & "Shorten the text in this cell."
                         
    AddErrorToErrorTable ErrorTable, "Note:" & vbLf & "AutoCorrect removed {0} characters which cannot be used for QuickBooks import.", ""
    
    AddErrorToErrorTable ErrorTable, "Note:" & vbLf & "The Display As name exceeded the character limit and AutoCorrect shortened it to {0} characters.", ""
    
    AddErrorToErrorTable ErrorTable, "Note:" & vbLf & "AutoCorrect fixed a duplicate Display As name. It was: '{0}', AutoCorrect added: '{1}'.", ""
    
    AddErrorToErrorTable ErrorTable, "Note:" & vbLf & "AutoCorrect removed extra spaces from this cell.", ""
    
    AddErrorToErrorTable ErrorTable, "Problem:" & vbLf & "You cannot change columns, headers, or worksheet  names in the QuickBooks templates. " & vbLf & "The template you're importing has been changed and cannot be used.", _
                         "Solution:" & vbLf & "Please use a QuickBooks supplied template and try again."
                         
    AddErrorToErrorTable ErrorTable, "Note:" & vbLf & "AutoCorrect truncated the text in this cell from {1} characters to {0} characters.", ""
                         
   
    
    '' Invalid Character initialization
    AddErrorToErrorTable InvalidCharacters, ":", "':'"
    AddErrorToErrorTable InvalidCharacters, vbTab, "tab"
    AddErrorToErrorTable InvalidCharacters, vbCrLf, "new line"
    AddErrorToErrorTable InvalidCharacters, vbCr, "new line"
    AddErrorToErrorTable InvalidCharacters, vbLf, "new line"
    
    
    
    
    '' Construct the field mapping
    ReDim Preserve QBFields(21) As FieldType
    AddFieldType QB_FIELD_COMPANY_NAME_INDEX, "QBCF4", 41, True
    AddFieldType QB_FIELD_MR_MRS_INDEX, "QBCF5", 15, True
    AddFieldType QB_FIELD_FIRST_NAME_INDEX, "QBCF6", 25, True
    AddFieldType QB_FIELD_MI_INDEX, "QBCF7", 5, True
    AddFieldType QB_FIELD_LAST_NAME_INDEX, "QBCF8", 25, True
    AddFieldType QB_FIELD_DISPLAY_AS_INDEX, "QBCF1", 41, True
    AddFieldType QB_FIELD_PHONE_INDEX, "QBCF10", 21, True
    AddFieldType QB_FIELD_FAX_INDEX, "QBCF11", 21, True
    AddFieldType QB_FIELD_ALTERNATE_PHONE_INDEX, "QBCF12", 21, True
    AddFieldType QB_FIELD_EMAIL_INDEX, "QBCF14", 99, True
    AddFieldType QB_FIELD_ACC_NUMBER_INDEX, "QBCF33", 99, True
    
    AddFieldType QB_FIELD_STREET1_INDEX, "Street1", 41, True
    AddFieldType QB_FIELD_STREET2_INDEX, "Street2", 41, True
    AddFieldType QB_FIELD_CITY_INDEX, "City", 31, True
    AddFieldType QB_FIELD_STATE_INDEX, "State", 21, True
    AddFieldType QB_FIELD_ZIP_INDEX, "Zip", 13, True
    
    AddFieldType QB_FIELD_ADDRLINE1_INDEX, "QBCF15", 41, False
    AddFieldType QB_FIELD_ADDRLINE2_INDEX, "QBCF16", 41, False
    AddFieldType QB_FIELD_ADDRLINE3_INDEX, "QBCF17", 41, False
    AddFieldType QB_FIELD_ADDRLINE4_INDEX, "QBCF18", 41, False
    AddFieldType QB_FIELD_ADDRLINE5_INDEX, "QBCF19", 41, False
    
    '' Fill the column indexes for the named cells
    UpdateFieldIndexes
End Sub

Public Sub AddFieldType(index As Integer, HeaderRangeName As String, nLimit As Integer, IsPublic As Boolean)
    QBFields(index).fieldHeaderRangeName = HeaderRangeName
    QBFields(index).fieldCharLimit = nLimit
    QBFields(index).IsPublic = IsPublic
End Sub

Public Sub AddErrorToErrorTable(ByRef stringTable() As ErrorMessageType, problemText As String, solutionText As String)
    Dim nCount As Integer
    
    nCount = UBound(stringTable)
    ReDim Preserve stringTable(nCount + 1)
    
    stringTable(nCount).problemText = problemText
    stringTable(nCount).solutionText = solutionText
    
End Sub

'' Is there a way to have variable arguments in VBA ?
'' or optional paramters ?
Public Function GetErrorCommentText(errorIndex As Integer, prob_param1, prob_param2, sol_param1, sol_param2) As String
    Dim nCount As Integer, sOutput As String
    Dim sProb_Param1 As String, sProb_Param2 As String '' Problem Text parameters
    Dim sSol_Param1 As String, sSol_Param2 As String   '' Solution Text parameters
    Dim problemText As String, solutionText As String
    
    nCount = UBound(ErrorTable)
    If (errorIndex >= 0 And errorIndex < nCount) Then
        problemText = GetErrorText(ErrorTable(errorIndex).problemText, prob_param1, prob_param2)
        solutionText = GetErrorText(ErrorTable(errorIndex).solutionText, sol_param1, sol_param2)
        
        GetErrorCommentText = problemText & vbLf & solutionText & vbLf
        Exit Function
    End If
    
    GetErrorCommentText = ""
End Function
                                     
Function GetErrorText(sText As String, param1, param2) As String
    Dim sOutput As String
    
    sOutput = sText
    If (Len(sOutput) > 0) Then
       sOutput = Replace(sOutput, "{0}", "" & param1)
       sOutput = Replace(sOutput, "{1}", "" & param2)
    End If
    
    GetErrorText = sOutput
End Function
                                     

Sub UpdateFieldIndexes()
    Dim i As Integer, r As Range
    If (DoesCodeNamedSheetExist("Data", "Sheet1")) Then
        For i = 0 To UBound(QBFields) - 1
            Set r = Sheet1.Range(QBFields(i).fieldHeaderRangeName)
            If (r Is Nothing) Then
                QBFields(i).fieldColIndex = -1
            Else
                QBFields(i).fieldColIndex = r.Column
            End If
        Next
    End If
End Sub

Function GetFieldIndex(nColumnIndex As Integer) As Integer
    Dim i As Integer, result As Integer
    
    result = -1
    
    For i = 0 To UBound(QBFields) - 1
        If (QBFields(i).fieldColIndex = nColumnIndex) Then
            result = i
            Exit For
        End If
    Next

    GetFieldIndex = result
End Function


Function GetCommentsForInvalidChar(text As String) As String
    Dim i As Integer, result As String
    
    result = ""
    For i = 0 To UBound(InvalidCharacters) - 1
        If (InStr(text, InvalidCharacters(i).problemText) > 0) Then
            result = result & GetErrorCommentText(ERR_CHARACTER_NOT_ALLOWED, InvalidCharacters(i).solutionText, "", InvalidCharacters(i).solutionText, "")
        End If
    Next
    
    GetCommentsForInvalidChar = result
End Function



Attribute VB_Name = "Module1"
' Helper functions
Sub AssignRangeName()
    Dim sName As String
    
    sName = InputBox(prompt:="Range Name", Title:="Set Range Name")
    
    If (Len(sName) > 0) Then
        Application.ActiveCell.Name = sName
    End If
   
End Sub

Public Sub DeleteRangeName()
    Dim r As Range
    
    Application.ActiveCell.Name.Delete
End Sub

Public Sub UpdateShapeInfo()
    Dim ShapeName As String, nColumnNumber As Integer
    Dim ws As Worksheet
    
    nColumnNumber = Application.ActiveCell.Column
    Set ws = ThisWorkbook.Worksheets("Meta")
    ws.Cells(2, nColumnNumber).Value = Selection.Name
    Selection.Visible = False
End Sub


Public Sub SetShapeProperties()
    Dim nColumnNumber As Integer
    Dim ws As Worksheet, ShapeName As String
    
    Set ws = ThisWorkbook.Worksheets("Meta")
    For nColumnNumber = 2 To 17
        ShapeName = ws.Cells(2, nColumnNumber).Value
        Sheet1.Shapes(ShapeName).Placement = xlFreeFloating
        Sheet1.Shapes(ShapeName).Locked = True
    Next
    
    
End Sub

Attribute VB_Name = "Sheet2"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Public Sub ProtectThisSheet()
    If (Application.Version < 11) Then
        Sheet2.Protect UserInterfaceOnly:=True, Password:=QB_TEMPLATE_PASSWORD, DrawingObjects:=True
    Else
        ProtectExcel2003Plus
    End If
End Sub

Public Sub UnprotectThisSheet()
    Sheet2.Unprotect Password:=QB_TEMPLATE_PASSWORD
End Sub

Sub ProtectExcel2003Plus()
    Sheet2.Protect Contents:=True, AllowInsertingRows:=True, AllowDeletingRows:=True, UserInterfaceOnly:=True, Password:=QB_TEMPLATE_PASSWORD, DrawingObjects:=True
End Sub

Attribute VB_Name = "SaveAndImportDialog"
Attribute VB_Base = "0{0AA05E53-30D2-4A37-AAB0-3EE09A52BD1C}{C16D50C8-045B-46BC-946A-58F206E9B59F}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
…