【VBA】Win10の標準機能でフォルダやファイルを圧縮する

2021年8月19日

データの圧縮について

８月なのに水が冷たい。。。

秋生まれだからなのか、暑いのと寒いのが苦手。どもjimです✋

今回は、以前あった依頼について記事にしてみようと思います。

どんな依頼かってぇーと、

『フォルダやファイルの圧縮（機能の一部に）』

まだこんなことしている企業があったのか。。。

圧縮が必要な仕事の仕方って、どうなんでしょうか？

多分、いけてねぇっす😅

 

簡単な圧縮方法

Win10の標準機能を使って圧縮するっす。

１、同じ名前の古いzipがあれば消す

２、zipフォルダ作成

３、zipフォルダに指定したフォルダやファイルをコピー

４、コピーが終わるまで待機

Option Explicit
Sub zip()
Dim targetName(2) As Variant
    'targetName(0) = "圧縮するフォルダorファイル
    targetName(0) = "C:\○○\△△フォルダ"
    targetName(1) = "C:\○○\△△\××フォルダ"
    targetName(2) = "C:\○○\△△\Book1.xlsx"
    Call MakeZip("C:\○○\テスト（フルパス）.zip", targetName)
End Sub
Private Sub MakeZip(ByVal zipName As String, collections As Variant)
Dim FSO As Object
Dim shellApp As Object
Dim zipFolder As Object
Dim dataObject As Variant
Dim i As Long
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set shellApp = CreateObject("Shell.Application")
    If FSO.fileexists(zipName) = True Then
        FSO.deletefile zipName
    End If
    With FSO.createtextfile(zipName, True)
        .write "PK" & Chr(5) & Chr(6) & String(18, 0)
        .Close
    End With
    i = 0
    Set zipFolder = shellApp.Namespace(FSO.getabsolutepathname(zipName))
    For Each dataObject In collections
        If CStr(dataObject) <> "" Then
            dataObject = FSO.getabsolutepathname(dataObject)
            zipFolder.copyhere (dataObject)
            i = i + 1
        End If
    Next
    Do While zipFolder.Items().Count <> i
        DoEvents
    Loop
    Set FSO = Nothing
    Set shellApp = Nothing
End Sub

何かの事故で無限ループに入ったらすんまてん。

圧縮なんて無駄なこと止めさせたい。。。

したら、またね✋