人気ブログランキング | 話題のタグを見る

[VBScript] 処理ダイアログを表示したコピー・移動処理を実現する

どーもボキです。

FileSystemObjectオブジェクトのCopyFileやMoveFileは、処理ダイアログが表示されず、
処理に時間のかかる大容量ファイルで処理が止まったようになる。

Shell ApplicationオブジェクトのCopyHereやMoveHereは、処理ダイアログは表示されるものの、
ファイル名のリネームを兼ねたコピー・移動処理ができない。

今回紹介するCopyFileやMoveFileは、処理ダイアログを表示させつつ、
コピー先・移動先でのファイル名をも指定できる関数となっている。
[VBScript] 処理ダイアログを表示したコピー・移動処理を実現する_a0021757_15033832.png

ForceDirectories(指定フォルダを階層ごと作成する関数)を利用するので、
処理先フォルダが存在しない場合は、階層ごと作成される。


::::Doは、::::Loop Unitl 1と組わせて、Gotoステートメントとして利用してみた。
「:」は複数行の構文を一行にまとめるための記号。Gotoを明示するためインデント分だけつけている。

Gotoは、終了処理を一か所に集約するときには積極的に使えばよいと思っている。
これにより、Ifでのネストを増やすよりも、コードの視認性が格段に増す。

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

by yozda | 2019-09-16 13:20 | プログラミング | Comments(0)