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