[VBA][VBS]Robocopyでフォルダをコピーして、もとのフォルダにショートカットを残し、更新日付を合わせる

フロー

フォルダーSからフォルダーDにファイルをロボコピーします。
このとき、ファイルの日付はキープされます。
次にフォルダーDにフォルダーSにコピーしたファイルのショートカットをつくります。
しかし、これだけでは更新日付は作成日でファイルの日付は反映していません。
このため、Shellを使い更新日付はコピーしたファイルと同じにします。
しかし、作成日付や最終アクセス日はVBAでは容易ではないので、ここではそれはやりません。

Point

フォルダ名の末尾には¥つけないようにしてください。
スペースが入ることを想定して、ダブルクォーテーションを追加しています。
スペースが入らないと少なくてすみます。
ShellアプリケーションのNameSpaceはフォルダで、Parsenameはファイル名になります。
しかし、これは、実は一度に指定できることがわかりました。
NameSpaceは名前空間という名前ですが、これは単に大きい集合だと思ってください。
フォルダはファイル（とサブフォルダー）の集合と捉えられます。
さらにフォルダとファイルの集合がドライブです。
なのでNameSpaceはフォルダのことを指します。
NameSpaceはいろいろな意味がありますが、すべて何らかの集合です。

VBA

Option Explicit
Sub test()
' VBA 版
Const SourceFolder = "C:\BackUp2\testdir1"
Const DistinyFolder = "D:\BackUp2\testdir2"
Const TgFile = "t est - コピー.txt"
Const blDeleteOption = False
' Dim WSH As New IWshRuntimeLibrary.WshShell
Dim WSH : Set WSH = CreateObject("WScript.Shell")
' Dim FSO As New Scripting.FileSystemObject: 
Dim FSO : Set FSO = CreateObject("Scripting.FileSystemObject")
' Dim SHELL As New Shell32.SHELL
Dim SHELL  : Set SHELL = CreateObject("SHELL.Application")
Dim sFile 'As File
Dim dFile ' As File
Dim sFolder 'As Folder
Dim cmdStr 'As String
Dim buf 'As String
Dim Sht
' 指定したファイルがなければ終了　あればsfile
If FSO.FileExists(FSO.BuildPath(SourceFolder, TgFile)) Then Set sFile = FSO.GetFile(FSO.BuildPath(SourceFolder, TgFile)) Else Exit Sub
' Robocopy
WSH.Run "cmd /c (%windir%\system32\robocopy.exe """ & SourceFolder & """ """ & DistinyFolder & """ """ & TgFile & """  /DCOPY:DAT /COPY:DAT /W:0 /R:0 /J)", 0, True: DoEvents

' Fileができていたら

If FSO.FileExists(FSO.BuildPath(DistinyFolder, TgFile)) Then
Set dFile = FSO.GetFile(FSO.BuildPath(DistinyFolder, TgFile))
If FSO.FileExists(FSO.BuildPath(SourceFolder, FSO.GetBaseName(sFile) & ".lnk")) = True Then FSO.DeleteFile (FSO.BuildPath(SourceFolder, FSO.GetBaseName(sFile) & ".lnk"))
Set Sht = WSH.CreateShortcut(FSO.BuildPath(SourceFolder, FSO.GetBaseName(sFile) & ".lnk"))
With Sht
.TargetPath = dFile.Path
.Save
End With
Set Sht = Nothing
Set Sht = SHELL.Namespace(SourceFolder).ParseName(FSO.GetBaseName(sFile) & ".lnk")
Sht.ModifyDate = FSO.GetFile(sFile).DateLastModified
' DeleteOptionがTrueなら削除
If blDeleteOption = True Then
FSO.DeleteFile (sFile.Path)
End If
Else
Exit Sub
End If
End Sub

VBS

Option Explicit

Const SourceFolder = "G:\BackUp2\testdir1"
Const DistinyFolder = "G:\BackUp2\testdir2"
Const TgFile = "t est - コピー.txt"
Const blDeleteOption = False
' Dim WSH As New IWshRuntimeLibrary.WshShell
Dim WSH : Set WSH = CreateObject("WScript.Shell")
' Dim FSO As New Scripting.FileSystemObject: 
Dim FSO : Set FSO = CreateObject("Scripting.FileSystemObject")
' Dim SHELL As New Shell32.SHELL
Dim SHELL  : Set SHELL = CreateObject("SHELL.Application")
Dim sFile 'As File
Dim dFile ' As File
Dim sFolder 'As Folder
Dim cmdStr 'As String
Dim buf 'As String
Dim Sht
' 指定したファイルがなければ終了　あればsfile
If FSO.FileExists(FSO.BuildPath(SourceFolder, TgFile)) Then Set sFile = FSO.GetFile(FSO.BuildPath(SourceFolder, TgFile)) 
Else
Set FSO = Nothing
Set WSH = Nothing
Set SHELL = Nothing
WScript.Quit
End If
' Robocopy
WSH.Run "cmd /c (%windir%\system32\robocopy.exe """ & SourceFolder & """ """ & DistinyFolder & """ """ & TgFile & """  /DCOPY:DAT /COPY:DAT /W:0 /R:0 /J)", 0, True: DoEvents
' Fileができていたら

If FSO.FileExists(FSO.BuildPath(DistinyFolder, TgFile)) Then
Set dFile = FSO.GetFile(FSO.BuildPath(DistinyFolder, TgFile))
If FSO.FileExists(FSO.BuildPath(SourceFolder, FSO.GetBaseName(sFile) & ".lnk")) = True Then FSO.DeleteFile (FSO.BuildPath(SourceFolder, FSO.GetBaseName(sFile) & ".lnk"))
Set Sht = WSH.CreateShortcut(FSO.BuildPath(SourceFolder, FSO.GetBaseName(sFile) & ".lnk"))
With Sht
.TargetPath = dFile.Path
.Save
End With
Set Sht = Nothing
Set Sht = SHELL.Namespace(SourceFolder).ParseName(FSO.GetBaseName(sFile) & ".lnk")
Sht.ModifyDate = FSO.GetFile(sFile).DateLastModified
' DeleteOptionがTrueなら削除
If blDeleteOption = True Then
FSO.DeleteFile (sFile.Path)
End If
Set FSO = Nothing
Set WSH = Nothing
Set SHELL = Nothing
WScript.Quit
Else
Set FSO = Nothing
Set WSH = Nothing
Set SHELL = Nothing
WScript.Quit
End If
End Sub