I think you can get close to what your boss wants.
But once you open a workbook/template and you allow the user to save it
manually, you lose control over what they do and how they do it.
But you could open the workbook/template for them, ask them the name that
they'll save it with and then do the save and log those initial save
(location/time/date/user name) statistics.
If that seems reasonable, they start a new workbook and paste the code into a
general module.
When you're ready to do it for real, think about what you want. If you decide
to add buttons/templates/worksheets later, make sure you name the button nicely:
BTN_## (01 to 10 (or whatever).
But those last 2 digits will determine which log worksheet to use:
TemplateLog# ##
So if you rearrange/delete/change around, you could log to the incorrect log
worksheet.
Anyway, the code consists of 3 procedures.
The first one: SetupLogWkbk__RunOneTimeOnly
will create the buttons and build the logworksheets--it'll delete any worksheets
that exist in the active workbook--it starts from scratch each time you run it!
The second procedure just retrieves the user's name: fOSUserName
And the third procedure is tied to each button and does the real work:
OpenTemplate
And you'll have to modify this line to include all your templates:
TemplateNames = Array("c:\my documents\excel\book1.xlt", _
"c:\my documents\excel\book2.xlt")
Give the fullpath and keep them in the order that you want.
Here's the code:
Option Explicit
Option Private Module
Option Base 0
Private Declare Function apiGetUserName Lib "advapi32.dll" Alias _
"GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Sub SetupLogWkbk__RunOneTimeOnly()
Dim wks As Worksheet
Dim btnWks As Worksheet
Dim myBtn As Button
Dim iCtr As Long
Dim TemplateNames As Variant
TemplateNames = Array("c:\my documents\excel\book1.xlt", _
"c:\my documents\excel\book2.xlt")
On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("master").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set btnWks = Worksheets.Add
btnWks.Name = "Master"
For Each wks In ThisWorkbook.Worksheets
If StrComp(wks.Name, "master", vbTextCompare) = 0 Then
'do nothing
Else
Application.DisplayAlerts = False
wks.Delete
Application.DisplayAlerts = True
End If
Next wks
For iCtr = LBound(TemplateNames) To UBound(TemplateNames)
Set wks = Worksheets.Add
With wks
With ThisWorkbook.Worksheets
wks.Move after:=.Item(.Count)
End With
.Name = "TemplateLog# " & Format(iCtr + 1, "00")
.Range("a1").Resize(1, 5).Value _
= Array("Filename", "UserName", "Date Created", _
"Time Created", "Based on: " & TemplateNames(iCtr))
End With
Next iCtr
With btnWks
.Range("b1").Value = "Template Name"
.Range("a:a").ColumnWidth = 12
For iCtr = LBound(TemplateNames) To UBound(TemplateNames)
With .Cells(iCtr + 2, "A")
Set myBtn = .Parent.Buttons.Add _
(Top:=.Top, _
Left:=.Left, _
Width:=.Width, _
Height:=.Height)
myBtn.Name = "BTN_" & Format(iCtr + 1, "00")
myBtn.OnAction = ThisWorkbook.Name & "!OpenTemplate"
myBtn.Caption = "Click Me"
.Offset(0, 1).Value = "'" & TemplateNames(iCtr)
End With
Next iCtr
End With
End Sub
Function fOSUserName() As String
' Returns the network login name
Dim lngLen As Long, lngX As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngX = apiGetUserName(strUserName, lngLen)
If lngX <> 0 Then
fOSUserName = Left$(strUserName, lngLen - 1)
Else
fOSUserName = ""
End If
End Function
Sub OpenTemplate()
Dim wks As Worksheet
Dim myBtn As Button
Dim wkbk As Workbook
Dim myFileName As Variant
Dim tempStr As String
Dim myTemplateName As String
Dim nextCell As Range
Dim errorNumber As Long
Dim resp As Long
Set myBtn = ActiveSheet.Buttons(Application.Caller)
Set wks = Worksheets("TemplateLog# " & Right(myBtn.Name, 2))
myTemplateName = myBtn.TopLeftCell.Offset(0, 1).Value
tempStr = ""
On Error Resume Next
tempStr = Dir(myTemplateName)
On Error GoTo 0
If tempStr = "" Then
MsgBox "design error--Template not available"
Exit Sub
End If
Set wkbk = Workbooks.Add(template:=myTemplateName)
Do
myFileName = Application.GetSaveAsFilename _
(filefilter:="Excel Files,*.xls")
If myFileName = False Then
wkbk.Close savechanges:=False
MsgBox "Template file closed!"
Exit Sub
End If
resp = vbYes
If Dir(myFileName) <> "" Then
resp = MsgBox(Prompt:="Overwrite existing file: " _
& myFileName & "?", _
Buttons:=vbYesNo)
End If
If resp = vbYes Then
Exit Do
End If
Loop
'overwrite any existing file without a warning!
Application.DisplayAlerts = False
On Error Resume Next
wkbk.SaveAs Filename:=myFileName, FileFormat:=xlNormal, _
addtomru:=True
errorNumber = Err.Number
On Error GoTo 0
Application.DisplayAlerts = True
If errorNumber <> 0 Then
Err.Clear
MsgBox "An error occurred while saving" & vbLf & "Please try again!"
wkbk.Close savechanges:=False
Exit Sub
End If
With wks
Set nextCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
With nextCell
.Value = wkbk.FullName
.Offset(0, 1).Value = fOSUserName
With .Offset(0, 2)
.Value = Date
.NumberFormat = "mm/dd/yyyy"
End With
With .Offset(0, 3)
.Value = Time
.NumberFormat = "hh:mm:ss"
End With
End With
.UsedRange.Columns.AutoFit
End With
Application.Goto ThisWorkbook.Worksheets("Master").Range("a1"), _
scroll:=True
ThisWorkbook.Save
MsgBox "Don't forget to close the workbook so others can use it!"
End Sub
