VBAで圧縮解凍処理を行います。
1 | 'オプションの意味：変数宣言必須 |
2 | Option Explicit |
3 |
4 | '圧縮処理(実行) |
5 | Public Sub ZipSample() |
6 | ZipFileOrFolder "C:\Test\Files" 'フォルダ圧縮 |
7 | MsgBox "処理が終了しました。", vbInformation + vbSystemModal |
8 | End Sub |
9 |
10 | '解凍処理(実行) |
11 | Public Sub UnZipSample() |
12 | UnZipFile "C:\Test\Files\Test.zip" |
13 | MsgBox "処理が終了しました。", vbInformation + vbSystemModal |
14 | End Sub |
15 |
16 | '圧縮処理 |
17 | Public Sub ZipFileOrFolder(ByVal SrcPath As Variant, _ |
18 | Optional ByVal DestFolderPath As Variant = "") |
19 | 'ファイル・フォルダをZIP形式で圧縮 |
20 | 'SrcPath：元ファイル・フォルダ |
21 | 'DestFolderPath：出力先、指定しない場合は元ファイル・フォルダと同じ場所 |
22 | Dim DestFilePath As Variant |
23 |
24 | With CreateObject("Scripting.FileSystemObject") |
25 | If IsFolder(DestFolderPath) = False Then |
26 | If IsFolder(SrcPath) = True Then |
27 | DestFolderPath = SrcPath |
28 | ElseIf IsFile(SrcPath) = True Then |
29 | DestFolderPath = .GetFile(SrcPath).ParentFolder.Path |
30 | Else: Exit Sub |
31 | End If |
32 | End If |
33 | DestFilePath = AddPathSeparator(DestFolderPath) & _ |
34 | .GetBaseName(SrcPath) & ".zip" |
35 | '空のZIPファイル作成 |
36 | With .CreateTextFile(DestFilePath, True) |
37 | .Write ChrW(&H50) & ChrW(&H4B) & ChrW(&H5) & ChrW(&H6) & String(18, ChrW(0)) |
38 | .Close |
39 | End With |
40 | End With |
41 | |
42 | With CreateObject("Shell.Application") |
43 | With .NameSpace(DestFilePath) |
44 | .CopyHere SrcPath |
45 | While .Items.Count < 1 |
46 | DoEvents |
47 | Wend |
48 | End With |
49 | End With |
50 | End Sub |
51 |
52 | '解凍処理 |
53 | Public Sub UnZipFile(ByVal SrcPath As Variant, _ |
54 | Optional ByVal DestFolderPath As Variant = "") |
55 | 'ZIPファイルを解凍 |
56 | 'SrcPath：元ファイル |
57 | 'DestFolderPath：出力先、指定しない場合は元ファイルと同じ場所 |
58 | '※出力先に同名ファイルがあった場合はユーザー判断で処理 |
59 | With CreateObject("Scripting.FileSystemObject") |
60 | If .FileExists(SrcPath) = False Then Exit Sub |
61 | If LCase(.GetExtensionName(SrcPath)) <> "zip" Then Exit Sub |
62 | If IsFolder(DestFolderPath) = False Then |
63 | DestFolderPath = .GetFile(SrcPath).ParentFolder.Path |
64 | End If |
65 | End With |
66 | |
67 | With CreateObject("Shell.Application") |
68 | .NameSpace(DestFolderPath).CopyHere .NameSpace(SrcPath).Items |
69 | End With |
70 | End Sub |
71 |
72 | 'フォルダチェック処理 |
73 | Private Function IsFolder(ByVal SrcPath As String) As Boolean |
74 | IsFolder = CreateObject("Scripting.FileSystemObject").FolderExists(SrcPath) |
75 | End Function |
76 |
77 | 'ファイルチェック処理 |
78 | Private Function IsFile(ByVal SrcPath As String) As Boolean |
79 | IsFile = CreateObject("Scripting.FileSystemObject").FileExists(SrcPath) |
80 | End Function |
81 |
82 | 'ファイルパスセパレータ追加処理 |
83 | Private Function AddPathSeparator(ByVal SrcPath As String) As String |
84 | If Right(SrcPath, 1) <> ChrW(92) Then SrcPath = SrcPath & ChrW(92) |
85 | AddPathSeparator = SrcPath |
86 | End Function |