VBA Express : Excel - Generate a unique sequential filename.

Excel

Generate a unique sequential filename.

Ease of Use

Intermediate

Version tested with

2003

Submitted by:

Kenneth Hobs

Description:

A unique full path with filename is generated from a folder and base filename. Neither folder nor filename need exist. If they do, gaps in the sequential filenames are filled first. Requires v5 of shell32.dll which is included in XP SP2 and Windows Server 2003. It is my Vista x64 as well.

Discussion:

This concept can be used in any VBA code where one needs to generate a unique filename with a prefix or base name. The filenames generated are from a folder name and a base filename though neither need exist. e.g. c:\file.xls, c:\file (1).xls, c:\file (2).xls, etc. Basically, two API's are shown. Four custom functions enable the user to pass the folder name and base filename separately or as one string. The concept of this macro is a bit similar to tstav's KB entry to produce a unique suffix for a filename. In the XLS attachment, I have compared this method to tstav's method. http://vbaexpress.com/kb/getarticle.php?kb_id=1008

Code:

instructions for use

			Sub Test1() 
    Dim s As String 
    s = fMakeAnotherUnique("", Environ("username") & ".xls", ThisWorkbook.Path) 
    MsgBox s, vbInformation, "MsgBox1: fMakeAnotherUnique()" 
    s = fMakeAnotherUnique("", ThisWorkbook.Name, ThisWorkbook.Path) 
    MsgBox s, vbInformation, "MsgBox2: fMakeAnotherUnique()" 
End Sub 
 
Sub Test2() 
    Dim s As String 
    s = MakeAnotherUnique(ThisWorkbook.Path & "\" & Environ("username") & ".xls") 
    MsgBox s, vbInformation, "MsgBox3: MakeAntoherUnique()" 
    s = MakeAnotherUnique(ThisWorkbook.FullName) 
    MsgBox s, vbInformation, "MsgBox4: MakeAntoherUnique()" 
End Sub 
 
Sub Test3() 
    Dim s As String 
    s = fMakeUnique("", Environ("username") & ".xls", ThisWorkbook.Path) 
    MsgBox s, vbInformation, "MsgBox5: fMakeUnique()" 
    s = fMakeUnique("", ThisWorkbook.Name, ThisWorkbook.Path) 
    MsgBox s, vbInformation, "MsgBox6: fMakeUnique()" 
End Sub 
 
 
Sub Test4() 
    Dim s As String 
    s = MakeUnique(ThisWorkbook.Path & "\" & Environ("username") & ".xls") 
    MsgBox s, vbInformation, "MsgBox7: MakeUnique()" 
    s = MakeUnique(ThisWorkbook.FullName) 
    MsgBox s, vbInformation, "MsgBox8: MakeUnique()" 
End Sub 
 
 'Put this part below in a separate module.
Const Max_Path As String = 260 
 'http://msdn.microsoft.com/en-us/library/bb776479.aspx
Public Declare Function PathYetAnotherMakeUniqueName _ 
Lib "shell32.dll" _ 
( _ 
ByVal pszUniqueName As String, _ 
ByVal pszPath As String, _ 
ByVal pszShort As String, _ 
ByVal pszFileSpec As String _ 
) As Boolean 
 
 'http://msdn.microsoft.com/en-us/library/bb776479.aspx
Public Declare Function PathMakeUniqueName _ 
Lib "shell32.dll" _ 
( _ 
ByVal pszUniqueName As String, _ 
ByVal cchMax As Long, _ 
ByVal pszTemplate As String, _ 
ByVal pszLongPlate As String, _ 
ByVal pszDir As String _ 
) As Boolean 
 
Function fMakeAnotherUnique(vShortTemplate, vLongTemplate, vFolder) As String 
     'vFolder can end in trailing backslash or not
    Dim rc As Boolean, vUniqueName As String, s As String 
    vUniqueName = Space$(Max_Path) 
    rc = PathYetAnotherMakeUniqueName(vUniqueName, StrConv(vFolder, vbUnicode), _ 
    StrConv(vShortTemplate, vbUnicode), StrConv(vLongTemplate, vbUnicode)) 
    If rc Then 
        vUniqueName = StrConv(vUniqueName, vbFromUnicode) 
        fMakeAnotherUnique = vUniqueName 
    End If 
End Function 
 
Function MakeAnotherUnique(filespec As String) As String 
    MakeAnotherUnique = fMakeAnotherUnique("", GetFileName(filespec), GetFolderName(filespec)) 
End Function 
 
Function fMakeUnique(vShortTemplate, vLongTemplate, vFolder) As String 
     'vFolder can end in trailing backslash or not
    Dim rc As Boolean, vUniqueName As String, s As String 
    vUniqueName = Space$(Max_Path) 
    rc = PathMakeUniqueName(vUniqueName, Max_Path, StrConv(vShortTemplate, vbUnicode), _ 
    StrConv(vLongTemplate, vbUnicode), StrConv(vFolder, vbUnicode)) 
    If rc Then 
        vUniqueName = StrConv(vUniqueName, vbFromUnicode) 
        fMakeUnique = vUniqueName 
    End If 
End Function 
 
Function MakeUnique(filespec As String) As String 
    MakeUnique = fMakeUnique("", GetFileName(filespec), GetFolderName(filespec)) 
End Function 
 
Function GetFileName(filespec As String) As String 
    Dim p1 As Integer, p2 As Integer 
    p1 = InStrRev(filespec, "\") 
    p2 = Len(filespec) - p1 
    GetFileName = Mid$(filespec, p1 + 1, p2) 
End Function 
 
Function GetFolderName(filespec As String) As String 
    Dim p1 As Integer 
    p1 = InStrRev(filespec, "\") 
    GetFolderName = Left$(filespec, p1) 
End Function

How to use:

Open the example XLS file and click each of Test buttons, or:
Copy the above code.
Open any workbook.
Press Alt + F11 to open the Visual Basic Editor (VBE).
From the Menu, choose Insert-Module.
Paste the code into the right-hand code window.
Move the Test1 to Test4 Subs to the end or cut and paste to another Module.
Close the VBE, save the file if desired.

Test the code:

Open the example XLS file and click each of Test buttons.
Save the file with names like those generated and re-click the Test buttons.
Note how the filenames are generated.
After saving the workbook with filenames that have (2).xls , (3).xls, (4).xls and such, delete one in the middle and click the Test buttons to note how the next generated name is the one that was deleted.

Sample File:

PathYetAnotherMakeUniqueName.zip 23.79KB

Approved by mdmackillop

This entry has been viewed 462 times.