Un Known…(跡地) 技術メモ

VBAで圧縮解凍処理を行います。

'オプションの意味：変数宣言必須
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

Excelでオブジェクトを変数宣言するには
遅延バインディングと事前バインディングの2種類の方法がある。

実装の違い(例として、FileSystemObjectを利用)

• 遅延バインディング

Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")

• 事前バインディング

「ツール」→「参照設定」で
「Microsoft Scripting Runtime」にチェックを付ける。

Dim objFSO As New FileSystemObject
または、
Dim objFSO As FileSystemObject
Set objFSO = New FileSystemObject

一言で言えば、変数宣言の型が
遅延バインディングはObject型
事前バインディングは特定のオブジェクト型
となっている。

遅延バインディング（実行時バインディング）

オブジェクトが Object 型として宣言された変数に代入する場合、
遅延（実行時）にバインディングされる。
この型のオブジェクトは、任意のオブジェクトへの参照を保持できるが、
事前バインディングされたオブジェクトの利点をほとんど持たない。

事前バインディング

特定のオブジェクト型として宣言された変数に代入する場合、
オブジェクトは事前（コンパイル時に）バインディングされる。
事前バインディングされたオブジェクトでは、アプリケーションが実行される前に、
コンパイラによってメモリの割り当てとその他の最適化が実行される。
また、自動クイックヒントが表示されるようになる。

名前の定義は有能だと思うのですが、
参考ブックからコピーすると一緒にコピーされ、
収集つかなくなるためこれで削除します。

Option Explicit

Private Sub NameDefDel()
    Dim Ans, RefStyle, n
    
    Ans = MsgBox("実行しますか？", vbYesNo, "実行確認")
    If Ans = vbNo Then Exit Sub
    
    RefStyle = Application.ReferenceStyle
    
    If RefStyle = xlR1C1 Then
        Application.ReferenceStyle = xlA1
    Else
        Application.ReferenceStyle = xlR1C1
    End If

    For Each n In ActiveWorkbook.Names
        If Not n.Name Like "*!Print_Area" And _
            Not n.Name Like "*!Print_Titles" Then
            n.Delete
        End If
    Next

    Application.ReferenceStyle = RefStyle
    
    MsgBox "完了しました！"
End Sub