Option Explicit
Sub VerSaveAs( _
Optional SaveType As String = "????")
'
'****************************************************************************************
' Title VerSaveAs
' Target Application: MS applications
' Function; save current file with EITHER:
' SaveType = "Date" ===> filename with embedded date and version number
' FileName Format: abcdef;yyyy-mm-dd_hhmmss.ijk
' OR
' SaveType = "Vers" ===> filename with embedded version number
' FileName Format: abcdef;v###.ijk
'
' Limitations with date and time, proc handles:
' 1. any file type (3 letter extension) for standard MS applications
' 2. the 2 cases for the current file name:
' 2.1 just "FileName.xls" (adds todays date time)
' 2.2 "FileName;yyyy-mm-dd_hhmmss.xls" (replaces old date/time with new)
'
' Limitations with version number, proc handles:
' 1. any file type (3 letter extension) for standard MS applications
' 2. the 2 cases for the current file name:
' 2.1 just "FileName.xls" (adds "v001")
' 2.2 "FileName;v###.xls" (increments version number
' 3. up to 999 version numbers; on attempt to save file allready at
' v999, user is allowed to save file with another name
' Passed Values:
' SaveType [in, string] "Date" OR "Vers" OR "????"
' if SaveType = "???", the procedure will try to recognize
' the current file format (either abcdef;yyyy-mm-dd_hhmmss.ijk or
' abcdef;v###.ijk). If recognized, the format will be followed.
' If not recognized, the Vers format will be used.
'
' COMMENTS:
'
' the use of a version number (either a traditional version number like
' abcdef;v###.ijk or an embedded date style like abcdef;yyyy-mm-dd_hhmmss.ijk)
' facilitates storing a file after changes AND being able to go back to previous
' versions easily. The standardized formats mean that files listed alphabetically
' will make sense.
'
' The date format used, i.e., yyyy-mm-dd, is not the most common and not the
' most unambiguous. dd/mm/yy is more common and dd-mmm-yyyy or yyyy-mmm-dd
' are less ambiguous. But all of these formats have significant problems
' when used as part of a file name:
' dd/mm/yy has illegal characters
' dd-mm-yy might be a substitute, but files with that embedded date will not
' alphabetize correctely.
' Similarly, dd-mmm-yyyy will not alphabetize correctly, nor will yyyy-mmm-dd.
'
'
' Option Explicit is used at VBA module level to force explicit declaration of all
' variables in that module. Compiler errors will occur for any undeclared variables
' and any undefined types, procedures, or objects not found (at compile)in one of
' the referenced libraries. Option Explicit is very good practice and should be
' used all the time.
'
' In the code sections Step2 and Step5 below, references to specific microsoft
' application types, e.g.,
' ActiveWorkBook for Excel,
' ActivePresentation for PowerPoint,
' ActiveProject for Project, and
' ActiveDocument for Word
' require that the corresponding libraries be refereneced at compile. Thus an appl
' using this procedure (VerSavAs) must explicitly reference:
' MS Excel Object Library
' MS Powerpoint Object Library
' MS Project Object Library
' MS Word Object Library
' OR cases and references not needed must be commented out (as has been done here
' for MSProject)
'
'****************************************************************************************
'
'
Dim Ans As VbMsgBoxResult
Dim ProcTitle As String
Dim SaveType2 As String
Dim strFileName As String
Dim strNewName As String
Dim strOldDate As String
Dim strOldName As String
Dim strSuffix As String
Dim strVerNum As String
Dim ThisPath As String
Dim localVerNum As Integer
ProcTitle = "VerSaveAs"
Step1: ' verify SaveType
Select Case LCase(SaveType)
Case "date", "vers", "????"
Case Else
MsgBox "invalid SaveType. File not saved.", vbCritical, ProcTitle
Exit Sub
End Select
Step2: ' parse current file name
Select Case LCase(Application.Name)
Case "microsoft access"
Case "microsoft excel"
strFileName = ActiveWorkbook.Name
ThisPath = ActiveWorkbook.Path
Case "microsoft outlook"
Case "microsoft powerpoint"
strFileName = ActivePresentation.Name
ThisPath = ActivePresentation.Path
Case "microsoft project"
' strFileName = ActiveProject.Name
' ThisPath = ActiveProject.Path
Case "microsoft visio"
Case "microsoft word"
strFileName = ActiveDocument.Name
ThisPath = ActiveDocument.Path
Case Else
MsgBox "unknown application; appl name = " & Application.Name & vbCrLf & _
"save NOT performed", vbCritical, ProcTitle
Exit Sub
End Select
strOldName = Left(strFileName, Len(strFileName) - 4)
strSuffix = Right(strFileName, 3)
Step3: ' store save type; if ???? then try to match current format
Select Case LCase(SaveType)
Case "date", "vers"
SaveType2 = SaveType
Case "????"
If strOldName Like "*;v###" Then
SaveType2 = "vers"
Goto Step4
End If
If strOldName Like "*;####-##-##_######" Then
SaveType2 = "date"
Goto Step4
End If
SaveType2 = "vers"
End Select
Step4: ' build new file name
Select Case LCase(SaveType2)
Case "date"
strOldDate = Right(strOldName, 17)
'
' is date/time already embedded? if so, strip off old date/time
'
If strOldDate Like "####-##-##_######" Then
strOldName = Left(strOldName, Len(strOldName) - 18)
End If
strNewName = ThisPath & "\" & _
strOldName & ";" & Format(Date, "yyyy-mm-dd") & _
"_" & Format(Now, "hhmmss") & "." & strSuffix
Case "vers"
'
' is version number already embedded?
'
If strOldName Like "*;v###" Then
strVerNum = VerNum(Right(strOldName, 3), 3, 1)
localVerNum = strVerNum
If localVerNum > 999 Then
MsgBox "Next version number > 999; can not be accomodated" & _
vbCrLf & vbCrLf & _
"Current file will be saved with current version number." & vbCrLf & _
"You can change filename when system prompts to replace" & vbCrLf & _
"existing file", vbCritical, ProcTitle
strNewName = ThisPath & "\" & strOldName & "." & strSuffix
Goto Step5:
End If
strNewName = ThisPath & "\" & Left(strOldName, Len(strOldName) - 3) & _
strVerNum & "." & strSuffix
Else ' no version number
strNewName = ThisPath & "\" & strOldName & _
";v001" & "." & strSuffix
End If
End Select
Step5: ' save with new name
Select Case LCase(Application.Name)
Case "microsoft access"
Case "microsoft excel"
ActiveWorkbook.SaveAs FileName:=strNewName
Case "microsoft outlook"
Case "microsoft powerpoint"
ActivePresentation.SaveAs FileName:=strNewName
Case "microsoft project"
' ActiveProject.SaveAs FileName:=strNewName
Case "microsoft visio"
Case "microsoft word"
ActiveDocument.SaveAs FileName:=strNewName
End Select
End Sub
Function VerNum(strOldVerNum, Length, Inc) As String
'
'****************************************************************************************
' Title VerNum
' Target Application: any
' Function: creates a new version number by incrementing old number
' by Inc. Resulting number is converted to string type and
' front padded with "0"s to achieve apprpriate "length"
'
' If natural length of new version number is > length, "XXX"
' is assigned to VerNum and function exits. For example,
' orig ver number = 98, length = 2 and Inc = 3. New number
' is 101 which is longer than 2
' Limitations: none
' Passed Values:
' StrOldVerNum [in, string] original version number
' Length [in, int/long] desired length of new version
' number (actual number is left
' padded with "0"s)
' Inc [in, int/long] increment
'
'****************************************************************************************
'
'
Dim NumZeros As Integer
Dim localVerNum As Long
localVerNum = CLng(strOldVerNum) + Inc
NumZeros = Length - Len(Trim(Str(localVerNum)))
If NumZeros < 0 Then
VerNum = "XXX"
Exit Function
End If
VerNum = String(NumZeros, "0") & Trim(Str(localVerNum))
End Function
Sub SaveAs_Test()
Dim SaveType As String
SaveType = InputBox("date or vers or ???? approach?")
If SaveType = "" Then Exit Sub
Call VerSaveAs(SaveType)
End Sub
|