VBAでファイルパスが長すぎてコピー時のエラー対策

フォルダ内にあるファイル（xlsx）を１つのファイルごとに分類したいため、
そのファイル名と同名のフォルダを元のフォルダ内に新たに作成し、そこに保存したいという
下記のマクロを見つけて動かしてみたのですが、

FileCopy FPath & "\" & TargetFile, FPath & "\" & DName 　& "\" & TargetFile
の箇所でファイルが存在しないと出ました。

色々と調べた結果、サーバーの中にあるファイルを作ろうとしているのですが
サーバーの階層が深く取得するパス名が300文字になっていたので
Dir関数だとエラーになることが判明し、対策として
ショートパスへ変換する方法やFSOを使って行えば解決するという所までは
調べたのですが、上手くいきません。

分かる方がいればアドバイスを頂ければと思い質問をさせて頂きました。
宜しくお願い致します。




Sub フォルダ作成()
　　Dim FPath, TargetFile, DName

　　FPath = Range("A1").Value
'セルのA1にサーバーのパスを記載しています

\\TEST\TESTファイル\管理項目\管理簿\各担当部署\確認事項\
上記の記載は例ですが本来の記載はかなり長く、260文字くらいあります。

　　If FPath = "" Then Exit Sub
　　TargetFile = Dir$(FPath & "\*.xlsx")
　　Do While TargetFile <> ""
　　　DName = Left(TargetFile, InStrRev(TargetFile, ".") - 1)

　　　MkDir FPath & "\" & DName
ファイル名と同名のフォルダをサーバーに作成するのは成功しています。

　　　FileCopy FPath & "\" & TargetFile, FPath & "\" & DName _
　　　　　　& "\" & TargetFile
上記の部分でエラーが出ており、パス名が長いためエラーになっています。


　　　Kill FPath & "\" & TargetFile
　　　TargetFile = Dir$
　　Loop

　End Sub


Dim fso As New FileSystemObject
ファイルオブジェクトを使い、ショートパスにすればという
所までは調べたのですが、そこからどう繋げていいか不明なので
お手数ですがご教授願えないでしょうか？

No.1 ベストアンサー 回答者： WindFaller 回答日時： 2017/05/17 10:58

このご質問の回答としては、私は、以下のコードを提示しますが、何か別の方法があったような気がしてなりません。

Function shortName(ByVal FileName As String)
'ショートネイム用のユーザー定義関数
　Dim objFS As Object
　Dim objFile As Object
　Set objFS = CreateObject("Scripting.FileSystemObject")
　If Right(FileName, 1) <> "\" Then　'フォルダーとファイルの区分け
　　Set objFile = objFS.GetFile(FileName)
　Else
　　Set objFile = objFS.GetFolder(FileName)
　End If
　shortName = objFile.shortPath
End Function

使用例：
Sub TestLongFileName()
　Dim fn As String

　Dim dst As String
　fn = "---long Name file ----"
　fn = shortName(fn)
　If Dir(fn) = "" Then
　　MsgBox "ファイルが見つかりません", vbCritical
　　Exit Sub
　End If

　dst = ""---long Name Path ----"" '末尾に￥を入れないとエラーが出ます。
　dst = shortName(dst)
FileCopy fn, dst
'　'　Shell ("cmd.exe /c Copy " & fn & " " & dst)
End Sub

この回答へのお礼

返答ありがとうございます。
元のマクロと組み込んでショートネイム用のユーザー定義関数を使い
ファイルのパスを取得することは出来ました。

細かい所の調整は行って色々と試したいと思います。
アドバイスありがとうございました。

お礼日時：2017/05/17 19:19