投稿‎ > ‎

MakeCab

posted Oct 19, 2016, 4:05 PM by Zhang Wenxu   [ updated Oct 20, 2016, 3:50 PM ]
VBAで指定フォルダーにあるファイルを集めて、MakeCabでcabファイルを作成する。
VBAでフィルターをかけられるので、あるパターンのみのファイルをバックアップすると便利。

Dim cel As Range
Dim rootFld As String
Dim outFld As String
Dim ts As TextStream

Public Const TemporaryFolder = 2
Public Sub listFiles()
    Dim fso  As New FileSystemObject
    Dim fld As Folder
    Dim ret As String
    
    rootFld = "C:\work\Demo_x86"
    outFld = "E:\Documents\backup"
    ret = runCmd("pushd " & outFld & " " & Chr(38) & " rd /S /Q . 2> nul ")
    
    Set ts = fso.OpenTextFile(outFld & "\cablist.txt", ForWriting, True)
    ts.WriteLine ".OPTION EXPLICIT"
    ts.WriteLine ".Set SourceDir = " & rootFld
    'ts.WriteLine ".Set DestinationDir=" & outFld
    ts.WriteLine ".Set CabinetNameTemplate=" & fso.GetFileName(rootFld) & ".CAB"
    ts.WriteLine ".Set Cabinet=on"
    ts.WriteLine ".Set Compress=on"
    'ts.WriteLine ".Set MaxCabinetSize=2000000000000"
    'ts.WriteLine ".Set MaxDiskSize=512000000"
    Set cel = ActiveCell
    Set fld = fso.GetFolder(rootFld)
    Call listFld(fld)
    ts.Close
    
    ret = runCmd("pushd " & outFld & " " & Chr(38) & " makecab /F " & """" & outFld & "\cablist.txt" & """ /L " & outFld)
    Debug.Print ret
End Sub

Public Sub listFld(fld As Folder)
    Dim subFld As Object
    Dim f As Object
    For Each f In fld.Files
        'Debug.Print f.name
        cel.Value = Mid(f.Path, Len(rootFld) + 2, 100)
        Set cel = cel.Offset(1, 0)
        ts.WriteLine """" & Mid(f.Path, Len(rootFld) + 2, 100) & """"
    Next
    For Each subFld In fld.SubFolders
        'Debug.Print subFld.name
        'cel.Value = Mid(subFld.Path, Len(rootFold) + 1, 100)
        'Set cel = cel.Offset(1, 0)
        ts.WriteLine ".Set DestinationDir=" & """" & Mid(subFld.Path, Len(rootFld) + 2, 100) & """"
        Call listFld(subFld)
    Next
End Sub

Public Function runCmd(strCmd As String) As String
    Dim fso As New FileSystemObject
    Dim tempFile As String
    Dim wsh As Object
    Dim waitOnReturn As Boolean
    Dim windowStyle As Integer

    Set wsh = CreateObject("WScript.Shell")
    tempFile = fso.GetSpecialFolder(TemporaryFolder) & "\" & Replace(fso.GetTempName(), ".tmp", ".txt")
    strCmd = "cmd /c " & strCmd & " > " & tempFile
    Debug.Print strCmd
    waitOnReturn = True
    windowStyle = 0
    wsh.Run strCmd, windowStyle, waitOnReturn
    On Error Resume Next
    runCmd = fso.OpenTextFile(tempFile, ForReading, False).ReadAll
End Function



参照設定:
Microsoft Scripting Runtime

Comments