Versioning files with VBA

I was wandering through the AnalystCave blog, and stumped on this topic. The add-in posted there was not fullfilling my requirements, so I decided to go a bit further, and then this came out:

Public Sub sSaveNewVersion()
    MsgBox SaveNewVersion("yymmdd*###")
End Sub

Public Function SaveNewVersion(Optional ByVal strTemplate As String = "yymmdd*###") As String
' Recommended templates:
' yymmdd        991231
' hh.mm         2355
' hh.mm.ss      235545
' ###           027
' ##            27
' #             7
' yymmdd_###    991231_015
' yymmdd_hh.mm  991231_23.55
    
    Dim strFileName As String
    Dim strPath As String
    Dim strExtension As String
    Dim aNaming() As String
    Dim strMask As String
    Dim strLastVersion As String
    Dim strPrefix As String
    Dim strSuffix As String

    Dim strVersion As String
    Dim iIndex As Integer

    strPath = ActiveDocument.Path & "\"     ' ActiveWorkbook.Path
    strFileName = ActiveDocument.Name       ' ActiveWorkbook.Name
    'strFileName = "190104_this_is only a test#015.docx"
    
    aNaming() = VBA.Split(strFileName, ".")
    strExtension = aNaming(UBound(aNaming))
    
    strFileName = VBA.Mid$(strFileName, 1, VBA.Len(strFileName) - VBA.Len(strExtension) - 1)
    'iIndex = ...
    
    aNaming() = VBA.Split(strTemplate, "*")
    If LBound(aNaming) = UBound(aNaming) Then
        strPrefix = vbNullString
        strMask = fMask(aNaming(LBound(aNaming)), strSuffix)
        
        strLastVersion = VBA.Mid$(strFileName, VBA.InStrRev(strFileName, "#") + 1)
        strFileName = VBA.Mid$(strFileName, 1, VBA.Len(strFileName) - VBA.Len(strLastVersion) - 1)
        
        If strLastVersion Like strMask Then
        ' Rip off strLastVersion from strFileName
            strFileName = VBA.Mid$(strFileName, 1, InStr(1, strFileName, strLastVersion))
            If strLastVersion Like aNaming(UBound(aNaming)) Then
                ' Get index...
                strSuffix = fNewIndex(aNaming(LBound(aNaming)), VBA.CInt(strLastVersion) + 1)
            End If
        End If
    
    Else
        strMask = fMask(aNaming(LBound(aNaming)), strPrefix)
        strLastVersion = VBA.Mid$(strFileName, 1, VBA.Len(strMask))
        If strLastVersion Like strMask Then
            strFileName = VBA.Mid$(strFileName, VBA.Len(strMask) + 1 + 1)
            If strLastVersion Like aNaming(UBound(aNaming)) Then
                ' Get index...
                strPrefix = fNewIndex(aNaming(LBound(aNaming)), VBA.CInt(strLastVersion) + 1)
            End If
        End If

        strMask = fMask(aNaming(UBound(aNaming)), strSuffix)
        strLastVersion = VBA.Mid$(strFileName, VBA.InStrRev(strFileName, "#") + 1)
        
        If strLastVersion Like strMask Then
        ' Rip off strLastVersion from strFileName
            strFileName = VBA.Mid$(strFileName, 1, VBA.Len(strFileName) - VBA.Len(strLastVersion) - 1)
            If strLastVersion Like aNaming(UBound(aNaming)) Then
                ' Get index...
                strSuffix = fNewIndex(aNaming(UBound(aNaming)), VBA.CInt(strLastVersion) + 1)
            End If
        End If
    End If
    
    strFileName = strPath _
                & strPrefix _
                & "_" _
                & strFileName _
                & "#" _
                & strSuffix & _
                "." & strExtension
    
    'ActiveDocument.SaveAs strFileName ' ActiveWorkbook.SaveAs strFileName
End Function

Private Function fNewIndex(ByVal strTemplate As String, _
                           ByVal iIndex As Integer) As String
' Get new version index
    Dim strVersion As String
    
    strVersion = strTemplate
    If strVersion Like "*[#][#][#]*" Then
        strVersion = VBA.Replace(strVersion, "###", VBA.Format(iIndex, "000"))
    ElseIf strVersion Like "*[#][#]*" Then
        strVersion = VBA.Replace(strVersion, "##", VBA.Format(iIndex, "00"))
    ElseIf strVersion Like "*[#]*" Then
        strVersion = VBA.Replace(strVersion, "#", VBA.Format(iIndex, "0"))
    End If
    
    fNewIndex = strVersion
End Function

Private Function fMask(ByVal strTemplate As String, _
                       ByRef strVersion As String) As String
    Dim strMask As String
    Dim iIndex As Integer
    
    strMask = strTemplate
    strVersion = strTemplate
    If strVersion Like "*yyyy*" Then
        strVersion = VBA.Replace(strVersion, "yyyy", VBA.Format(VBA.Now(), "yyyy"))
        strMask = VBA.Replace(strMask, "yyyy", "####")
    ElseIf strVersion Like "*yy*" Then
        strVersion = VBA.Replace(strVersion, "yy", VBA.Format(VBA.Now(), "yy"))
        strMask = VBA.Replace(strMask, "yy", "##")
    End If
    If strVersion Like "*mmmm*" Then
        strVersion = VBA.Replace(strVersion, "mmmm", VBA.Format(VBA.Now(), "mmmm"))
        strMask = VBA.Replace(strMask, "mmmm", "####")
    ElseIf strVersion Like "*mmm*" Then
        strVersion = VBA.Replace(strVersion, "mmm", VBA.Format(VBA.Now(), "mmm"))
        strMask = VBA.Replace(strMask, "mmm", "###")
    ElseIf strVersion Like "*mm*" Then
        strVersion = VBA.Replace(strVersion, "mm", VBA.Format(VBA.Now(), "mm"))
        strMask = VBA.Replace(strMask, "mm", "##")
    End If
    If strVersion Like "*dd*" Then
        strVersion = VBA.Replace(strVersion, "dd", VBA.Format(VBA.Now(), "dd"))
        strMask = VBA.Replace(strMask, "dd", "##")
    ElseIf strVersion Like "*d*" Then
        strVersion = VBA.Replace(strVersion, "d", VBA.Format(VBA.Now(), "d"))
    End If
    If strVersion Like "*hh.mm*" Then
        strVersion = VBA.Replace(strVersion, "hh.mm", VBA.Format(VBA.Now(), "hh.mm"))
        strMask = VBA.Replace(strMask, "hh.mm", "##.##")
    ElseIf strVersion Like "*hh*" Then
        strVersion = VBA.Replace(strVersion, "HH", VBA.Format(VBA.Now(), "hh.mm"))
        strMask = VBA.Replace(strMask, "hh", "##")
    End If
    If strVersion Like "*ss*" Then
        strVersion = VBA.Replace(strVersion, "ss", VBA.Format(VBA.Now(), "ss"))
        strMask = VBA.Replace(strMask, "ss", "##")
    End If
    
    fMask = strMask
End Function

Hope you enjoy