Obtenga un nombre de archivo único usando VBA

Vba

Módulo estándar

'module: mod_GetUniqueFilename_s4p
'*************** Code Start ***************************************************
' Purpose  : return a unique filename from path\file passed
'              optional add DateTime format such as yymmdd OR yymmdd_hhnnss
'                    uses Now if datetime value not specified and format is
'              if duplicate found, increment counter according to psFormatNumber, default="00"
' Author   : crystal (strive4peace)
' Code List: www.msaccessgurus.com/code.htm
' This code: 
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Mark your changes. Use at your own risk.
'--------------------------------------------------------------------------------
'                              GetUniqueFilename_s4p
'--------------------------------------------------------------------------------
Function GetUniqueFilename_s4p(psPathFile As String _ 
   ,Optional psFormatDate2Add As String =  "" _ 
   ,Optional psFormatNumber As String =  "00" _ 
   ,Optional pvDateTime As Variant _ 
   ) As String 
'240210 s4p, 11, 317, 240726
'return psPathFile if filename is unique
' if not unique, add possible datetime stamp and test again
' if not unique, increment counter on end of filename before extension
'     continue incrementing and testing until a unique filename is found

   'PARAMETERS
   '  psPathFile = file to check or add (datetime and) numbers to file name
   '  psFormatDate2Add:
   '        if specified, Format(pvDateTime or Now) will be appended to end
   '           before extension. Automatically delimited with _
   '           ie: yymmdd_hhnn
   '        "" (default) means adding Date/Time is not desired
   '        instead or in addition to increment number
   '  psFormatNumber controls format of the incremented number
   '     00 can go to 99. After that, numbers are still shown,
   '                 but sorting won't be right, 99 should be enough!
   '  pvDateTime - date/time to use for naming the file if not unique
   '        if psFormatDate2Add <> ""
   '        And you want something other than Now()
   '        IGNORED if psFormatDate2Add = ""
   
   Dim iPos As Integer _ 
      ,iCount As Integer _ 
      ,sPathFileNoExtension As String _ 
      ,sPathFile As String _ 
      ,sExt As String _ 
      ,sResult As String _ 
      ,sDateTime As String _ 
      ,nDateTime As Date 

   'initalize return value
   GetUniqueFilename_s4p =  ""
   
   'if no file spec passed, then exit
   If psPathFile =  "" Then Exit Function 
   
   'see if what was passed is already unique
   If Not Dir(psPathFile) <>  "" Then   ',0 vbNormal
      'filename is unique
      GetUniqueFilename_s4p = psPathFile 
      Exit Function 
   End If 
   
   'NOT UNIQNUE so filename before extension needs to change
   
   'separate file name from extension
   ' assume last period begins file extension, if there is one
   '     to avoid using FSO
   iPos = InStrRev(psPathFile, ".") 
   If Not iPos > 0 Then 
      'no extension
      sExt =  ""
      sPathFileNoExtension = psPathFile 
   Else 
      'Dot plus Extension
      sExt = Mid(psPathFile,iPos) 
      sPathFileNoExtension = Left(psPathFile,iPos - 1) 
   End If 
   
   ' ---- append datetime stamp to filename?
   sDateTime =  "" 'default --  nothing added
   If psFormatDate2Add <>  "" Then 
      'format specified -- get a date/time
      If IsMissing(pvDateTime) Then 
         nDateTime = Now() 
      Else 
         'has value, make sure its a date
         If IsDate(pvDateTime) Then 
            nDateTime = CDate(pvDateTime) 
            If nDateTime = 0 Then 
               'assume not valid
               nDateTime = Now() 
            End If 
         Else 
            nDateTime = Now() 
         End If 
      End If 
      'date/time string to add
      sDateTime = Format(nDateTime,psFormatDate2Add) 
      
      'add datetime stamp to filename
      sPathFileNoExtension = sPathFileNoExtension _ 
                        &  "_" & sDateTime 
                        
      sPathFile = sPathFileNoExtension & sExt 
      
      'check file with datetime stamp added
      If Not Dir(sPathFile) <>  "" Then 
         'filename is unique
         GetUniqueFilename_s4p = sPathFile 
         Exit Function 
      End If 
   End If 
   
   '----------------------- add increment counter to Filename
   'filename still isn't unique
   'increment number at end of FileName before extension (if there is one)
   iCount = 0 
   sResult =  "keep testing"
   sPathFile =  "" 'reset return value
   Do While sResult <>  ""
      
      iCount = iCount + 1  'increment counter
      sPathFile = sPathFileNoExtension _ 
         &  "_" & Format(iCount,psFormatNumber) _ 
         & sExt 
      '----------------------- check file
      sResult = Dir(sPathFile) 

   Loop 
   
   GetUniqueFilename_s4p = sPathFile 


End Function 

'--------------------------------------------------------------------------------
'                              test
'--------------------------------------------------------------------------------
Sub testGetUniqueFilename() 
'240211, 240726

   'CLICK HERE
   'PRESS F5 to RUN!
   
   Dim sPathFile As String 
   '---------------------- change sPathFile and parameters
'   sPathFile = "C:\MyPath\Demo\Files\test" 'no extension
   sPathFile =  "C:\MyPath\Demo\Files\test.txt"
'   sPathFile = "C:\NonExistingFile.txt"
   
   Debug.Print  "GetUniqueFilename_s4p: check " & sPathFile 
'   Debug.Print Space(3); GetUniqueFilename_s4p(sPathFile, "yymmdd_hhmm", "0")
'   Debug.Print Space(3); GetUniqueFilename_s4p(sPathFile) ', , "0"
'   Debug.Print Space(3); GetUniqueFilename_s4p(sPathFile)
   Debug.Print Space(3); GetUniqueFilename_s4p(sPathFile, "yymmdd") 
   
End Sub 
'*************** Code End *****************************************************

‘ El código se generó con colores usando el complemento gratuito Color Code para Access