Word to Excel (part 2)

In a past post I dealed with the needing of moving Word to Excel.

Recently I needed to get all the tables from a bunch of Word documents inside Excel. The thing was that the Copy-PasteSpecial Format:=”Text” did not behaved as expected, as it did not paste as text but as an image. Uhm, we start to get into trouble. To get things worse, then I found that the paste operation was getting itself in problems when they mess with the screenupdating or the calculation… Excel getting into “Busy state”, so I set a “wait until Complete state” loop to solve this point.

And then I realised the word tables, that came from a PDF that also came from a Word document had an caotic structure because the “translation” operations. Buf… to much to deal with (after we can get the table stuff).

Here is the code that takes the tables from Word to Excel (as they come). Handy to use whenever we need Word To Excel data interchange.

Public Sub read_word_document()
'!!!!!!!!!!!!!!!!!!!!!!!!!
    Dim DOC_PATH As String: DOC_PATH = ThisWorkbook.Path & "\"
'!!!!!!!!!!!!!!!!!!!!!!!!!
    Dim strFile As String
    Dim oXlApp As Excel.Application
    Dim oXlWbk As Excel.Workbook
    Dim oXlWbk0 As Excel.Workbook
    Dim oXlWsh As Excel.Worksheet
    Dim oXlWsh0 As Excel.Worksheet
    Dim oXlRng As Excel.Range
    Dim oXlTRow As Excel.Range
    Dim oXlTCol As Excel.Range
    Dim oXlCell As Excel.Range
    
    Dim oWdApp As Word.Application
    Dim oWdDoc As Word.Document
    Dim oWdTab As Word.Table
    Dim oWdTRow As Word.Row
    Dim oWdTCol As Word.Column
    Dim oWdCell As Word.Cell
    
    Dim lgTable As Long
    Dim bGetData As Boolean
    'Dim bSplitData As Boolean
    Dim lgR As Long
    Dim lgC As Long
    Dim strText As String
    Dim aData() As String
    Dim lgData As Long
    
'    On Error GoTo ErrHandler
    Set oWdApp = GetObject(, "Word.Application")
    'Set oWdApp = CreateObject("Word.Application")
    'oWdApp.Visible = False
    Do While oWdApp.Documents.Count > 0
        oWdApp.ActiveDocument.Close SaveChanges:=False
    Loop
    
    Set oXlApp = GetObject(, "Excel.Application")
    'Set oXlApp = CreateObject("Excel.Application")
    'oXlApp.Visible = False
    Set oXlWbk0 = oXlApp.ActiveWorkbook
     
    'lgR = 0
    strFile = VBA.Dir(DOC_PATH & "*.doc*")
    Do Until strFile = vbNullString
        Set oWdDoc = oWdApp.Documents.Open(Filename:=DOC_PATH & strFile, ReadOnly:=True)

        If oWdDoc.Tables.Count > 0 Then
            Set oXlWbk = oXlApp.Workbooks.Add() '.Open(fileName:=DOC_PATH & strFile, ReadOnly:=False)
            oXlWbk.SaveAs Filename:=DOC_PATH & VBA.Replace(strFile, ".doc", ".xls")
            
            lgR = 0
            Set oXlWsh0 = oXlWbk0.Sheets.Add
            oXlWsh0.Name = "#" & strFile
            oXlWsh0.Activate
            Set oXlRng = oXlWsh0.Range("A1")
            'oXlWsh0.Cells.ClearContents
            oXlRng.Select
            
            lgTable = 0 ' resume table
            For Each oWdTab In oWdDoc.Tables
                DoEvents

'                If vbNo = MsgBox("table " & lgTable & ", resume?", vbYesNo) Then Stop
'                On Error Resume Next
'                For Each oWdTRow In oWdTab.Rows
'                    If Err.Number = 5991 Then GoTo ExitTable
'                    If bGetData Then ' copy this data
'                        lgR = lgR + 1
'                        lgC = 0
'                        For Each oWdCell In oWdTRow.Cells
'                            lgC = lgC + 1
'                            If Not VBA.Trim$(oWdCell.Range.text) Like vbNullString Then
'                                oXlWsh.Cells(lgR, lgC).Value = oWdCell.Range.text
'                            End If
'                        Next oWdCell
'                    End If
'                Next oWdTRow
'ExitTable:
'                On Error GoTo 0
                'bSplitData = False
                lgTable = lgTable + 1
                Set oXlWsh = oXlWbk.Sheets.Add
                oXlWsh.Name = "H_" & lgTable
                oXlWsh.Activate
                Set oXlRng = oXlWsh.Range("A1")
                oXlRng.Select
                
                ' Copy table to Excel, then depurate
                oWdTab.Select
            
                On Error GoTo ErrWait
                oWdTab.Range.Copy
                oXlRng.Parent.Paste
                On Error GoTo 0
                
                'oXlRng.Parent.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False
                Set oXlRng = oXlRng.Resize(oWdTab.Rows.Count, oWdTab.Columns.Count)
                With oXlRng
                    With .Cells
                        .UnMerge
                        .MergeCells = False
                        .WrapText = False
                        .VerticalAlignment = xlBottom
                        .Orientation = 0
                        .AddIndent = False
                        .IndentLevel = -1
                        .ShrinkToFit = False
                        .ReadingOrder = xlContext
                        
                        '.columnWidth = 14
                        '.RowHeight = 14
                        .Font.Size = 10
                        .Font.Name = "Calibri"
                    End With
                    
                    For Each oXlTRow In oXlRng.Rows
                        'bGetData = False
                        'For Each oXlCell In oXlTRow.Cells
                        '    If VBA.UCase$(oXlCell.Value) Like "*" Then
                        '        bGetData = True
                        '        Exit For
                        '    End If
                        'Next oXlCell
    
                        If bGetData Then ' copy this row
                            'bSplitData = True
                            lgR = lgR + 1
                            lgC = 0
                            For Each oXlCell In oXlTRow.Cells
                                'If Not IsEmpty(oXlCell.Value) Then
                                If Not VBA.Trim$(oXlCell.Value) Like vbNullString Then
                                    lgC = lgC + 1
                                    oXlWsh0.Cells(lgR, lgC).Value = oXlCell.Value
                                End If
                            Next oXlCell
                        End If
                    Next oXlTRow
                End With
            
                'If bSplitData Then lgR = lgR + 3
                Set oXlRng = oXlRng.Offset(oWdTab.Rows.Count + 2, 0)
            Next oWdTab
        End If
                    
        'Stop
        ' Delete all temp worksheets
        'oXlApp.DisplayAlerts = False
        'For Each oXlWsh In oXlWbk.Worksheets
        '    If oXlWsh.Name Like "H*" Then
        '        oXlWsh.Delete
        '    End If
        'Next oXlWsh
        'oXlApp.DisplayAlerts = True
        'Stop

        oWdDoc.Close SaveChanges:=False
        oXlWbk.Close SaveChanges:=False
        
        strFile = VBA.Dir
    Loop
'    oWdApp.Quit
     
    GoTo done
     
ErrWait:
'Stop
    Application.Wait ((Now + TimeValue("0:00:02")))
    Resume

ErrClose:
    On Error Resume Next
     
ErrHandler:
    Debug.Print Err.Description
    On Error GoTo 0

done:
    ' Move all worksheets that has "#" to new file
    Dim aArray As Variant
    
    lgData = -1
    Erase aData()
    For Each oXlWsh0 In oXlWbk0.Worksheets
        If oXlWsh0.Name Like "[#]*" Then
            lgData = lgData + 1
            ReDim Preserve aData(0 To lgData)
            aData(lgData) = oXlWsh0.Name
        End If
    Next oXlWsh0
    aArray = aData()
    oXlWbk0.Sheets(aArray).Move
End Sub

EXCEL VBA MULTITHREADING

This is another post I have started beeing inspired by posts on AnalystCave blog, and wanted to reach further from where he left it.

There are some starting posts with info that worth to take a look before getting hands on dough:

Continue reading “EXCEL VBA MULTITHREADING”

VBA FTP

Again, from AnalystCave blog, I’ve found an interesting post about how to perform download/upload via FTP protocol in VBA. We should rely on some API functions. The code presented here is 90% the same from the original post, but tidied a bit so it can be reused on a UserForm with ease. There’s only the need for 4 textboxes (userName, Password, Port, SeverHost IP address), and 2 more textboxes (linked one each to 2 listboxes/treebox) to deal with the archives both in the local drive and in the server. And buttons to Upload/Download and Cancel… and you have a clean interface to do FTP under VBA.

Following are the common API functions and constants needed:

Private Const FTP_TRANSFER_TYPE_UNKNOWN As Long = 0
Private Const INTERNET_FLAG_RELOAD As Long = &H80000000

Private Declare Function InternetOpenA Lib "wininet.dll" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetConnectA Lib "wininet.dll" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Long, ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lcontext As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Long
Private Declare Function FtpGetFileA Lib "wininet.dll" (ByVal hConnect As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Long, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function FtpPutFileA Lib "wininet.dll" (ByVal hFtpSession As Long, ByVal lpszLocalFile As String, ByVal lpszRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean

VBA FTP Download Files

To download files via FTP protocol in VBA, use this code:

Private Function FtpDownload(ByVal strRemoteFile As String, _
                             ByVal strLocalFile As String, _
                             ByVal strHost As String, _
                             ByVal lngPort As Long, _
                             ByVal strUser As String, _
                             ByVal strPass As String) As Boolean
' to download file from server:
    
    Dim hOpen As Long
    Dim hConn As Long
    Dim lgRetVal As Long

    hOpen = InternetOpenA("FTPGET", 1, vbNullString, vbNullString, 1)
    hConn = InternetConnectA(hOpen, strHost, lngPort, strUser, strPass, 1, 0, 2)
    
    If Not FtpGetFileA(hConn, _
                       strRemoteFile, _
                       strLocalFile, _
                       1, _
                       0, _
                       FTP_TRANSFER_TYPE_UNKNOWN Or INTERNET_FLAG_RELOAD, _
                       0) Then
        lgRetVal = VBA.MsgBox("Error while downloading file [" & strRemoteFile & "] from server", _
                              vbCritical, "W A R N I N G")
    End If

     'Close connections
    InternetCloseHandle hConn
    InternetCloseHandle hOpen
End Function
Syntax

strRemoteFile 
A string path to the file on the remote FTP drive which you want to download e.g. “//home/user/text file.txt”

strLocalFile 
A string path to the file on the local drive which you want to save the remote file to e.g. “C:\text file.txt”

strHost 
A string with the FTP server name e.g. “192.168.0.100” or “myserver.domain.com”.

lngPort 
A number specifying the FTP port. 21 by default.

strUser 
A string with the FTP user name.

strPass
A string with the FTP user password.

Example

Now let us use the above VBA FTP Download procedure to download a file from our FTP server.

Public Sub TestDownload()
    FtpDownload strRemoteFile:="//Download/file.txt", _
                strLocalFile:="C:\text file.txt", _
                strHost:="192.168.0.100", _
                lngPort:=21, _
                strUser:="username", _
                strPass:="password"
End Sub
VBA FTP Upload Files

To upload files from your local drive via FTP protocol in VBA, use this code:

Private Function FtpUpload(ByVal strLocalFile As String, _
                           ByVal strRemoteFile As String, _
                           ByVal strHost As String, _
                           ByVal lngPort As Long, _
                           ByVal strUser As String, _
                           ByVal strPass As String) As Boolean
' to upload file to server:
    
    Dim hOpen As Long
    Dim hConn As Long
    Dim lgRetVal As Long

    hOpen = InternetOpenA("FTPGET", 1, vbNullString, vbNullString, 1)
    hConn = InternetConnectA(hOpen, strHost, lngPort, strUser, strPass, 1, 0, 2)

    If Not FtpPutFileA(hConn, _
                       strLocalFile, _
                       strRemoteFile, _
                       FTP_TRANSFER_TYPE_UNKNOWN Or INTERNET_FLAG_RELOAD, _
                       0) Then
        lgRetVal = VBA.MsgBox("Error while uploading file [" & strRemoteFile & "] to server", _
                              vbCritical, "W A R N I N G")
    End If

     'Close connections
    InternetCloseHandle hConn
    InternetCloseHandle hOpen
End Function

Syntax

strLocalFile 
A string path to the file on the local drive which you want to upload e.g. “C:\text file.txt”
strRemoteFile 
A string path with the name of the upload file on the remote drive to e.g. “//home/user/text file.txt”

strHost 
A string with the FTP server name e.g. “192.168.0.100” or “myserver.domain.com”.

lngPort 
A number specifying the FTP port. 21 by default.

strUser 
A string with the FTP user name.

strPass
A string with the FTP user password.

Example

Public Sub TestUpload()
    FtpUpload strLocalFile:=VBA.Environ("UserProfile") & "\Documents\" & "file.txt", _
              strRemoteFile:="//Download/file.txt", _
              strHost:="192.168.0.100", _
              lngPort:=21, _
              strUser:="username", _
              strPass:="password"
End Sub

Download a file via VBA. Resume downloads

I’ve tried several ways to download a file, but none of them were truly convincing me, beeing the most promissing the URLDownloadToFile API function. But recently I found a post on the AnalystCave that rely on the InternetReadBinaryFile
The use of this API functions got me thinking if I can control the download progress (for example, to resume a broken download, or throw it to perform on VBscript). The VBS option comes really handy, as can free Excel of the downloading process, and doesn’t require an InternetExplorer object, so it can be used also as a method to overcome ban situations and continue downloading.

The lNumBytesToRead in the InternetReadBinaryFile function was very promissing, but did not manage to tame it to my requirements, so it looks like to resume a download will not be achieved via API functions. Anyway, googling a bit shows me that it could be done via XMLHTTP request (you had to tune the Range attribute… worth looking here,  here and here)

There’s another option to download files described here.

And following, the code that achieves the download resume:


Private Sub ResumeDownload(ByVal strURL As String, _
                           ByVal sSaveToFile As String, _
                           Optional ByVal overWriteFile As Boolean = False, _
                           Optional ByVal lgFirstByteToRead As Long = 0, _
                           Optional ByVal lgBytesToRead As Long = 0)
    Dim oHTTP As Object
    Dim oStream As Object
    Dim sBuffer() As Byte
    Dim totalRead As Long
    
    'Const bufSize = 128
    
    Set oHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    
    With oHTTP
        .Open "GET", strURL, False
        
        .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .setRequestHeader "Range", VBA.CStr("bytes=" & lgFirstByteToRead & "-" & VBA.IIf(lgBytesToRead = 0, "", lgFirstByteToRead + lgBytesToRead)) ' retrieve only this bytes...
        .send ("")
        
        'wait
        Do While .Status = 200 And .readyState = 4
            DoEvents
        Loop
        
        If lgBytesToRead = 0 Then lgBytesToRead = VBA.Len(.responsetext)
        
        ReDim sBuffer(0 To lgBytesToRead - 1)
        
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        
        'Do
        '    lgRetVal = InternetReadBinaryFile(hInternet, sBuffer(0), UBound(sBuffer) - LBound(sBuffer), lngDataReturned)
        '    If lngDataReturned = 0 Then Exit Do
        '
        '    If lngDataReturned < bufSize Then ReDim Preserve sBuffer(0 To lngDataReturned - 1)
            oStream.Write sBuffer
        '    ReDim sBuffer(0 To bufSize - 1)
        '    totalRead = totalRead + lngDataReturned
        '    'Application.StatusBar = "Downloading file. " & CLng(100 * totalRead / bufSize) & "% of " & totalRead & " KB downloaded"
        '    DoEvents
        'Loop While lngDataReturned <> 0
            
        'Application.StatusBar = "Download complete"
        oStream.SaveToFile sSaveToFile, IIf(overWriteFile, 2, 1)
        oStream.Close
    
        Dim iFileOut As Integer
        iFileOut = VBA.FreeFile()
        Open sSaveToFile For Binary As #iFileOut
        Put #iFileOut, , VBA.StrConv(.responsetext, vbFromUnicode)
        Close #iFileOut
    End With
End Sub

For the API methods, both discussed are shown here, activate the one you whish to try:

Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Option Explicit

Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Private Const DOWNLOAD_OK As Long = 0
'Private Const E_OUTOFMEMORY As Long = &H8007000E
'Private Const INTERNET_OPEN_TYPE_PRECONFIG As Long = 0
'Private Const INTERNET_FLAG_EXISTING_CONNECT As Long = &H20000000
'Private Const INTERNET_OPEN_TYPE_DIRECT As Long = 1
'Private Const INTERNET_OPEN_TYPE_PROXY As Long = 3
'Private Const INTERNET_FLAG_RELOAD As Long = &H80000000
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal lpszAgent As String, ByVal dwAccessType As Long, ByVal lpszProxyName As String, ByVal lpszProxyBypass As String, ByVal dwFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal sUrl As String, ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetReadBinaryFile Lib "wininet.dll" Alias "InternetReadFile" (ByVal hfile As Long, ByRef bytearray_firstelement As Byte, ByVal lNumBytesToRead As Long, ByRef lNumberOfBytesRead As Long) As Integer
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer

Sub TestDownload()
    Dim strPath As String
    strPath = VBA.Environ$("UserProfile") & "\Documents\" 'ThisWorkbook.Path
    'DownloadFile "https://analystcave.com/junk.txt", strPath & "junk.txt", True
    DownloadFile "https://www.planwallpaper.com/static/cache/76/ae/76aef16c40b4e4447233badc50b1845a.jpg", strPath & "image_https_2.jpg"
End Sub

Sub DownloadFile(ByVal sUrl As String, _
                 ByVal sSaveToFile As String, _
                 Optional ByVal overWriteFile As Boolean = False)
    Dim oStream As Object
    Dim hInternet As Long
    Dim hSession As Long
    Dim lngDataReturned As Long
    Dim sBuffer() As Byte
    Dim totalRead As Long
    Dim lgRetVal As Long
    
Stop    ' Method URLDownloadToFile
    'lgRetVal = URLDownloadToFile(0&, sUrl, sSaveToFile, 0&, 0)
    'If lgRetVal = DOWNLOAD_OK Then Exit Sub ' download completed
    
Stop    ' Method InternetReadBinaryFile
    Const bufSize = 128
    
    ReDim sBuffer(0 To bufSize - 1)
 
    hSession = InternetOpen("", 0, vbNullString, vbNullString, 0)
    If hSession Then
        hInternet = InternetOpenUrl(hSession, sUrl, vbNullString, 0, INTERNET_FLAG_NO_CACHE_WRITE, 0)
    End If
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    
    If hInternet Then
        lngDataReturned = 0
        Do
            lgRetVal = InternetReadBinaryFile(hInternet, sBuffer(0), UBound(sBuffer) - LBound(sBuffer), lngDataReturned)
            If lngDataReturned = 0 Then Exit Do
            
            If lngDataReturned < bufSize Then ReDim Preserve sBuffer(0 To lngDataReturned - 1)
            oStream.Write sBuffer()
            ReDim sBuffer(0 To bufSize - 1)
            totalRead = totalRead + lngDataReturned
            Application.StatusBar = "Downloading file. " & CLng(100 * totalRead / bufSize) & "% of " & totalRead & " KB downloaded"
            DoEvents
        Loop While lngDataReturned <> 0
        
        Application.StatusBar = "Download complete"
        oStream.SaveToFile sSaveToFile, IIf(overWriteFile, 2, 1)
        oStream.Close
    End If
    Call InternetCloseHandle(hInternet)

    Set oStream = Nothing
End Sub

Also, dealing with downloads topic, I also liked this post.

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