Excel

ZIP形式で圧縮・解凍を行うVBAマクロ

この記事のように、処理の中でZIP形式のファイルを扱うことはありましたが、圧縮・解凍処理だけを記事にすることは無かったので、簡単にコードをまとめてみました。

Option Explicit

Public Sub ZipSample()
  ZipFileOrFolder "C:\Test\Files" 'フォルダ圧縮
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

Public Sub UnZipSample()
  UnZipFile "C:\Test\Files\Test.zip"
  MsgBox "処理が終了しました。", vbInformation + vbSystemModal
End Sub

Public Sub ZipFileOrFolder(ByVal SrcPath As Variant, _
                           Optional ByVal DestFolderPath As Variant = "")
'ファイル・フォルダをZIP形式で圧縮
'SrcPath:元ファイル・フォルダ
'DestFolderPath:出力先、指定しない場合は元ファイル・フォルダと同じ場所
  Dim DestFilePath As Variant
  
  With CreateObject("Scripting.FileSystemObject")
    If IsFolder(DestFolderPath) = False Then
      If IsFolder(SrcPath) = True Then
        DestFolderPath = SrcPath
      ElseIf IsFile(SrcPath) = True Then
        DestFolderPath = .GetFile(SrcPath).ParentFolder.Path
      Else: Exit Sub
      End If
    End If
    DestFilePath = AddPathSeparator(DestFolderPath) & _
                     .GetBaseName(SrcPath) & ".zip"
    '空のZIPファイル作成
    With .CreateTextFile(DestFilePath, True)
      .Write ChrW(&H50) & ChrW(&H4B) & ChrW(&H5) & ChrW(&H6) & String(18, ChrW(0))
      .Close
    End With
  End With
  
  With CreateObject("Shell.Application")
    With .NameSpace(DestFilePath)
      .CopyHere SrcPath
      While .Items.Count < 1
        DoEvents
      Wend
    End With
  End With
End Sub

Public Sub UnZipFile(ByVal SrcPath As Variant, _
                     Optional ByVal DestFolderPath As Variant = "")
'ZIPファイルを解凍
'SrcPath:元ファイル
'DestFolderPath:出力先、指定しない場合は元ファイルと同じ場所
'※出力先に同名ファイルがあった場合はユーザー判断で処理
  With CreateObject("Scripting.FileSystemObject")
    If .FileExists(SrcPath) = False Then Exit Sub
    If LCase(.GetExtensionName(SrcPath)) <> "zip" Then Exit Sub
    If IsFolder(DestFolderPath) = False Then
      DestFolderPath = .GetFile(SrcPath).ParentFolder.Path
    End If
  End With
  
  With CreateObject("Shell.Application")
    .NameSpace(DestFolderPath).CopyHere .NameSpace(SrcPath).Items
  End With
End Sub

Private Function IsFolder(ByVal SrcPath As String) As Boolean
  IsFolder = CreateObject("Scripting.FileSystemObject").FolderExists(SrcPath)
End Function

Private Function IsFile(ByVal SrcPath As String) As Boolean
  IsFile = CreateObject("Scripting.FileSystemObject").FileExists(SrcPath)
End Function

Private Function AddPathSeparator(ByVal SrcPath As String) As String
  If Right(SrcPath, 1) <> ChrW(92) Then SrcPath = SrcPath & ChrW(92)
  AddPathSeparator = SrcPath
End Function

Shellで処理するため、外部のアプリケーションやDLLが不要な点はメリットとして挙げられるのですが、上記コードの処理は“サポート対象外”となっているので、場合によっては上手く処理できないかもしれません。

関連記事

2016年10月の人気記事前のページ

【感想】なんと染め抜く次のページ

関連記事

  1. Office関連

    Officeアプリケーションのバージョン情報ダイアログから情報を取得するVBScript

    自分の手間を減らすためのスクリプトシリーズ、今回はWordやExcel…

  2. Excel

    Adobe Reader XIを利用してPDFファイルのページ数を取得するVBAマクロ

    先日Adobe Readerを利用してPDFファイルのページ数を取得す…

  3. Excel

    MDB(Accessデータベース)ファイルを作成してデータを格納するExcelマクロ

    2012/2/22追記:下記で作成したMDBファイルを利用したWo…

  4. Office アドイン

    [Office用アプリ]日本のOfficeストア向けにもアプリを登録できるようになりました。

    Officeストアにアプリを登録する際、これまではアプリのサポート言語…

  5. Office アドイン

    JavaScriptで作成した作業ウィンドウアプリを検証してみる。

    ※ この情報はOffice 2013 カスタマー プレビュー版を元にし…

  6. Office関連

    [Office]OutlookとIMEの利用に関するアンケートへの回答でAmazonギフト券が当たる…

    昨年の11月、「シンプルリボン」に関するアンケートが行われました(下記…

コメント

  • コメント (0)

  • トラックバックは利用できません。

  1. この記事へのコメントはありません。

Time limit is exhausted. Please reload CAPTCHA.

Translate

Chinese (Simplified)Chinese (Traditional)EnglishFrenchGermanJapaneseKoreanRussianSpanish

最近の記事

アーカイブ

PAGE TOP