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
