[VBScript] 処理ダイアログを表示したコピー・移動処理を実現する
2019年 09月 16日
fpth_f = "C:\test.dat"
fpth_t = "D:\1\2\3\4\test.dat"
Msgbox CopyFile(fpth_f, fpth_t)
'================================================================================
'-------------------------------------------------------------------------------
' ファイルを別の場所へコピーする(ダイアログ付き)
'-------------------------------------------------------------------------------
Function CopyFile(FPath_From, Path_To)
CopyFile = procFile_Mode(FPath_From, Path_To, 0)
End Function
'-------------------------------------------------------------------------------
' ファイルを別の場所へ移動する(ダイアログ付き)
'-------------------------------------------------------------------------------
Function MoveFile(FPath_From, Path_To)
MoveFile = procFile_Mode(FPath_From, Path_To, 1)
End Function
'-------------------------------------------------------------------------------
' ファイルをコピー・移動する(ダイアログ付き)
'-------------------------------------------------------------------------------
Private Function procFile_Mode(FPath_From, Path_To, cProcMode)
::::Do
Dim objFS: Set objFS = CreateObject("Scripting.FileSystemObject")
If (InStr(FPath_From,"*") = 0) And (Not objFS.FileExists(FPath_From)) Then Err=1: Err.Description="コピー元ファイルがない": Exit Do
' コピー先フォルダの準備
Dim dpth_t
If Right(Path_To,1) = "\" Then
dpth_t = Path_To
Else
dpth_t = IncludeTrailingPathDelimiter(objFS.GetParentFolderName(Path_To))
End If
If Not ForceDirectories(dpth_t) Then Err=2: Err.Description="コピー先フォルダがない": Exit Do
' コピー元ファイルの準備
Dim fpth_f: fpth_f = FPath_From
Dim fname_t: fname_t = objFS.GetFileName(FPath_From)
Dim b_name: b_name = (InStr(FPath_From,"*") = 0) And (Right(Path_To,1) <> "\")
If b_name Then
' ファイル名を一時的に変更する
fname_t = objFS.GetFileName(Path_To)
Dim fname_f: fname_f = objFS.GetFileName(FPath_From)
Dim fname_0: fname_0 = Year(Now) & Month(Now) & Day(Now) & Hour(Now) & Minute(Now) & Second(Now)
Dim f
Set f = objFS.GetFile(FPath_From)
f.Name = fname_0
fpth_f = f.Path
End If
' ファイルの処理
Dim objSA: Set objSA = CreateObject("Shell.Application")
Dim objFolder: Set objFolder = objSA.NameSpace(dpth_t)
If cProcMode = 0 Then
objFolder.CopyHere fpth_f, &H10 ' 上書き ※FPath_Fromでワイルドカードを指定した際、上書き確認は回避できない
Else
objFolder.MoveHere fpth_f, &H10
End If
' 指定のファイル名に戻す
If b_name Then
f.Name = fname_f
If cProcMode = 0 Then
If Not objFS.FileExists(dpth_t & fname_0) Then Err=3: Err.Description="ファイル処理キャンセル": Exit Do
If objFS.FileExists(dpth_t & fname_t) Then objFS.DeleteFile dpth_t & fname_t, True
Set f = objFS.GetFile(dpth_t & fname_0)
f.Name = fname_t
End If
End If
If (InStr(FPath_From,"*") = 0) And (Not objFS.FileExists(dpth_t & fname_t)) Then Err=3: Err.Description="ファイル処理キャンセル": Exit Do
::::Loop Until 1
procFile_Mode = (Err=0)
End Function
'-------------------------------------------------------------------------------
' 指定ディレクトリパスを全階層作成する
'-------------------------------------------------------------------------------
Function ForceDirectories(DirectoryPath)
Dim r: r = False
::::Do
If DirectoryPath = "" Then Exit Do
Dim objFS: Set objFS = CreateObject("Scripting.FileSystemObject")
r = objFS.FolderExists(DirectoryPath)
If r Then Exit Do
Dim i,dname,dpth
dpth = Replace(DirectoryPath,"\\","//")
dname = Split(dpth, "\", -1, vbTextCompare)
dpth = dname(0)
On Error Resume Next
For i = 1 to Ubound(dname)
dpth = dpth + "\" + dname(i)
If Not objFS.FolderExists(dpth) Then objFS.CreateFolder(dpth)
Next
On Error GoTo 0
r = objFS.FolderExists(DirectoryPath)
::::Loop Until 1
ForceDirectories = r
End Function