ファイル名が重複しているときに自動ナンバリングしたファイル名を返すメソッドの改良

VBA自作メソッド

ファイル名が重複しているときに自動ナンバリングしたファイル名を返すメソッドの改良

f:id:akashi_keirin:20190421091725j:plain

akashi-keirin.hatenablog.com

これの改良。

改良後のコード

前回は、イマイチFileSystemObjectを使いこなせていなかったので、FileSystemObjectの実力をもっと活用しようと思う。

リスト１　標準モジュール
Public Function getNameWithoutDuplication( _
            ByVal targetDirectoryPath As String, _
            ByVal targetFilename As String) As String  '……(1)'
  Dim fsObj As New FileSystemObject
  If Right(targetDirectoryPath, 1) <> "\" Then _
    targetDirectoryPath = targetDirectoryPath & "\"  '……(2)'
  '拡張子を取得'
  Dim nameExt As String  '……(3)'
  nameExt = fsObj.GetExtensionName( _
                    targetDirectoryPath & targetFilename)
  '拡張子を除いた名前を取得'
  Dim nameBase As String  '……(4)'
  nameBase = fsObj.GetBaseName( _
                     targetDirectoryPath & targetFilename)
  Dim n As Long
  n = 0
  Dim tmp As String
  tmp = targetDirectoryPath & nameBase
  '接尾辞を作成'
  Dim suffixStr As String
  Do While fsObj.FileExists(tmp & suffixStr & "." & nameExt)
    n = n + 1
    suffixStr = "(" & n & ")"
  Loop
  getNameWithoutDuplication = nameBase & suffixStr & "." & nameExt
  Set fsObj = Nothing
End Function

まず(1)の

Public Function getNameWithoutDuplication( _
            ByVal targetDirectoryPath As String, _
            ByVal targetFilename As String) As String

では、引数リストを変更した。

第１引数targetDirectoryPathで保存先のフォルダパスを受け取り、第２引数targetFileNameではシンプルにファイル名を受け取る。

前回のやつは、拡張子抜きのフルパスとか、拡張子名とか、取り出すのに特殊な操作が必要なデータを渡す必要があったので、使い勝手が悪かった。少なくとも、三日も経てば使い方を忘れる不親切なものだった。

(2)の

If Right(targetDirectoryPath, 1) <> "\" Then _
    targetDirectoryPath = targetDirectoryPath & "\"

で、フォルダパスの右端に「\」を付ける。場合によっては「\」付きで渡すこともあるかと思ったので、右端の文字を確認するようにした。

(3)からの３行（実質２行）

Dim nameExt As String
nameExt = fsObj.GetExtensionName( _
                  targetDirectoryPath & targetFilename)

及び、

(4)からの３行（実質２行）

Dim nameBase As String
nameBase = fsObj.GetBaseName( _
                   targetDirectoryPath & targetFilename)

では、それぞれFileSystemObjectオブジェクトのGetExtensionNameメソッド、GetBaseNameメソッドを用いて、対象ファイルの拡張子名と拡張子を除いたファイル名を取得している。

FileSystemObjectを使ったら、こんなに簡単に、しかも読みやすく書くことができる。

FileSystemObject、チョー便利じゃん！

後は前回同様、FileSystemObjectオブジェクトのFileExsistsメソッドで同名ファイルの有無を確認しながら接尾辞を作成。同名ファイルが存在しなくなるまで「()」（半角カッコ）内の数字をインクリメントさせる。

おわりに

FileSystemObjectオブジェクトのMoveFileメソッドでファイルを移動させるとき、移動先フォルダに同名のファイルが既にあるとエラーが出るので、MoveFileメソッドやCopyFileメソッドにファイル名を渡すときに、このメソッドをかましてやれば安心です。

追記

空腹おやじ (id:Z1000S) さんより、コメントに曰く、

getNameWithoutDuplication = nameBase & suffixStr & "." & nameExt

これだと拡張子のないファイルの場合、末尾に "." が・・・

と。

オ、オーマイガ!!!!!!!!

……というわけで、修正。

リスト２　標準モジュール
Public Function getNameWithoutDuplication( _
            ByVal targetDirectoryPath As String, _
            ByVal targetFilename As String) As String
  Dim fsObj As New FileSystemObject
  If Right(targetDirectoryPath, 1) <> "\" Then        '"
    targetDirectoryPath = targetDirectoryPath & "\"   '"
  End If
  '拡張子を取得'
  Dim nameExt As String
  nameExt = fsObj.GetExtensionName( _
                    targetDirectoryPath & targetFilename)
  '「.」（ドット）付きにする。拡張子無しなら空文字になる。'
  If nameExt <> "" Then nameExt = "." & nameExt    '……(*)'
  '拡張子を除いた名前を取得'
  Dim nameBase As String
  nameBase = fsObj.GetBaseName( _
                     targetDirectoryPath & targetFilename)
  Dim n As Long
  n = 0
  Dim tmp As String
  tmp = targetDirectoryPath & nameBase
  '接尾辞を作成'
  Dim suffixStr As String
  Do While fsObj.FileExists(tmp & suffixStr & nameExt)
    n = n + 1
    suffixStr = "(" & n & ")"
  Loop
  getNameWithoutDuplication = nameBase & suffixStr & nameExt
  Set fsObj = Nothing
End Function

拡張子を取得した直後に、変数nameExtの中身を「.」（ドット）付きにしてしまえば良いと考えた。拡張子なしのファイルだったら、GetExtensionNameメソッドの返り値が空文字になるので、そのときはnameExtの中身を空文字のままにしておけば良い。