VBA 同名のファイルがあるときにカッコつきで枝番を追加して重複を避けたファイル名を生成する関数 Same Filename add 2 digit number in BracketsFunction

今回はOfficeVBAユーザー定義関数

同名のファイルがあるときにカッコつきで枝番を追加して重複を避けたファイル名を生成する関数
Same Filename add 2 digit number in BracketsFunction

前提

D:\abcd.txt というファイルが同名ならD:\abcd(01).txtにする

最大は99

最大はabcd(99).txtまで

返り値のデータ型

返り値のデータ型はテキスト/String
エラーはNullstringを返す。

02があって01がない場合は03を返す

またD:\abcd(02).txtならD:\abcd(03).txtを返す

(01)(02).txtなら(01)(03).txtを返す

一番後ろだけ置換することで途中にカッコつき数字があっても変換されません。

ファイル名をフルパス/フルネームで入れるとフルパス/フルネームで返す

書式

fnNewFileNameAddNumInBrac("C/hoge/hoge.txt")

コード

Function fnNewFileNameAddNumInBrac(strFullPathFileName) As String
'For Office VBA
'Recommend Reference setting Microsoft Scripting Runtime and Vbscript Regular expression 5.5
' Usage fnNewFileNameAddNumInBrac("C/hoge/hoge.txt")
Const MaxDegit = 2 '99までに制限
Const Maxdegitstring = "9" ' この場合99+1で桁オーバーにする 3ケタの場合はMaxDigitを3にする。ただし9だと999までいくため5で555くらいがいいのでは。
Dim FSO: Set FSO = CreateObject("Scripting.FileSystemObject"): 'Dim FSO As New Scripting.FileSystemObject
Dim oFolder 'As Folder
Dim oFIle 'As File
Dim ar, iar, i As Long, i1 As Long
Dim strPath As String, strFile As String, strBase As String, strExt As String
Dim Reg: Set Reg = CreateObject("VBScript.RegExp")
Dim MC, M, iM, sMs, strLast5$
ar = Split(strFullPathFileName, "\")
For i = UBound(ar) - 1 To 0 Step -1
strPath = ar(i) & "\" & strPath
Next
i = -1
On Error GoTo ERR_Handle
If FSO.FolderExists(strPath) = False Then Debug.Print " fnNewFileNameAddNumInBrac occure error line 10 Folder " & strPath & " not exist": Set FSO = Nothing: fnNewFileNameAddNumInBrac = vbNullString: Exit Function ' フォルダがなければエラー
If FSO.FileExists(strFullPathFileName) = False Then
fnNewFileNameAddNumInBrac = strFullPathFileName
Exit Function
Else
Set oFIle = FSO.GetFile(strFullPathFileName)
strExt = FSO.getextensionname(oFIle.Path)
strBase = FSO.getbasename(oFIle.Path)
If Len(strBase) >= MaxDegit + 3 Then
  strLast5 = Right(strBase, MaxDegit + 3) 'ファイル名が長いときは途中の枝番に見えるところを変換しかねないのでカットして変換する
Else
  strLast5 = strBase
End If
Reg.Pattern = "\([0-9]{0," & MaxDegit & "}\)": Reg.Global = True: Reg.MultiLine = False
  If Reg.test(strLast5) = True Then
  If Len(strBase) >= MaxDegit + 3 Then
  Set MC = Reg.Execute(strLast5)
  strLast5 = Replace(strBase, MC(MC.Count - 1), "", 1, 1, vbTextCompare)
  strBase = Left(strBase, MC(0).FirstIndex + 1) & strLast5
  i = CLng(Replace(Replace(MC(MC.Count - 1).Value, "(", "", 1, 1, vbTextCompare), ")", "", 1, -1, vbTextCompare))
Else
  Set MC = Reg.Execute(strLast5)
  strBase = Replace(strBase, MC(MC.Count - 1), "", 1, 1, vbTextCompare)
  i = CLng(Replace(Replace(MC(MC.Count - 1).Value, "(", "", 1, 1, vbTextCompare), ")", "", 1, -1, vbTextCompare))
End If
End If
If i = -1 Then i = 0 ’When Figure in Bracket is Nothing, i = 0  
Do
  i = i + 1
  If i > CLng(String(MaxDegit, Maxdegitstring)) Then fnNewFileNameAddNumInBrac = vbNullString: Debug.Print "Branch count " & CLng(String(MaxDegit, "9")) + 1 & " over Too Many": Exit Function
  If FSO.FileExists(strPath & strBase & "(" & String(MaxDegit - Len(CStr(i)), "0") & i & ")." & strExt) = False Then
    Set FSO = Nothing
    fnNewFileNameAddNumInBrac = strPath & strBase & "(" & String(MaxDegit - Len(CStr(i)), "0") & i & ")." & strExt
    Exit Do
  End If
Loop
Exit Function
End If
Exit Function
ERR_Handle:
Set FSO = Nothing
If Err.Number <> 0 Then Debug.Print "fnNewFileNameAddNumInBrac Error strfullpathfile:=" & strFullPathFileName & vbCrLf & Err.Number & vbCrLf, Err.Description: Err.Clear
Exit Function
End Function