Visual Basic > Files Directories Drives

Creating a unique file name

Creating a unique file name

Below is a routine which creates a unique indexed file name based on an input file name.

Option Explicit



'Purpose     :  Returns a unique file name given an filename as a seed
'Inputs      :  sFilename                   The path and file name to be used as a seed.
'Outputs     :  Returns an unique indexed version of the filename from the input parameter "sFilename".
'               Returns an empty file name on error.
'Notes       :
'Revisions   :

Function FileNameGetUnique(sFileName As String) As String
    Dim lCount As Long, lPosDot As Long
    Dim sFileNoExtension As String, sExtension As String

    On Error GoTo ErrFailed
    If Len(sFileName) = 0 Then
        Debug.Assert "Error: Empty File name supplied to " & FileNameGetUnique
        Exit Function
    End If
    
    'Remove file extension
    lPosDot = InStrRev(sFileName, ".")
    If lPosDot Then
        sFileNoExtension = Left$(sFileName, lPosDot - 1)
        sExtension = Mid$(sFileName, lPosDot)
    Else
        sFileNoExtension = sFileName
    End If
    
    'Get unique file name
    Do
        lCount = lCount + 1
    Loop While Len(Dir$(sFileNoExtension & "." & CStr(lCount) & sExtension))
    FileNameGetUnique = sFileNoExtension & "." & CStr(lCount) & sExtension
    Exit Function

ErrFailed:
    Debug.Print Err.Description
    Debug.Assert False
    FileNameGetUnique = ""
End Function

'Demonstration routine
Sub Test()
    Dim sFileName As String, sUniqueFileName As String
    sFileName = "C:\Filename.xls"
    sUniqueFileName = FileNameGetUnique(sFileName)
    MsgBox "The unique file name is " & sUniqueFileName
End Sub