OLVBA - XLSM + XLM macro

olevba 0.52 - http://decalage.info/python/oletools
Flags        Filename
-----------  -----------------------------------------------------------------
OpX:MAS-HB-- 63bacd873beeca6692142df432520614a1641ea395adaabc705152c55ab8c1d7
===============================================================================
FILE: 63bacd873beeca6692142df432520614a1641ea395adaabc705152c55ab8c1d7
Type: OpenXML
-------------------------------------------------------------------------------
VBA MACRO Makra.bas
in file: xl/vbaProject.bin - OLE stream: 'VBA/Makra'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -


' **********************************************
' *     MS-Excel\x99 Template Control Code        *
' *  Copyright \xa9 1994-6 Village Software, Inc. *
' *           All Rights Reserved              *
' *      LICENSED FOR END-USER USE ONLY.       *
' * CODE MAY NOT BE INCLUDED IN COMMERCIAL     *
' *    THIRD PARTY APPLICATIONS WITHOUT THE    *
' *        EXPRESSED WRITTEN CONSENT OF        *
' *           VILLAGE SOFTWARE, INC.           *
' *                                            *
' *                Version 8.0                 *
' **********************************************

' These routines control the behavior of the toolbars,
' buttons, and other user-interface elements of the
' MS-Excel 97 templates


' ****************************************************
' * Global options, types, declarations, & constants *
' ****************************************************

    Option Base 1

    Public LetterFont As String
    Public LetterStyle As String
    Public LetterColor As Integer
    Public LetterSize As Integer

    Public UnqNumber As Variant
    Public Cloak_Next As Boolean
    Public MacXL As Boolean
    Global GenNumber As Long
    Global BookName As String
    Global FullBookName As String

    Const SheetBar = "Objedn\xe1vka"
    Const NumberingFilename = "Objedn\xe1vka"
    Const Vital = "\xdaprava objedn\xe1vky"
    Const Content1 = "Objedn\xe1vka"

    Const Lock_String = "Zamknout / Ulo\x9eit list"
    Const Lock_Text = "Nyn\xed m\xf9\x9eete \xfadaje na tomto listu pro \xfapravy zamknout a p\xf8\xedpadn\xec zm\xecn\xecnou verzi \x9aablony ulo\x9eit."
    Const Unlock_String = "Odemknout tento list"
    Const Unlock_Text = "Odemknete-li tento list, m\xf9\x9eete na n\xecm prov\xe9st libovoln\xe9 \xfapravy. Po proveden\xed pot\xf8ebn\xfdch zm\xecn stiskn\xecte tla\xe8\xedtko """ & Lock_String & """ a zamkn\xecte jej. Ochr\xe1n\xedte jej tak p\xf8ed necht\xecn\xfdmi zm\xecnani."
    Const Save_Alrt = "Upraven\xe1 \x9aablona byla ulo\x9eena do slo\x9eky "
    Const Save_Alrt2 = ". Tuto \x9aablonu m\xf9\x9eete pou\x9e\xedt tak, \x9ee nejprve zvol\xedte p\xf8\xedkaz Zav\xf8\xedt z nab\xeddky Soubor a potom p\xf8\xedkaz Nov\xfd."
    Const Save_Filter = "\x8aablony,*.xlt"
    Const Save_Title = "Ulo\x9eit \x9aablonu"


    Const Logo_Error = "Logo \x9aablony nelze zm\xecnit. List mus\xedte nejprve odemknout."
    Const LetterFont_Error = "P\xedsmo \x9aablony nelze zm\xecnit. List mus\xedte nejprve odemknout."
    Const Univ_Error = "Neo\xe8ek\xe1van\xe1 chyba \xe8\xedslo "

    Const ATW_NotThere = "Tuto funkci lze pou\x9e\xedt pouze pokud je nainstalov\xe1n Pr\xf9vodce \x9aablonou. Pokyny pro instalaci z\xedsk\xe1te klepnut\xedm na tla\xe8\xedtko N\xe1pov\xecda."
    Const ATW_SheetName = "TemplateInformation"


    Const SQ_DB_Loc = "V zadan\xe9m adres\xe1\xf8i nen\xed \x9e\xe1dn\xe1 spole\xe8n\xe1 datab\xe1ze. Zm\xec\xf2te pros\xedm nastaven\xed um\xedst\xecn\xed datab\xe1ze na listu \xdaprava objedn\xe1vky."
    Const SQ_DB_Struc = "Struktura datab\xe1ze nen\xed slu\xe8iteln\xe1 s p\xf8edlohou. Obnovte pros\xedm p\xf9vodn\xed strukturu."
    Const SQ_DB_CatTitle = "Katalog zbo\x9e\xed a slu\x9eeb"
    Const SQ_DB_CatItem = "N\xe1zev slu\x9eby/zbo\x9e\xed"
    Const SQ_DB_EmpTitle = "Zam\xecstnanci"
    Const SQ_DB_EmpItem = "Jm\xe9no"

    Const NUM_Hdr = "P\xf8i\xf8a\xefit \xe8\xedslo"
    Const NUM_Warn1 = "\x8e\xe1d\xe1te o p\xf8i\xf8azen\xed jedine\xe8n\xe9ho \xe8\xedsla tomuto formul\xe1\xf8i.  P\xf8ejete si pokra\xe8ovat?"
    Const NUM_Warn2 = "Tomuto formul\xe1\xf8i je ji\x9e p\xf8i\xf8azeno \xe8\xedslo.  Zm\xecna m\xf9\x9ee zp\xf9sobit probl\xe9my.  P\xf8ejete si opavdu p\xf8i\xf8adit nov\xe9 \xe8\xedslo?"
    Const NUM_NotThere = "Dopln\xeck pro \xe8\xedslov\xe1n\xed mus\xed b\xfdt otev\xf8en, aby \xe8\xedslov\xe1n\xed a funkce panelu n\xe1stroj\xf9 byla optim\xe1ln\xed. Um\xedst\xecte pros\xedm tento dopln\xeck do slo\x9eky Library."
    Const Num_Prob = "B\xechem pokusu o p\xf8i\xf8azen\xed \xe8\xedsla se objevila chyba. Ujist\xecte se, \x9ee cesta zadan\xe1 na listu \xdapravy objedn\xe1vky je platn\xe1, nebo zadejte \xe8\xedslo ru\xe8n\xec."
    Const VIL_Dlg = "Spole\xe8nost Village Software nab\xedz\xed r\xf9zn\xe9 \xf8e\x9aen\xe9 \xfalohy pro oblast obchodu a financ\xed ur\xe8en\xe9 pro aplikaci Excel - jak pro obchodn\xed tak i dom\xe1c\xed pou\x9eit\xed. Katalog z\xedsk\xe1te zdarma na tel. \xe8\xedsle 617-695-9332 nebo p\xedsemn\xec na adrese Village Software, 186 Lincoln Street, Boston MA 02111, USA."
    Const VIL_Dlg2 = "Zp\xect do se\x9aitu, se kter\xfdm jste pracovali, m\xf9\x9eete p\xf8epnout pomoc\xed p\xf8\xedkazu Okno v nab\xeddce."
    Const EmpDlg = "V\xfdb\xecr zam\xecstnance"
    Const LockDlg = "Z\xe1mek"
    Const CredDlg = "Z\xe1sluhy"

    Const ZoomButton = 1
    Const TipButton = 2
    Const DocButton = 3
    Const HelpButton = 4
    Const SampleButton = 5
    Const NumbersButton = 6
    Const ATWButton = 7
    Const CredButton = 8

    Const Zoom1 = 80
    Const Zoom2 = 95
    Const Zoom3 = 105

    Const DatabasePathCell = "B3"
    Const LocalizationCell = "LOC"
    Const SampleStateCell = "SS"
    Const ToolbarStateCell = "NS"
    Const CommonDBPathCell = "CDB"
    Const ContentSheetCell = "CS"

    Const File_ATW = "WZTEMPLT"
    Const File_Number = "TMPLTNUM"
    Const File_Help = "XLTMPL8.HLP"
    Const File_Help_Mac = "MS Excel Solutions Help"
    Const File_Help_Main = "XLMAIN8.HLP"
    Const File_Help_Main_Mac = "MS Excel Help"
    Const File_DB = "COMMON"

    Const Cloak = True
    Const Default_Font = "Arial CE"

    Const cRange = "Range"
    Const cWorksheet = "Worksheet"
    Const cNothing = "Nothing"
    Const cEmpty = "Empty"

    'For the intl.Fixup macro:
    Const TRIGGER_NAME = "__IntlFixup"
    Const TABLE_NAME = "__IntlFixupTable"


' ***********************************
' * Automatic execution procedures  *
' ***********************************


Sub Auto_Open()
Attribute Auto_Open.VB_ProcData.VB_Invoke_Func = " \n14"
'Initializes the worksheet properties

    Application.ScreenUpdating = False
'    IntlFixup

   MacXL = (UCase(Left(Application.OperatingSystem, 3)) = "MAC")

    If CheckBars(SheetBar) Then
      If Int(Left(Application.Version, 1)) > 5 Then
        Toolbars(SheetBar).ToolbarButtons(ZoomButton).OnAction = "PageZoom"
        Toolbars(SheetBar).ToolbarButtons(TipButton).OnAction = "CellTipDisplay"
        Toolbars(SheetBar).ToolbarButtons(HelpButton).OnAction = "Help"
        Toolbars(SheetBar).ToolbarButtons(SampleButton).OnAction = "ToggleSample"
      Else
        Toolbars(SheetBar).Delete
        Exit Sub
      End If
    End If

    If Not CheckAddIns(File_Number & ".XLA", Ttl) Then
      MsgBox NUM_NotThere, vbOKOnly + vbCritical, SheetBar
    End If

    ActiveWorkbook.OnSheetActivate = "CheckSheet"
    ActiveWorkbook.OnSheetDeactivate = "CloakSheet"
    ActiveWindow.OnWindow = "CheckWindow"

    For Each ThisSheet In Sheets
      If TypeName(ThisSheet) = cWorksheet Then
        ThisSheet.OnEntry = "CheckEntry"
      End If
    Next

    LetterFont = Default_Font
    Application.DisplayNoteIndicator = True

    FullBookName = ActiveWorkbook.Name
    BookName = ParentWorkbook(FullBookName)

    AutoScale

    Range(LocalizationCell) = Application.International(1)
    Range(ContentSheetCell) = Sheets(Content1).Name
    If CheckSheets(ATW_SheetName, ActiveWorkbook.Name) Then
        If Sheets(ATW_SheetName).Range(DatabasePathCell).Value = _
         FlName(Sheets(ATW_SheetName).Range(DatabasePathCell).Value) Then
            Sheets(ATW_SheetName).Range(DatabasePathCell).Value = Application.LibraryPath & _
             Application.PathSeparator & FlName(Sheets(ATW_SheetName).Range(DatabasePathCell).Value)
        End If
    End If

    Specific_AutoStart

    'Application.ScreenUpdating = True

End Sub


Sub IntlFixup()
Attribute IntlFixup.VB_ProcData.VB_Invoke_Func = " \n14"
    Dim wbTemplate As Workbook
    Dim wbDataTable As Workbook
    Dim v As Variant
    Dim rTable As Range
    Dim rCurCell As Range
    Dim rDestCell As Range
    Dim iLocaleOffset As Integer
    Dim rSrcCell As Range

    ' if somebody absolutely had to have the table in a different workbook,
    ' make it easy on them.  Just change these definitions to affect the rest
    ' of the macro.  Could also pass info as parameters if required.
    Set wbTemplate = ThisWorkbook
    Set wbDataTable = ThisWorkbook

    On Error Resume Next
    Set v = Nothing
    Set v = wbTemplate.Names(TRIGGER_NAME)
    If Not (v Is Nothing) Then Exit Sub

    Set rTable = wbDataTable.Names(TABLE_NAME).RefersToRange
    If rTable Is Nothing Then
        MsgBox "Warning: Missing Localization Table"
        Exit Sub
    End If

    ' lookup the locale offset within the table.  After found, it is just a constant
    ' offset into the table columns.  If not found, bail out silently
    v = Application.Match(Application.International(xlCountrySetting), _
        rTable.Rows(1).Cells.Offset(0, 3).Resize(columnsize:=rTable.Columns.Count - 3), 0)
    If Not IsError(v) Then
        iLocaleOffset = CInt(v) - 1

        Set rCurCell = rTable.Cells(2, 1)
        Do Until IsEmpty(rCurCell.Value)
            Set rDestCell = wbTemplate.Sheets(rCurCell.Value).Range(rCurCell.Offset(0, 1).Value)
            Set rSrcCell = rCurCell.Offset(0, 3 + iLocaleOffset)
            If Not IsEmpty(rSrcCell) Then
                Select Case rCurCell.Offset(0, 2).Value
                    Case 1
                        ' contents
                        rDestCell.Value = rSrcCell.Value
                    Case 2
                        ' number format
                        rDestCell.NumberFormatLocal = rSrcCell.Value
                    Case 3
                        ' formula
                        rDestCell.Formula = "=" & rSrcCell.Formula
                    Case 4
                        ' paper size (applies to entire worksheet)
                        rDestCell.Parent.PageSetup.PaperSize = rSrcCell.Value
                    Case Else
                        ' do nothing - a bogus entry in the localization table
                        MsgBox "Warning: invalid action code entry in localization table"
                End Select
            End If
            Set rCurCell = rCurCell.Offset(1, 0)
        Loop
    End If

    ' add the trigger name so that this template never gets fixed up again.
    wbTemplate.Names.Add Name:=TRIGGER_NAME, RefersTo:="=True", Visible:=False
End Sub


Sub Auto_Close()
Attribute Auto_Close.VB_ProcData.VB_Invoke_Func = " \n14"
'Orderly closedown/pass-off of toolbars, etc.

    Unhide_Workbook ThisWorkbook.Name

    If CheckBars(SheetBar) Then

        If BookName = "" Then
            BookName = ParentWorkbook(ActiveWorkbook.Name)
        End If

        If IsNull(SiblingWorkbooks(BookName, 1)) Then
            Toolbars(SheetBar).Delete
            Application.OnWindow = ""
        Else
            TransName = SiblingWorkbooks(BookName, 1)
            Toolbars(SheetBar).ToolbarButtons(ZoomButton).OnAction = _
              TransName & "!PageZoom"
            Toolbars(SheetBar).ToolbarButtons(TipButton).OnAction = _
              TransName & "!CellTipDisplay"
            Toolbars(SheetBar).ToolbarButtons(HelpButton).OnAction = _
              TransName & "!Help"
            Toolbars(SheetBar).ToolbarButtons(SampleButton).OnAction = _
              TransName & "!ToggleSample"

            If NumbersButton <> 0 Then
                Toolbars(SheetBar).ToolbarButtons(NumbersButton).OnAction = _
                  TransName & "!AssignNumbers"
            Else
                Toolbars(SheetBar).ToolbarButtons(SplitButton).OnAction = _
                  TransName & "!SplitWindow"
            End If

            If ATWButton <> 0 Then
                Toolbars(SheetBar).ToolbarButtons(ATWButton).OnAction = _
                  TransName & "!DatabaseLink"
            Else
                Toolbars(SheetBar).ToolbarButtons(CalcButton).OnAction = _
                  TransName & "!Calc"
            End If

            If Windows(TransName).Visible = False Then
                Toolbars(SheetBar).Visible = False
            End If

        End If
    End If

    Specific_AutoStop

End Sub


Sub CheckSheet()
Attribute CheckSheet.VB_ProcData.VB_Invoke_Func = " \n14"
'Executed on worksheet changes

    If BookName = "" Then
        FullBookName = ActiveWorkbook.Name
        BookName = ParentWorkbook(ActiveWorkbook.Name)
    End If

    Specific_CheckSheet

    'update status bars
    If CheckBars(SheetBar) Then

      Range(ToolbarStateCell) = Toolbars(SheetBar).Visible

      If TypeName(ActiveSheet) = cWorksheet And ActiveWindow.Type = xlWorkbook Then

        'update zoom status
        Toolbars(SheetBar).ToolbarButtons(ZoomButton).Pushed = (ActiveWindow.Zoom < ZoomFactor)

        'update split/freeze status
        If SplitButton > 0 Then
            Toolbars(SheetBar).ToolbarButtons(SplitButton).Pushed = ActiveWindow.FreezePanes
        End If

        'update sample status
        Toolbars(SheetBar).ToolbarButtons(SampleButton).Pushed = Range(SampleStateCell)

        'update celltip display status
        Toolbars(SheetBar).ToolbarButtons(TipButton).Pushed = Not Application.DisplayNoteIndicator

      Else
        For i = 1 To 6
            With Toolbars(SheetBar).ToolbarButtons(i)
                If .Enabled Then .Pushed = False
            End With
        Next
      End If
    End If

End Sub


Sub CloakSheet()
Attribute CloakSheet.VB_ProcData.VB_Invoke_Func = " \n14"
'manages hiding of vital sheet and closing of toolbars


    If CheckBars(SheetBar) Then
        On Error Resume Next
        Workbooks(FullBookName).Sheets(Vital).Range(ToolbarStateCell) = Toolbars(SheetBar).Visible
        On Error GoTo 0
    End If

    'hides vital sheet
    On Error Resume Next
    If ActiveWindow.Type <> xlInfo Then
      On Error GoTo 0
      If TypeName(ActiveSheet) <> cNothing Then
        WorkbookName = ActiveWorkbook.Name
        If UCase(Right(WorkbookName, 4)) = ".XLS" _
         Or UCase(Right(WorkbookName, 4)) = ".XLT" Then _
         WorkbookName = Left(WorkbookName, Len(WorkbookName) - 4)
        If WorkbookName = FullBookName Then
            If ActiveSheet.Name <> Vital Then
                If Cloak_Next = True And Cloak = True Then
                    Sheets(Vital).Visible = False
                    Cloak_Next = False
                    Specific_AutoStart
                End If
            Else
                Cloak_Next = True
            End If
        End If
      End If
    End If
    On Error GoTo 0

    'closes old bar down
    If TypeName(ActiveWorkbook) = cNothing Then
        If CheckBars(SheetBar) Then
            Toolbars(SheetBar).Visible = False
        End If
    Else
        If BookName <> Left(ActiveWorkbook.Name, Len(BookName)) Then
            If CheckBars(SheetBar) Then
                Toolbars(SheetBar).Visible = False
            End If
        Else
            If LCase(Left(Right(ActiveWorkbook.Name, 12), 8)) = "database" Then
                If CheckBars(SheetBar) Then
                    Toolbars(SheetBar).Visible = False
                End If
            End If
        End If
    End If

End Sub



Sub CheckWindow()
Attribute CheckWindow.VB_ProcData.VB_Invoke_Func = " \n14"

    If CheckBars(SheetBar) Then
        If LCase(BookName) = LCase(Left(ActiveWorkbook.Name, Len(BookName))) _
         And LCase(Right(Trim(ActiveWorkbook.Name), 8)) <> "database" _
         And ActiveWindow.Type <> xlChartInPlace Then
            Toolbars(SheetBar).Visible = Range(ToolbarStateCell)
            CheckSheet
        Else
            Toolbars(SheetBar).Visible = False
        End If
    End If
    Application.StatusBar = False

End Sub


Sub CheckEntry()
Attribute CheckEntry.VB_ProcData.VB_Invoke_Func = " \n14"
'Executed on any entry in any cell

    If ActiveSheet.Name = Vital Then
        If LetterSize = 0 Then
            LetterSize = 10
        End If
        PreviewPane
    End If

End Sub


Sub AutoScale()
Attribute AutoScale.VB_ProcData.VB_Invoke_Func = " \n14"
'scales the default zoom factor to the user's monitor size

    For Each ThisSheet In Sheets
      If TypeName(ThisSheet) = cWorksheet Then
        ThisSheet.Activate
        ActiveWindow.Zoom = ZoomFactor
      End If
    Next

    ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
    Sheets(Content1).Activate

End Sub



' *******************************************
' *  Button and Toggle/States support code  *
' *******************************************


Sub PageZoom()
Attribute PageZoom.VB_ProcData.VB_Invoke_Func = " \n14"
'Controls Zoom toolbar button

  If TypeName(ActiveSheet) = cWorksheet And TypeName(Selection) = cRange Then

    On Error GoTo Err_1

    Toolbars(SheetBar).ToolbarButtons(ZoomButton).Pushed = _
    Not Toolbars(SheetBar).ToolbarButtons(ZoomButton).Pushed

    If Not Toolbars(SheetBar).ToolbarButtons(ZoomButton).Pushed Then
        ActiveWindow.Zoom = ZoomFactor
    Else
        Application.ScreenUpdating = False
        Set ThisCell = ActiveCell
        Range("Print_Area").Select
        ActiveWindow.Zoom = True
        ThisCell.Select
        'Application.ScreenUpdating = True
    End If

  End If
  On Error GoTo 0
  Exit Sub

Err_1:

  Toolbars(SheetBar).ToolbarButtons(ZoomButton).Pushed = False
  'Application.ScreenUpdating = True
  Err = 0
  On Error GoTo 0

End Sub



Sub ToggleSample()
Attribute ToggleSample.VB_ProcData.VB_Invoke_Func = " \n14"
'Controls Sample toobar button

    On Error GoTo Err_S:
    Selection.DataSeries

    Application.ScreenUpdating = False
    Set StartSheet = ActiveSheet

    For Each rngName In ActiveWorkbook.Names
        If InStr(rngName.Name, "qzqzqz") = 1 Then
            Range(rngName).MergeCells = False
        End If
    Next rngName

    For Each ThisSheet In Sheets
      If TypeName(ThisSheet) = cWorksheet Then
        ThisSheet.Activate
        If TypeName(Selection) <> cRange Then ThisSheet.Range("A1").Select
        PIndex = ThisSheet.Index
        For Each ThisScen In ThisSheet.Scenarios
            TName = ThisScen.Name
            TIndex = ThisScen.Index
            If Left(TName, 6) = "sample" Then
                Set SelCells = Sheets(PIndex).Scenarios(TName).ChangingCells
                ScenNo = Right(TName, Len(TName) - 6)
                ScenName = "current" & Trim(ScenNo)
                If Range(SampleStateCell).Value = False Then

                    If CheckScenarios(ScenName, PIndex) Then
                        ThisSheet.Scenarios(ScenName).Delete
                    End If

                    Sheets(PIndex).Scenarios.Add ScenName, SelCells
                    ThisScen.Show
                Else
                    ThisSheet.Scenarios(ScenName).Show
                End If
            End If
        Next
      End If
    Next

    Toolbars(SheetBar).ToolbarButtons(SampleButton).Pushed = _
    Not Toolbars(SheetBar).ToolbarButtons(SampleButton).Pushed

    Range(SampleStateCell).Value = _
    Not Range(SampleStateCell).Value

    For Each rngName In ActiveWorkbook.Names
        If InStr(rngName.Name, "qzqzqz") = 1 Then
            Range(rngName).MergeCells = True
        End If
    Next rngName

    StartSheet.Activate
    'Application.ScreenUpdating = True

Err_S:
End Sub


Sub AssignNumbers()
Attribute AssignNumbers.VB_ProcData.VB_Invoke_Func = " \n14"
'Controls the Assign Numbers button on the toolbar

  On Error GoTo Err_S:
  If CheckAddIns(File_Number & ".XLA", Ttl) Then

    If ActiveWindow.Type = xlWorkbook Then
      If Range("NO") = "" Then
          If MsgBox(NUM_Warn1, vbOKCancel + vbInformation, SheetBar) = vbCancel Then Exit Sub
      Else
          If MsgBox(NUM_Warn2, vbOKCancel + vbCritical, SheetBar) = vbCancel Then Exit Sub
      End If

      UnqNumber = Application.Run(File_Number & ".XLA!GetNextTemplateNumber", NumberingFilename, Not Range("SHR1").Value, Range("SHR2").Value, GenNumber)
      If UnqNumber <> "False" Then
        Range("NO").Value = UnqNumber
      Else
        MsgBox Num_Prob, vbOKOnly + vbExclamation, SheetBar
      End If
    End If

  Else

    MsgBox NUM_NotThere, vbOKOnly + vbCritical, SheetBar

  End If

Err_S:
End Sub




Sub CellTipDisplay()
Attribute CellTipDisplay.VB_ProcData.VB_Invoke_Func = " \n14"
'Controls the CellTip Display button on the toolbar

  If TypeName(ActiveSheet) = cWorksheet And ActiveWindow.Type = xlWorkbook Then

    Toolbars(SheetBar).ToolbarButtons(TipButton).Pushed = _
    Not Toolbars(SheetBar).ToolbarButtons(TipButton).Pushed

    If Not Toolbars(SheetBar).ToolbarButtons(TipButton).Pushed Then
        Application.DisplayNoteIndicator = True
    Else
        Application.DisplayNoteIndicator = False
    End If

  End If

End Sub






Sub LockSheet()
Attribute LockSheet.VB_ProcData.VB_Invoke_Func = " \n14"
'Controls the Lock Sheet button on the Vitals page

    If Sheets(Vital).DrawingObjects("Lock").Caption = Lock_String Then

      If DialogSheets(LockDlg).Show Then
        Sheets(Vital).Protect DrawingObjects:=True, Contents:=True
        Sheets(Vital).DrawingObjects("Lock").Caption = Unlock_String
        Sheets(LockDlg).DialogFrame.Caption = Unlock_String
        Sheets(LockDlg).TextBoxes("PNL1_TXT1").Text = Unlock_Text
        Sheets(LockDlg).GroupBoxes("PNL2").Visible = False
        Sheets(LockDlg).OptionButtons("LCK_1").Visible = False
        Sheets(LockDlg).OptionButtons("LCK_2").Visible = False
        Sheets(LockDlg).TextBoxes("PNL1_TXT1").Height = 80
        If Sheets(LockDlg).OptionButtons("LCK_2").Value = xlOn Then
          ThisDir = CurDir()
          TempDir = Application.TemplatesPath
          ChDrive Mid(TempDir, 1, 1)
          ChDir TempDir
          FileNm = Application.GetSaveAsFilename(FileFilter:=Save_Filter, Title:=Save_Title)
          If FileNm <> False Then
            OWFlg = Application.DisplayAlerts
            Application.DisplayAlerts = False
            ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
            Sheets(Content1).Activate
            Sheets(Vital).Visible = False
            With ActiveWorkbook
                .SaveAs Filename:=FileNm, FileFormat:=xlTemplate
                FName = .FullName
                PName = .Path
            End With
            Application.DisplayAlerts = OWFlg
            MsgBox Save_Alrt & PName & Save_Alrt2, vbOKOnly + vbInformation, SheetBar
          End If
          ChDrive Mid(ThisDir, 1, 1)
          ChDir ThisDir
        End If
      End If

    Else

      If DialogSheets(LockDlg).Show Then
        Sheets(Vital).Unprotect
        Sheets(Vital).DrawingObjects("Lock").Caption = Lock_String
        Sheets(LockDlg).DialogFrame.Caption = Lock_String
        Sheets(LockDlg).TextBoxes("PNL1_TXT1").Text = Lock_Text
        Sheets(LockDlg).GroupBoxes("PNL2").Visible = True
        Sheets(LockDlg).OptionButtons("LCK_1").Visible = True
        Sheets(LockDlg).OptionButtons("LCK_2").Visible = True
        Sheets(LockDlg).TextBoxes("PNL1_TXT1").Height = 40
      End If

    End If

End Sub



Sub Customize()
Attribute Customize.VB_ProcData.VB_Invoke_Func = " \n14"
'Controls Customize button on any Content Page

    Cloak_Next = True
    Sheets(Vital).Visible = True
    Sheets(Vital).Select
    CheckSheet

End Sub





' *********************************************************
' * Procedures which manage the logo and lettertype boxes *
' *********************************************************


Sub InsertLogo()
Attribute InsertLogo.VB_ProcData.VB_Invoke_Func = " \n14"
'Lets the user insert a custom logo

  Dim LoopL As Integer
  Dim LogpPic As Variant
  Dim Err_Flg As Boolean

  If Sheets(Vital).DrawingObjects("Lock").Caption = Lock_String Then

    ShtMem = ActiveSheet.Index

    Sheets(Vital).Activate
    Set Mem = ActiveCell

    With ActiveSheet.DrawingObjects("LG")
        lgl = .Left
        lgt = .Top
        lgw = .Width
        lgh = .Height
    End With

    On Error GoTo Err_1B

    If Application.Dialogs(xlDialogInsertPicture).Show Then

      Application.ScreenUpdating = False

      ActiveSheet.DrawingObjects("LG").Delete

      On Error GoTo Err_2

      With Selection
        .Left = lgl
        .Top = lgt
        .Width = lgw
        .Height = lgh
        .Width = lgw
        .Name = "LG"
        .OnAction = "Nada"
        .Copy
      End With

      Mem.Select

      For Each ThisSheet In Sheets
        If TypeName(ThisSheet) = cWorksheet Then

          ThisSheet.Activate
          Set Mem = ActiveCell
          ActiveSheet.DrawingObjects("LG").Select

          If Not Err_Flg Then

            With ActiveSheet.DrawingObjects("LG")
                lgl = .Left
                lgt = .Top
                lgw = .Width
                lgh = .Height
                .Delete
            End With

            ActiveSheet.Paste

            With Selection
                .Left = lgl
                .Top = lgt
                .Width = lgw
                .Height = lgh
                .Name = "LG"
                .OnAction = "Nada"
            End With

          Else
            Err_Flg = False
          End If

          Mem.Select
        End If
      Next

      Sheets(ShtMem).Activate
    End If

  Else

    MsgBox Logo_Error, vbCritical, SheetBar

  End If

  On Error GoTo 0
  'Application.ScreenUpdating = True
  Exit Sub

Err_1B:

  MsgBox Error(Err), vbCritical + vbOKOnly, SheetBar
  Err = 0
  'Application.ScreenUpdating = True
  On Error GoTo 0
  Exit Sub

Err_2:

  If Err <> 1004 And Err <> 1006 Then

    Msg = Univ_Error & Str(Err) & ": " & Error(Err)
    MsgBox Msg, vbCritical, SheetBar
    Err = 0
  Else
    Err_Flg = True
    Err = 0
    Resume Next
  End If

  Sheets(ShtMem).Activate
  On Error GoTo 0
  'Application.ScreenUpdating = True

End Sub


Sub PreviewPane()
Attribute PreviewPane.VB_ProcData.VB_Invoke_Func = " \n14"
'Adds text into the preview panels dynamically

  Dim Len1 As Integer
  Dim String1 As String
  Dim Thisbox As Variant
  Dim LoopA As Integer

  'Application.ScreenUpdating = False

  Len1 = Sheets(Vital).Range("vital1").Characters.Count

  If Not IsEmpty(Range("vital8")) Then
    Tel = "tel. "
    CommaTel = "  "
  Else
    Tel = ""
    CommaTel = ""
  End If

  If Not IsEmpty(Range("vital9")) Then
    Fax = "fax "
  Else
    Fax = ""
  End If
    If Not IsEmpty(Range("vital5")) Then CommaPSC = "  " Else CommaPSC = ""

  String1 = Sheets(Vital).Range("vital1").Value & Chr(10) _
    & Sheets(Vital).Range("vital2").Value & Chr(10) _
    & Sheets(Vital).Range("vital5").Value & CommaPSC _
    & Sheets(Vital).Range("vital4").Value & Chr(10) _
    & Tel & Sheets(Vital).Range("vital8").Value & CommaTel _
    & Fax & Sheets(Vital).Range("vital9").Value
  On Error GoTo Err_2B

  For Each ThisSheet In Sheets
    If TypeName(ThisSheet) = cWorksheet Then

      ThisSheet.DrawingObjects("LT").Characters.Text = String1

      If Err_Flg = False Then
        With ThisSheet.DrawingObjects("LT").Characters.Font
          .Name = LetterFont
          .ColorIndex = LetterColor
          .Size = LetterSize
          .Strikethrough = False
          .Superscript = False
          .Subscript = False
          .OutlineFont = False
          .Shadow = False
          .Underline = xlNone
          .FontStyle = LetterStyle
        End With

        With ThisSheet.DrawingObjects("LT").Characters(Start:=1, Length:=Len1).Font
          .Size = LetterSize + 10
          .FontStyle = LetterStyle
        End With

      Else
        Err_Flg = False
      End If
    End If
  Next

  On Error GoTo 0
  'Application.ScreenUpdating = True
  Exit Sub

Err_2B:

  If Err <> 1004 And Err <> 1006 Then

    Msg = Univ_Error & Str(Err) & ": " & Error(Err)
    MsgBox Msg, vbCritical, SheetBar
    Err = 0
  Else
    Err_Flg = True
    Err = 0
    Resume Next
  End If

  On Error GoTo 0
  'Application.ScreenUpdating = True

End Sub





' ************************************
' * Calls to customized dialog boxes *
' ************************************


Sub DatabaseLink()
Attribute DatabaseLink.VB_ProcData.VB_Invoke_Func = " \n14"
'Auto-Template Wizard/ Database link box
'requires template add-in file for auto-numbering routine

    Dim GenNumber As Long
    On Error GoTo Err_S:

    If CheckAddIns(File_ATW & ".XLA", Ttl) Then
        Set CurrWorkbook = ActiveWorkbook
        AddIns(Ttl).Installed = True
        CurrWorkbook.Activate
        If DialogSheets("ATW").Show Then
            If DialogSheets("ATW").OptionButtons("ATW_1").Value = xlOn Then
                Application.Run File_ATW & ".XLA!StartWizard"
            Else
                Application.Run File_ATW & ".XLA!Commit"
            End If
        End If
    Else
     If MacXL Then
            File_Help_To_Call = File_Help_Main_Mac
        Else
            File_Help_To_Call = File_Help_Main
        End If

        MsgBox ATW_NotThere, vbOKOnly + vbCritical + vbMsgBoxHelpButton, SheetBar, Application.Path & Application.PathSeparator & File_Help_To_Call, 5117208

    End If

Err_S:
End Sub


Sub VillageCredit()
Attribute VillageCredit.VB_ProcData.VB_Invoke_Func = " \n14"
'Village Software credits box

    MsgBox VIL_Dlg

End Sub



' ***********************************
' * Calls to Built-in Excel dialogs *
' ***********************************


Sub ChangeFont()
Attribute ChangeFont.VB_ProcData.VB_Invoke_Func = " \n14"
'Changes the font in the preview panels

  Dim Return_1 As Object

  If Sheets(Vital).DrawingObjects("Lock").Caption = Lock_String Then

    ShtMem = ActiveSheet.Index

    Sheets(Vital).Activate
    Set Return_1 = ActiveCell

    Sheets(Vital).Range("LTR").Select

    If Application.Dialogs(xlDialogActiveCellFont).Show Then
        With Selection.Font
            LetterFont = .Name
            LetterColor = .ColorIndex
            LetterSize = .Size
            LetterStyle = .FontStyle
            .Underline = xlNone
            PreviewPane
        End With
    End If

    Return_1.Select
    Sheets(ShtMem).Activate
  Else

    MsgBox LetterFont_Error, vbCritical, SheetBar
  End If

End Sub




' ***************************************
' * Supporting procedures and functions *
' ***************************************


Function CheckScenarios(ScenarioName, Scenariopage)
Attribute CheckScenarios.VB_ProcData.VB_Invoke_Func = " \n14"
'Checks if a scenario is in a worksheet, returns T/F

    CheckScenarios = False
    If Scenariopage > 0 Then
        For Each ThisScenario In Sheets(Scenariopage).Scenarios
            If ThisScenario.Name = ScenarioName Then
                CheckScenarios = True
            End If
        Next
     End If

End Function


Function ParentWorkbook(WorkbookName)
Attribute ParentWorkbook.VB_ProcData.VB_Invoke_Func = " \n14"
'Returns the template parent name of the input workbookname

    If UCase(Right(WorkbookName, 4)) = ".XLS" _
     Or UCase(Right(WorkbookName, 4)) = ".XLT" Then
        WorkbookName = Left(WorkbookName, Len(WorkbookName) - 4)
    End If

    If IsNumeric(Right(WorkbookName, 1)) Then
        ParentWorkbook = ParentWorkbook(Left(WorkbookName, Len(WorkbookName) - 1))
    Else
        ParentWorkbook = WorkbookName
    End If

End Function


Function SiblingWorkbooks(WorkbookName, NumberHurdle)
Attribute SiblingWorkbooks.VB_ProcData.VB_Invoke_Func = " \n14"
'Checks if any other "offspring" workbooks are present, returns name or null
'NumberHurdle is how many siblings need be concurrently open to return non-False

    i = 0
    SiblingWorkbooks = Null
    For Each ThisBook In Workbooks
        If UCase(WorkbookName) = Left(UCase(ThisBook.Name), Len(WorkbookName)) Then
            i = i + 1
            If TypeName(ActiveSheet) <> cNothing Then
                If ThisBook.Name <> ActiveWorkbook.Name Then
                    temp = ThisBook.Name
                End If
            End If
        End If
    Next

    If i > NumberHurdle Then
        SiblingWorkbooks = temp
    Else
        SiblingWorkbooks = Null
    End If

End Function


Function CheckSheets(SheetName, ThisBookName)
Attribute CheckSheets.VB_ProcData.VB_Invoke_Func = " \n14"
'Checks if a sheet is in a workbook, returns T/F

    NumberofSheets = Workbooks(ThisBookName).Sheets.Count
    CheckSheets = False
    On Error Resume Next
    Set ThisSheet = Workbooks(ThisBookName).Sheets(SheetName)
    If TypeName(ThisSheet) <> cEmpty Then
        CheckSheets = True
    End If

End Function


Function NameIndex(RName)
Attribute NameIndex.VB_ProcData.VB_Invoke_Func = " \n14"
'Checks to see if a name is in a sheet, returns index

    Dim Count As Integer
    Dim Loop1 As Integer

    Count = ActiveWorkbook.Names.Count
    NameIndex = False
    For Loop1 = 1 To Count
        If ActiveWorkbook.Names(Index:=Loop1).Name = RName Then
            NameIndex = Loop1
        End If
    Next

End Function


Function CheckBars(BarName)
Attribute CheckBars.VB_ProcData.VB_Invoke_Func = " \n14"
'Checks if a toolbar is in a worksheet, returns T/F

    CheckBars = False
    On Error Resume Next
    Set ThisToolbar = Toolbars(BarName)
    If TypeName(ThisToolbar) <> cEmpty Then
        CheckBars = True
    End If

End Function


Function CheckAddIns(AddInName, AddInTitle)
Attribute CheckAddIns.VB_ProcData.VB_Invoke_Func = " \n14"
'Checks if an addin is available to Excel, returns T/F

    CheckAddIns = False
    On Error GoTo NotLoadedTrap
    AddInTitle = Workbooks(AddInName).Title
    CheckAddIns = True
    Exit Function

NotLoaded:
    On Error GoTo CantLoadTrap
    Workbooks.Open Application.LibraryPath & Application.PathSeparator & AddInName
    AddInTitle = Workbooks(AddInName).Title
    CheckAddIns = True
    Exit Function

NotLoadedTrap:
    Resume NotLoaded

CantLoadTrap:
    CheckAddIns = False

End Function



Sub Unhide_Workbook(WBook)
Attribute Unhide_Workbook.VB_ProcData.VB_Invoke_Func = " \n14"
'Unhides a hidden workbook, called on closedown

    For Each ThisWindow In Windows
        WWind = Trim(ThisWindow.Caption)
        If Not IsError(Application.Search(":", WWind)) Then
            WWind = Left(WWind, Application.Find(":", WWind) - 1)
        End If
        If WWind = WBook Then
            If ThisWindow.Visible = False Then _
             ThisWindow.Visible = True
        End If
    Next

End Sub



Function ZoomFactor()
Attribute ZoomFactor.VB_ProcData.VB_Invoke_Func = " \n14"
'Returns the proper default zoom factor for the user's display

    Select Case ActiveWindow.Width
        Case 1 To 600
            ZoomFactor = Zoom1
        Case 601 To 1050
            ZoomFactor = Zoom2
        Case Else
            ZoomFactor = Zoom3
    End Select

End Function


Function FlName(PathName)
Attribute FlName.VB_ProcData.VB_Invoke_Func = " \n14"
'Returns the file name from a full path name

    If InStr(PathName, Application.PathSeparator) > 0 Then
        FlName = FlName(Right(PathName, Len(PathName) - InStr(PathName, Application.PathSeparator)))
    Else
        FlName = PathName
    End If

End Function


Sub Nada()
Attribute Nada.VB_ProcData.VB_Invoke_Func = " \n14"
'This area intentionally left blank
End Sub


Sub Help()
Attribute Help.VB_ProcData.VB_Invoke_Func = " \n14"
'Call to help file
If MacXL Then
        File_Help_To_Call = File_Help_Mac
    Else
        File_Help_To_Call = File_Help
    End If

  Application.Help Application.Path & Application.PathSeparator & File_Help_To_Call, 3


End Sub



' ***************************************************
' * Procedures specific to this particular template *
' ***************************************************


Sub Specific_CheckSheet()
Attribute Specific_CheckSheet.VB_ProcData.VB_Invoke_Func = " \n14"
'Template specific routines to be run in CheckSheet

    If ActiveSheet.Name = Range(ContentSheetCell) And Range("dflt1").Value = True Then
      If IsEmpty(Range("data7").Value) And IsEmpty(Range("data8").Value) Then
        If IsEmpty(Range("data7").Value) Then Range("data7").Value = Range("vital1").Value
        If IsEmpty(Range("data8").Value) Then Range("data8").Value = Range("vital2").Value
        If IsEmpty(Range("data9").Value) Then Range("data9").Value = Range("vital5").Value
        If IsEmpty(Range("data10").Value) Then Range("data10").Value = Range("vital4").Value
        If IsEmpty(Range("data12").Value) Then Range("data12").Value = Range("vital8").Value
        If IsEmpty(Range("data102").Value) Then Range("data102").Value = Range("vital3").Value
        If IsEmpty(Range("data103").Value) Then Range("data103").Value = Range("vital6").Value
        If IsEmpty(Range("data104").Value) Then Range("data104").Value = Range("vital7").Value
      End If
    End If

End Sub


Sub Specific_AutoStart()
Attribute Specific_AutoStart.VB_ProcData.VB_Invoke_Func = " \n14"

    Range("data101").Value = Now

End Sub


Sub Specific_AutoStop()
Attribute Specific_AutoStop.VB_ProcData.VB_Invoke_Func = " \n14"

End Sub


Sub PO_Payments()
Attribute PO_Payments.VB_ProcData.VB_Invoke_Func = " \n14"
'Subroutine managing the buttons on pages which have a Payment area


    If Range("data84") = 4 Then
        ActiveSheet.DrawingObjects("CCL").Visible = True
        Range("CCT").FormulaR1C1 = "=INDEX(CC,data83)"
    Else
        ActiveSheet.DrawingObjects("CCL").Visible = False
        Range("CCT").FormulaR1C1 = ""
    End If

End Sub


-------------------------------------------------------------------------------
VBA MACRO ThisWorkbook.cls
in file: xl/vbaProject.bin - OLE stream: 'VBA/ThisWorkbook'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(empty macro)
-------------------------------------------------------------------------------
VBA MACRO List1.cls
in file: xl/vbaProject.bin - OLE stream: 'VBA/List1'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(empty macro)
-------------------------------------------------------------------------------
VBA MACRO List2.cls
in file: xl/vbaProject.bin - OLE stream: 'VBA/List2'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(empty macro)
-------------------------------------------------------------------------------
VBA MACRO List3.cls
in file: xl/vbaProject.bin - OLE stream: 'VBA/List3'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(empty macro)