VBA：【PowerShell】zip形式でのフォルダorファイルの圧縮方法
VBAでzip形式に圧縮して保存する方法についてのサンプルコードです。
圧縮する対象がフォルダの場合とファイルの場合があると思うので、どちらでも動作するようにしました。
ダイアログを使って、圧縮対象を選んで、保存先を指定するようにした方がツールとしての使い勝手はよくなるかと思います。
◆zipでフォルダorファイルを圧縮して保存するサンプルコード
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
Sub Main_zip圧縮() Dim zipTargetPath As String Dim zipSavePath As String Dim psCommand As String Dim WSH As Object Dim zipResult As Integer Dim zipFolderName As String '//zipで圧縮するフォルダor ファイル。パスをファイル名と拡張子を記載すればファイルを圧縮します。' zipTargetPath = "C:\Users\zip圧縮解凍\圧縮用" '//対象がファイルならこんな感じ' 'zipTargetPath = "C:\Users\zip圧縮解凍\圧縮用\test.xlsx"' '//圧縮するフォルダ名orファイル名を取得' zipFolderName = getLastPathName(zipTargetPath) '//圧縮したzipファイルの保存先' zipSavePath = "C:\Users\zip圧縮解凍\" & zipFolderName '" '//実行するPowerShellのコマンド作成。「 -Force」で上書き。' psCommand = "powershell -NoLogo -ExecutionPolicy RemoteSigned -Command Compress-Archive -Path " & zipTargetPath & " -DestinationPath " & zipSavePath & " -Force" Set WSH = CreateObject("WScript.Shell") '//PowerShellのコマンド実行' '「zipSavePath」で指定した場所に圧縮されます。' zipResult = WSH.Run(Command:=psCommand, WindowStyle:=0, WaitOnReturn:=True) Set WSH = Nothing MsgBox "完了" End Sub '*********************************************************' '//パスの一番最後のフォルダ名orファイル名取得' Function getLastPathName(ByVal zipTargetPath As String) As String Dim FNameArray As Variant Dim lastPathName As String Dim getFileName As String Dim rightPoint As Long Dim chk As Long chk = GetAttr(zipTargetPath) FNameArray = Split(zipTargetPath, "\") '" lastPathName = FNameArray(UBound(FNameArray)) If chk = 16 Then getLastPathName = lastPathName Else '文字列の右端から"."を検索し、左端からの位置を取得する' rightPoint = InStrRev(lastPathName, ".") '拡張子を除いたファイル名の取得' getFileName = Left(lastPathName, rightPoint - 1) getLastPathName = getFileName End If End Function |
