フォルダコピーとファイルの移動　～ ⑥ 移動したファイルの圧縮～

先日は、フォルダの移動中に中断処理を追加してみた。
infoment.hatenablog.com
今日も、昨日の続きから。

リクエストの最後の条件は、以下のとおり。

移動先で、ファイルを圧縮したい。
圧縮は、ファイル単位で行いたい。
圧縮後、圧縮前ファイルは削除したい。

そこでまず、圧縮する関数を作成してみた。作成に際しては、こちらのサイトを
丸々参考にさせていただいた。ありがとうございます。
vbabeginner.net

Function Zip(source_path As String, _
             destination_path As String, _
    Optional source_del_flag As Boolean = True) As Boolean
    
    ' 参照設定：Windows Script Host Object Model
    Dim WshShell As IWshRuntimeLibrary.WshShell
    Set WshShell = New IWshRuntimeLibrary.WshShell
    Dim WshExec As IWshRuntimeLibrary.WshExec
    Dim Cmd As String
    
        ' 元データ（フォルダまたはファイル）の存在確認。
        If Not FSO.FileExists(source_path) And _
           Not FSO.FolderExists(source_path) Then
            Exit Function
        ' スペースがある場合も圧縮不可。
        ElseIf InStr(source_path, " ") <> 0 Then
            Exit Function
        End If
        
        ' 圧縮用コマンド作成。既に存在する場合は上書きする（-Force）。
        Cmd = "Compress-Archive -Path " & source_path & _
              " -DestinationPath " & destination_path & " -Force"
    
    ' 圧縮実行。
    Set WshExec = WshShell.Exec( _
        "powershell -NoLogo -ExecutionPolicy RemoteSigned -Command " & Cmd)
    
        ' 圧縮失敗。
        If WshExec.Status = WshFailed Then Exit Function
    
        ' 圧縮完了まで待機。
        Do While WshExec.Status = WshRunning
            DoEvents
        Loop
        
        ' 圧縮前のデータを削除。
        If source_del_flag Then
            Kill source_path
        End If
    
        Zip = True
End Function

圧縮は、あとで無くしたくなるかもしれない。そこで一旦移動ののち、
圧縮する別のサブプロシージャを実行することとした。

Sub ZipAndSourceDelete()
    ' 記録用テーブル。
    Dim Tb As ListObject
    Set Tb = LogSheet.ListObjects(1)
    
    ' 移動元パス配列。
    Dim SrcArray As Variant
        SrcArray = Tb.ListColumns("移動先パス").DataBodyRange
    
    ' 備考出力先。
    Dim NoteArray As Variant
        NoteArray = Tb.ListColumns("備考").DataBodyRange
    
    Dim i As Long
    Dim TempArray As Variant
    Dim DestinationPath As String
        For i = 1 To UBound(SrcArray)
            ' ファイルの存在確認。
            If Not FSO.FileExists(SrcArray(i, 1)) Then
            ' 既に圧縮されているか否かの確認。
            ElseIf StrConv(Right(SrcArray(i, 1), 4), _
                           vbNarrow + vbLowerCase) = ".zip" Then
            Else
                ' 拡張子を除去するため、一旦"."で分割。
                TempArray = Split(SrcArray(i, 1), ".")
                ' 分割結果の要素数を一つ減らすことで、拡張子を除去。
                ReDim Preserve TempArray(UBound(TempArray) - 1)
                ' "."で結合して末尾に".zip"を追加し、圧縮後バスを作成。
                DestinationPath = Join(TempArray, ".") & ".zip"
                
                If Zip(CStr(SrcArray(i, 1)), DestinationPath) Then
                    '圧縮が成功したならば、圧縮後のパスに置き換える。
                    SrcArray(i, 1) = DestinationPath
                    NoteArray(i, 1) = "圧縮成功"
                Else
                    NoteArray(i, 1) = "圧縮失敗"
                End If
            End If
        Next
        
        ' 結果の出力。
        Tb.ListColumns("移動先パス").DataBodyRange = SrcArray
        Tb.ListColumns("備考").DataBodyRange = NoteArray
End Sub

昨日作成した「cbDoMove」ボタンは、「Do」は要らないかなと思い
「cbMove」に名前を変更した。そのうえで、圧縮処理を追加したのが
こちら。

Private Sub cbMove_Click()
    Dim SpecifiedDate As Variant
        SpecifiedDate = InputBox("基準日を入力してください。", _
                                 "基準日入力", Date)
        If Not IsDate(SpecifiedDate) Then
            MsgBox "日付以外が入力されたため、処理を中断します。"
            Exit Sub
        End If
        
        ' 中断用フラグ初期化。
        StopFlag = False
    
    ' フォルダの移動。
    Call MoveFolders(CDate(SpecifiedDate))
    ' 圧縮と削除。
    Call ZipAndSourceDelete
End Sub