【转载】国外VBA 调用PowerShell压缩和解压缩文件代码

时　间:2021-11-02 10:38:08
作　者:金宇   ID：43  城市：江阴
摘　要:VBA 调用PowerShell压缩和解压缩文件代码
正　文:

可以将下面的代码放在模块中，然后自己尝试压缩和解压缩文件。

'---------------------------------------------------------------------------------------
' Procedure : PS_Zip
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Zip up a file or folder
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Requires a copy of the PS_Execute() sub
' References: https://docs.microsoft.com/en-us/powershell/module/microsoft.powershell.archive/compress-archive?view=powershell-7.1
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sSrc              : The source file or folder to compress/zip
' sDest             : The output zip file (fully qualified path and filename)
' sCompressionLvl   : Compression level to be used
'                       NoCompression, Fastest or Optimal
'
' Usage:
' ~~~~~~
' Compress a single file
'   PS_Zip("C:\Temp\MonthlyStats.xlsx", "C:\Users\Dev\Desktop\MyZipFile.zip")
' Compress a whole folder
'   PS_Zip("C:\Temp\", "C:\Users\Dev\Desktop\MyFolder.zip")
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' **************************************************************************************
' 1         2021-10-12              Initial Release
'---------------------------------------------------------------------------------------
Public Sub PS_Zip(sSrc As String, _
                  sDest As String, _
                  Optional sCompressionLvl As String = "Optimal")
    On Error GoTo Error_Handler
    Dim sCmd                  As String
 
    sCmd = "Compress-Archive -LiteralPath '" & sSrc & "' -DestinationPath '" & sDest & _
           "' -CompressionLevel " & sCompressionLvl
    Call PS_Execute(sCmd)
 
Error_Handler_Exit:
    On Error Resume Next
    Exit Sub
 
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: PS_Zip" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Sub

'---------------------------------------------------------------------------------------
' Procedure : PS_UnZip
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Unzip a file
' Copyright : The following is release as Attribution-ShareAlike 4.0 International
'             (CC BY-SA 4.0) - https://creativecommons.org/licenses/by-sa/4.0/
' Req'd Refs: Requires a copy of the PS_Execute() function
' References: https://docs.microsoft.com/en-us/powershell/module/microsoft.powershell.archive/expand-archive?view=powershell-7.1
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sSrc      : Zip file to unzip/expand
' sDest     : Folder where it should be to extracted to
'
' Usage:
' ~~~~~~
' Call PS_UnZip("c:\temp\testing.zip", "c:\temp\exports")
'
' Revision History:
' Rev       Date(yyyy-mm-dd)        Description
' **************************************************************************************
' 1         2021-10-12              Initial Release
'---------------------------------------------------------------------------------------
Public Sub PS_UnZip(sSrc As String, sDest As String)
On Error GoTo Error_Handler
    Dim sCmd                  As String
 
    sCmd = "Expand-Archive -LiteralPath '" & sSrc & "' -DestinationPath '" & sDest & "'"
    Call PS_Execute(sCmd)
 
Error_Handler_Exit:
    On Error Resume Next
    Exit Sub
 
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: PS_UnZip" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Sub

'---------------------------------------------------------------------------------------
' Procedure : PS_Execute
Public Sub PS_Execute(ByVal sPSCmd As String)
    'Setup the powershell command properly
    sPSCmd = "powershell -command " & sPSCmd
    'Execute and capture the returned value
    CreateObject("WScript.Shell").Exec (sPSCmd)
End Sub