压缩来自不同文件夹的文件，保留目录结构

Posted 2023-03-06

【中文标题】压缩来自不同文件夹的文件，保留目录结构

【英文标题】：Zipping files from different folders preserving the directory structure

【发布时间】：2013-10-16 21:53:23

【问题描述】：

我已经编写了一些非常有趣的代码来压缩多个文件和文件夹。

脚本将获取参数列表（文件和文件夹）并将它们压缩到以日期/时间为名称的 zip。

所以我需要一些在参数是文件时执行的代码。代码应将文件的目录结构添加到 zip 文件中。

'=================== THE SCRIPT =====================================

'Get command-line arguments.
Set objArgs = WScript.Arguments
Set objShell = CreateObject("Shell.Application")
'
'C:\DateYYYY-MM-DD_TimeHH-MM-SS.zip
ZipFile = "C:\DateYYYY-MM-DD_TimeHH-MM-SS.zip"
'Create empty ZIP file.
CreateObject("Scripting.FileSystemObject").CreateTextFile(ZipFile, True).Write "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
Set zip = objShell.NameSpace(ZipFile)
'
for i = 0 To objArgs.Count-1  
    On Error Resume Next
    IF fnFileExists( objArgs(i) ) OR (NOT fnFolderIsEmpty( objArgs(i) )) THEN 
        'WScript.Echo "Copying - " & objArgs(i)
        IF fnFileExists( objArgs(i) ) THEN
          '??? Code/Function/CopyHere[option] to create a directory structure in zip and copy objArgs(i) file into it
        End If
        zip.CopyHere( objArgs(i) )
    Else 
        WScript.Echo "Empty or !Exist - " & objArgs(i)
    End If
    Do 
        wScript.Sleep 200 
    Loop Until objShell.NameSpace(zip).Items.Count >= i 
Next
WScript.Echo "THE END"

fnFileExists() 函数仅在文件存在时返回 TRUE（如果文件夹或文件不存在，则返回FALSE。

如果文件夹为空或不存在，fnFolderIsEmpty() 函数将返回 TRUE。

给一个这样的电话：

"wscript zip.vbs "c:\Folder1\" "c:\Folder2\Sub2-1\" "c:\Windows\System32\TestFile0.txt"

文件夹是这样的：

\Folder1\
└──TestFile1.txt
└──TestFile2.txt
\Folder2\
└──\Sub2-1\
    └──TestFile3.txt
    └──TestFile4.txt
\Windows\
└──\System32\
    └──TestFile0.txt
└──\Sub3-2\
    └──TestFoo.txt

我得到一个结构如下的 zip 文件：

\Folder1\
└──TestFile1.txt
└──TestFile2.txt
\Sub2-1\
└──TestFile3.txt
└──TestFile4.txt
\TestFile0.txt

这就是我想要的样子：

\Folder1\
└──TestFile1.txt
└──TestFile2.txt
\Folder2\
└──\Sub2-1\
    └──TestFile3.txt
    └──TestFile4.txt
\Windows\
└──\System32\
    └──TestFile0.txt

我确实找到了以下内容，但我不知道 Java 如何/是否转换为 VBScript：

java.util.zip - Recreating directory structure -AND-Zipping files preserving the directory structure

【问题讨论】：

@Ansgar_Wiechers - 感谢您的编辑输入。

【参考方案1】：

好的，就是这样。 对于每个单独的文件，我将它放在一个临时文件夹（“C:\xxMisc”）中，在临时文件夹下创建完整路径。然后我压缩临时文件夹中的所有文件夹。非常适合我的目的。

例如如果我需要压缩“c:\windows\system32\bob.dll” 我会创建一个路径\文件 "c:\xxMisc\windows\system32\" 并将 bob.dll 复制到其中。 然后拨打：zip.MoveHere( "c:\xxMisc\Windows" );

结果是 zip 文件将有一个“\windows\”目录，其中包含所有子目录（和文件）。

用法： wscript <script.vbs> [/x] <FullPath[FileName]> [] 参数是可选的。通配符不起作用。以“\”结束完整路径。 "/x" 将打开一个 IE 调试窗口。wscript script.vbs /X "C:\My Path\" "c:\windows\system32\bob.dll"结果： "c:\" 处的 zip 文件将包含整个目录 "c: \My Path\"（包括文件和子目录）和 bob.dll 在“\windows\system32\”目录路径中。

这是代码。

IF WScript.Arguments.Count = 0 THEN
    WSCript.Quit
END IF

Dim objIEDebugWindow
sTempFolderName = "C:\xxMisc"   'Where individual files go
iBeforeCopy = 0                 'Value to detect when a move/copy is complete
bDebug = FALSE                  'Debug Flag
i = 0                           'Index through the objArgs()

'Get command-line arguments.
Set objArgs = wScript.Arguments
'General objects
Set objShell = CreateObject("Shell.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")

'Detect Debug Command Line Argument | MUST be FIRST Argument
IF UCase( objArgs( 0 ) ) = "/X" THEN
    bDebug = TRUE
    i = 1                   'Change Which Index objArgs() to start looking for files/folders
END IF

'Test to see if Windows Script Host is >= 2.0
fnCheckWSHversion( 2000 )

'Create empty ZIP file.
'C:\DateYYYY-MM-DD_TimeHH-MM-SS.zip
ZipFile = "C:\Date" & Year(Date) & "-" & Right("0" & Month(Date),2) & "-" & Right("0" & Day(Date),2) & "_Time" & Right("0" & Hour(now), 2) & "-" & Right("0" & Minute(now), 2) & "-" & Right("0" & Second(now), 2) & ".zip"
CreateObject("Scripting.FileSystemObject").CreateTextFile(ZipFile, True).Write "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
Set zip = objShell.NameSpace(ZipFile)

CALL Debug ( objArgs.Count )

'Iterate through the command line arguments
for i = i To objArgs.Count-1
    CALL Debug( "Processing objArgs = " & i & "| " & objArgs(i) )
    IF FileExists( objArgs(i) ) OR (NOT fnFolderIsEmpty( objArgs(i) )) THEN 
        IF FileExists( objArgs(i) ) THEN
            'IT'S A FILE
            CALL Debug( "Copying File - " & objArgs(i) )
            CALL fnMakeTempFile( sTempFolderName, objArgs( i ) )
        Else 'IT'S A FOLDER
            CALL Debug( "Copying Folder - " & objArgs(i) )
            iBeforeCopy = objShell.NameSpace(zip).Items.Count
            zip.CopyHere( objArgs(i) )
            'Wait until copy is done (Items.Count goes up)
            Do 
                wScript.Sleep 200 
            Loop Until objShell.NameSpace(zip).Items.Count > iBeforeCopy
        End If
    Else
        CALL Debug( "Empty or !Exist - " & objArgs(i) )
    End If
Next

IF (NOT fnFolderIsEmpty( "c:\xxMisc" )) THEN     'Just in case no FILES were backed up
    'Get ArrayList of Temp Folders
    Set arrDirs = fnListDirIn( "c:\xxMisc" )
    CALL Debug( "Copying sTempFolder" )
    For Each sFolderName in arrDirs
        CALL Debug( "sFolderName=" & sFolderName )
        iBeforeCopy = objShell.NameSpace(zip).Items.Count
        zip.MoveHere( sFolderName )
        'Wait until copy is done (Items.Count goes up)
        Do 
            wScript.Sleep 200 
        Loop Until objShell.NameSpace(zip).Items.Count > iBeforeCopy
    Next

    CALL Debug( "COPY DONE!" )

    CALL Debug( "Deleting sTempFolderName = " & sTempFolderName )
    objFSO.DeleteFolder sTempFolderName, TRUE
    'Wait until folder is finished deleting; because MoveHere doesn't MOVE
    While objFSO.FolderExists( sTempFolderName )
        wScript.Sleep 200
    Wend
END IF

CALL Debug( "THE END" )
CALL MsgBox( "Backup Complete", vbOKOnly+vbInformation, "My Backup" )
Set objArgs = Nothing
Set objShell = Nothing
Set objFSO = Nothing
Set zip = Nothing
wScript.Quit
' ----------------------------------------------
'END MAIN
' ----------------------------------------------


' ----------------------------------------------
'Copies sFileName into a temporary directory specified by sTempFolder
' e.g.:
'  sTempFolder = "C:\Temp\"
'  sFileName = "c:\Windows\System32\bob.ocx"
'  results is the creation of "C:\Temp\Windows\System32\bob.ocx"
'-Uses fnCreatePath()
'-No Return
Function fnMakeTempFile( ByVal sTempFolder, sFileName )
    IF Right( sTempFolder, 1 ) <> "\" THEN
        sTempFolder = sTempFolder & "\"
    End If
    Set objFile = objFSO.GetFile( sFileName )
    FilePath = objFSO.GetParentFolderName( objFile )
    FilePath = sTempFolder & Mid(FilePath, 4)
    fnCreatePath( FilePath )
    CALL Debug( "FILECOPY = "& objFile.Name &" -> FilePath = " & FilePath )
    objFile.Copy( FilePath & "\" & objFile.Name )
    While NOT objFSO.FileExists( FilePath & "\" & objFile.Name )
        wScript.Sleep 200
        CALL Debug( "FileCopy Waiting" )
    Wend 
    CALL Debug( "Temp FileCopy Completed" )
    Set objFile = Nothing
End Function

' ----------------------------------------------
'Recursively creates a folder path
'Based on script from:
'http://www.techcoil.com/blog/handy-vbscript-functions-for-dealing-with-zip-files-and-folders/
Function fnCreatePath( folderUrl )
    folderUrl = objFSO.GetAbsolutePathName(folderUrl)     
    If (Not objFSO.folderExists(objFSO.GetParentFolderName(folderUrl))) then
        ' Call CreateFolder recursively to create the parent folder
        fnCreatePath(objFSO.GetParentFolderName(folderUrl))
    End If
    ' Create the current folder if the parent exists
    If (Not objFSO.FolderExists(folderUrl)) then
        CALL Debug( "fnCreatePath; FolderURL = " & folderUrl )
        objFSO.CreateFolder(folderUrl)
    End If
End Function

' ----------------------------------------------
' Will return TRUE if folder is Empty or !Exist
Function fnFolderIsEmpty( sFolderName ) 
  Dim objFolderFSO        'FileSystemObject
  Dim objFolder
  Set objFolderFSO = CreateObject("Scripting.FileSystemObject")

  On Error Resume Next
  fnFolderIsEmpty = TRUE        'Return TRUE if it doesn't exist either
  If objFolderFSO.FolderExists( sFolderName ) Then
      Set objFolder = objFolderFSO.GetFolder( sFolderName )

      If objFolder.Files.Count = 0 And objFolder.SubFolders.Count = 0 Then
          fnFolderIsEmpty = TRUE
      Else
          fnFolderIsEmpty = FALSE
      End If
  End If
  objFolderFSO = Nothing
  objFolder = Nothing
End Function

' ----------------------------------------------
'Purpose:   Return True if the file exists, even if it is hidden.
'Arguments: strFile: File name to look for. Current directory searched if no path included.
'Note:      Does not look inside subdirectories for the file.
'Author:    Allen Browne. http://allenbrowne.com June, 2006.
Function FileExists( strFile ) 
    On Error Resume Next
    DIM fso

    Set fso = CreateObject("Scripting.FileSystemObject")

    If (fso.FileExists( strFile )) Then
      FileExists = TRUE
    Else
      FileExists = FALSE
    End If
    fso = Nothing
End Function

'---------------------------------------------------------------
'Based on: http://blogs.msdn.com/b/gstemp/archive/2004/08/11/213028.aspx
' Returns ArrayList of folders found in sDirectory
Function fnListDirIn( ByVal sDirectory )
    Set objWMIService = GetObject("winmgmts:\\.")
    CALL Debug( "fnListDirIn() Path=" & sDirectory )

    Set colFolders = objWMIService.ExecQuery _
                    ("ASSOCIATORS OF Win32_Directory.Name='" & sDirectory & "' " _
                    & "WHERE AssocClass = Win32_Subdirectory " _
                    & "ResultRole = PartComponent")

    Set arrNames = CreateObject("System.Collections.ArrayList")

    For Each objFolder in colFolders
        CALL Debug( "fnListDirIn Add Folder=" & objFolder.Name )
        arrNames.Add( objFolder.name )
    Next

    'colFolders = Nothing ?Why does this fail?
    'objFolder = Nothing  ?Why does this fail?
    Set fnListDirIn = arrNames
End Function

' ----------------------------------------------
'Checks available Windows Scripting Host Version
' - Quit Script if not available
'Based on: http://www.robvanderwoude.com/vbstech_debugging.php
Function fnCheckWSHversion( ByVal iMinVer )
    intMajorVerion = 0 + CInt( Mid( WScript.Version, 1, InStr( WScript.Version, "." ) - 1 ) )
    intMinorVerion = 0 + CInt( Mid( WScript.Version, InStr( WScript.Version, "." ) + 1 ) )
    intCheckVersion = 1000 * intMajorVerion + intMinorVerion
    CALL Debug( "WSH Version = " & intCheckVersion )
    If intCheckVersion < iMinVer Then
        WScript.Echo "Sorry, this script requires WSH " & iMinVer/1000 & " or later"
        WScript.Quit intCheckVersion
    End If
End Function

' ----------------------------------------------
' Dumps debug myText to an InternetExplorer Window
' Based on script from:
' http://www.robvanderwoude.com/vbstech_debugging.php
Sub Debug( myText )
    ' Uncomment the next line to turn off debugging
    IF NOT bDebug THEN
        Exit Sub
    END IF

    If Not IsObject( objIEDebugWindow ) Then
        Set objIEDebugWindow = CreateObject( "InternetExplorer.Application" )
        objIEDebugWindow.Navigate "about:blank"
        objIEDebugWindow.Visible = True
        objIEDebugWindow.ToolBar = False
        objIEDebugWindow.Width   = 200
        objIEDebugWindow.Height  = 300
        objIEDebugWindow.Left    = 10
        objIEDebugWindow.Top     = 10
        Do While objIEDebugWindow.Busy
            WScript.Sleep 100
        Loop
        objIEDebugWindow.Document.Title = "IE Debug Window"
        objIEDebugWindow.Document.Body.Innerhtml = _
                     "<b>" & Now & "</b></br>"
    End If

    objIEDebugWindow.Document.Body.InnerHTML = _
                     objIEDebugWindow.Document.Body.InnerHTML _
                     & myText & "<br>" & vbCrLf
    'Do NOT set objIEDebugWindow = Nothing; Will go away
End Sub

让我知道你的想法。谢谢。