jberenyi said:
I have put some serious hours into to trying to make this invoice template
work with Office 2007 and Windows 7. It came originally with Office 97 and
Office 2000 and was designed by Village Software for Excel usage. What is
nice about it is that it has a visual basic database attached to it to track
fields of data on the invoice. I have tried everything to make this darn
thing work and I really need it for my business. The file names that I copied
over to Windows 7 are:
INVDB.XLS
TMPLTNUM.XLS
WZTEMPLT.XLS
I pasted these files into location C:/Program Files (x86)/Microsoft
Office/Office12/Library as some on the net have suggested to do in XP (except
it would be Office11). I have successfully performed this feat in XP with
Office 2003 but not Office 2007 in Windows 7. Keep in mind that I did change
the file location of INVDB.XLS in the template but everytime I try to save
the file it says "cannot locate ...INVDB.XLS". I also do not get the number
toolbar to sequentially increase the invoice number manually.
Has anyone successfully made this awesome template work with Office 2007? I
know it can be done unless the VBA between the two Office versions are not
compatible.
I even created new folders for placement of the above three files in C:
/Program Files/Microsoft Office/Office/Library and no go.
Here is the code:
' **********************************************
' * MS-Excelâ„¢ Template Control Code *
' * Copyright © 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 95 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 = "Invoice"
Const NumberingFilename = "Invoice"
Const Vital = "Customize Your Invoice"
Const Content1 = "Invoice"
Const Lock_String = "Lock/Save Sheet"
Const Lock_Text = "You can lock the information on the Customize page and
save your customized version of the template."
Const Unlock_String = "Unlock This Sheet"
Const Unlock_Text = "By unlocking this sheet, you enable changes to be
made to the information on the Customize sheet. Select ""Lock This Sheet""
after you make your changes to protect the sheet from accidental changes."
Const Save_Alrt = "Your new customized template has been saved to the
directory "
Const Save_Alrt2 = ". To begin use, click Close from the File menu and
then click New to open your template."
Const Save_Filter = "Templates,*.xlt"
Const Save_Title = "Save Template"
Const Logo_Error = "You must unlock the Customize sheet to change the
logo for this template."
Const LetterFont_Error = "You must unlock the Customize sheet to change
the lettertype for this template."
Const Univ_Error = "Unexpected Error #"
Const ATW_NotThere = "To use this feature, you must first install the
Template Wizard add-in program. For installation instructions, click Help."
Const ATW_SheetName = "TemplateInformation"
Const SQ_DB_Loc = "There is no Common database in the specified directory.
Please reset the database location in the Customize page."
Const SQ_DB_Struc = "This database structure is not compatible with the
template. Please restore original structure."
Const SQ_DB_CatTitle = "Product and Service Catalog"
Const SQ_DB_CatItem = "Product/Service Name"
Const SQ_DB_EmpTitle = "Employee Info"
Const SQ_DB_EmpItem = "Name"
Const NUM_Hdr = "Assign a Number"
Const NUM_Warn1 = "You have asked for a unique number to be permanently
assigned to this form. Is it OK to proceed?"
Const NUM_Warn2 = "A unique number is already assigned to this form.
Changing it may cause you bookkeeping problems. Do you really want to assign
a new number?"
Const NUM_NotThere = "The numbering add-in must be loaded for optimal
numbering and toolbar behavior. Please load this add-in into your Library
directory."
Const Num_Prob = "An error occurred while trying to assign a number.
Please ensure that the path specified on the Customize sheet is valid, or
enter a number manually."
Const VIL_Dlg = "Village Software provides a variety of business and
financial spreadsheet solutions for Excel -- for both business and home use.
For a free catalog, call 617-695-9332 or write to Village Software, 186
Lincoln Street, Boston MA 02111 USA."
Const VIL_Dlg2 = "To switch back to the sheet you were working on, use
the Window command on the menu."
Const EmpDlg = "Select Employee"
Const LockDlg = "Lock"
Const CredDlg = "Credits"
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"
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 Aut
pen()
'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()
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()
'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()
'Executed on worksheet changes
If BookName = "" Then
FullBookName = ActiveWorkbook.Name
BookName = ParentWorkbook(ActiveWorkbook.Name)
End If
If TypeName(ActiveSheet) = cWorksheet Then
ActiveSheet.TransitionExpEval = False
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()
'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()
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()
'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()
'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()
'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()
'Controls Sample toolbar 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()
'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()
'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()
'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()
'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()
'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()
'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("vital4")) And Not IsEmpty(Range("vital5")) Then
Comma = ", "
Else
Comma = ""
End If
If Not IsEmpty(Range("vital9")) Then
Fax = " fax "
Else
Fax = ""
End If
String1 = Sheets(Vital).Range("vital1").Value & Chr(10) _
& Sheets(Vital).Range("vital2").Value & Chr(10) _
& Sheets(Vital).Range("vital4").Value & Comma & Sheets(Vital).Range
("vital5").Value & " " & Sheets(Vital).Range("vital6").Value _
& Chr(10) & Sheets(Vital).Range("vital8").Value & Fax & Sheets(Vital).
Range("vital9")
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()
'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()
'Village Software credits box
MsgBox VIL_Dlg
End Sub
' ***********************************
' * Calls to Built-in Excel dialogs *
' ***********************************
Sub ChangeFont()
'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)
'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)
'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)
'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)
'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)
'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)
'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
'ThisToolbar.Visible = True
CheckBars = True
End If
End Function
Function CheckAddIns(AddInName, AddInTitle)
'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)
'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()
'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)
'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()
'This area intentionally left blank
End Sub
Sub Help()
'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, 2
End Sub
' ***************************************************
' * Procedures specific to this particular template *
' ***************************************************
Sub Specific_CheckSheet()
'Template specific routines to be run in CheckSheet
End Sub
Sub Specific_AutoStart()
Range("data1").Value = Date
End Sub
Sub Specific_AutoStop()
End Sub
Sub INV_Payments()
'Subroutine managing the buttons on pages which have a Payment area
If Range("data64") = 3 Then
ActiveSheet.DrawingObjects("CCL").Visible = True
Range("CCT").FormulaR1C1 = "=INDEX(CC,data65)"
Else
ActiveSheet.DrawingObjects("CCL").Visible = False
Range("CCT").FormulaR1C1 = ""
End If
End Sub
