如何在没有任何第三方软件的WindowsXP中使用VBA创建.zip文件？ [英] How to create a .zip file with VBA in WindowsXP without any third party software?

问题描述

WindowsXP可以打开并创建一个压缩文件。

如何在VBA中压缩和解压缩文件？

谢谢你的帮助帮助。

解决方案

您好，iopcj。

我有一个用于压缩活动工作簿的vba代码。

但我不知道如何解压缩它。代码不是我的工作。

代码使用Windows Shell作为核心工作。

HTH。

--- -------------------------------------------------- ---------------------

Sub zip_activeworkbook（）
Dim strDate As String，DefPath As String
Dim FileNameZip，FileNameXls
Dim oApp As Object

如果ActiveWorkbook什么都没有那么退出Sub
DefPath = ActiveWorkbook.Path
如果Len（DefPath）= 0那么
msgbox" Plz在压缩之前保存活动工作簿&安培;空格（12），vbInformation，"压缩"





如果正确（DefPath，1）<> " \"那么
DefPath = DefPath& " \"
End If

'创建日期/时间字符串和临时xls和zip文件名
strDate =格式（现在，"dd-mmm-yy h-mm -ss"）
FileNameZip = DefPath&左（ActiveWorkbook.Name，Len（ActiveWorkbook.Name） - 4）& strDate& " .zip"
FileNameXls = DefPath&左（ActiveWorkbook.Name，Len（ActiveWorkbook.Name） - 4）& strDate& " .xls"

如果Dir（FileNameZip）=""和Dir（FileNameXls）=""然后

'制作activeworkbook的副本
ActiveWorkbook.SaveCopyAs FileNameXls

'创建空的Zip文件
newzip（FileNameZip）

'复制文件在压缩文件夹
设置oApp = CreateObject（" Shell.Application"）
oApp.Namespace（FileNameZip）.CopyHere FileNameXls

'保持脚本等待直到压缩完成

On Error Resume Next
Do Until oApp.Namespace（FileNameZip）.items.Count = 1
Application.Wait（Now + TimeValue（&0：00：01"））

循环
错误GoTo 0 < br>
'删除临时xls文件
杀死FileNameXls

msgbox"完成压缩：" &安培; vbNewLine& FileNameZip，vbInformation，" zipping"





msgbox" FileNameZip或/和FileNameXls存在"，vbInformation，" zipping"

结束如果
End Sub

Private Sub newzip（sPath）
'创建空Zip文件
'由keepITcool改变Dec-12-2005
如果Len（Dir（sPath）） ）> 0然后杀死sPath
打开sPath输出为＃1
打印＃1，Chr

（80）& Chr

（75）&字符

WindowsXP can open and create a zipped file.

How to zip and unzip a file in VBA?

Thanks for ur help.

解决方案

Hello, iopcj.

I have a vba code that zips active workbook.   

but I don't know how to unzip it. the code is not my work. 

the code uses Windows Shell that is the core to work.

HTH.

--------------------------------------------------------------------------

Sub zip_activeworkbook()
    Dim strDate As String, DefPath As String
    Dim FileNameZip, FileNameXls
    Dim oApp As Object
 
    If ActiveWorkbook Is Nothing Then Exit Sub
    DefPath = ActiveWorkbook.Path
    If Len(DefPath) = 0 Then
        msgbox "Plz Save activeworkbook before zipping" & Space(12), vbInformation, "zipping"
        Exit Sub
    End If
   
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If
 
    'Create date/time string and the temporary xls and zip file name
    strDate = Format(Now, " dd-mmm-yy h-mm-ss")
    FileNameZip = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".zip"
    FileNameXls = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".xls"
 
    If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then
 
        'Make copy of the activeworkbook
        ActiveWorkbook.SaveCopyAs FileNameXls
 
        'Create empty Zip File
        newzip (FileNameZip)
 
        'Copy the file in the compressed folder
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameZip).CopyHere FileNameXls
 
        'Keep script waiting until Compressing is done
        On Error Resume Next
        Do Until oApp.Namespace(FileNameZip).items.Count = 1
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop
        On Error GoTo 0
 
        'Delete the temporary xls file
        Kill FileNameXls
 
        msgbox "completed zipped : " & vbNewLine & FileNameZip, vbInformation, "zipping"
 
    Else
        msgbox "FileNameZip or/and FileNameXls exist", vbInformation, "zipping"

    End If
End Sub

Private Sub newzip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr

(80) & Chr

(75) & Chr

这篇关于如何在没有任何第三方软件的WindowsXP中使用VBA创建.zip文件？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！