Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- 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)
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement