access2010 FileSystemObject

別にaccessに限ってのことではないんだけど。苦手だから使ってなかったけど使いそうな気配
育てていこうかな。クラスにする必要あったのかなぁ
あー、よくかんがえたらzipアーカイブ処理は非同期だなぁ

Option Compare Database
Option Explicit

Private objFileSys As Object
Private objShell As Object

Private Sub Class_Initialize()
    Set objFileSys = CreateObject("Scripting.FileSystemObject")
    Set objShell = CreateObject("Shell.Application")
End Sub

Private Sub Class_Terminate()
    Set objFileSys = Nothing
    Set objShell = Nothing
End Sub

Public Function CreateZipFile(ZipFilePathString As Variant, ParamArray TargetFilesPathString()) As Boolean
On Error GoTo ErrHnd
'http://blog.livedoor.jp/humanfrog/archives/27718638.htmlから勝手に引用参考にさせていただいた。いい世の中だなぁ
Dim n As Integer
Dim strZipData As String
Dim strFile As String
Dim objFolder As Object
Dim objFolderItem As Object
Dim objDestination As Object

    CreateZipFile = True
    
    strZipData = "PK" & Chr(5) & Chr(6) & String(18, 0)
    
    If UCase(objFileSys.GetExtensionName(ZipFilePathString)) <> "ZIP" Then
        Debug.Print "拡張子が違います。"
        CreateZipFile = False
        Exit Function
    End If

    If Not objFileSys.FileExists(ZipFilePathString) Then
        objFileSys.CreateTextFile(ZipFilePathString, False).Write strZipData
    End If

    Set objDestination = objShell.NameSpace(ZipFilePathString)
    For n = 0 To UBound(TargetFilesPathString)
        Set objFolder = objShell.NameSpace(objFileSys.GetParentFolderName(TargetFilesPathString(n)))
        Set objFolderItem = objFolder.ParseName(objFileSys.GetFileName(TargetFilesPathString(n)))
        If objFolderItem Is Nothing Then
            Debug.Print "ファイルがありません。：" & TargetFilesPathString(n)
            objFileSys.DeleteFile ZipFilePathString
            CreateZipFile = False
            Exit Function
        End If
        objDestination.CopyHere objFolderItem, 16
    Next
Exit Function
ErrHnd:
    CreateZipFile = False
    Debug.Print Err.Number, Err.Description
End Function

Public Function ExtractZipFile(TargetZipFilePath As Variant, DestinationFolderPath As Variant) As Boolean
On Error GoTo ErrHnd
Dim objFile As Object
Dim objDestination As Object

    ExtractZipFile = True

    If UCase(objFileSys.GetExtensionName(TargetZipFilePath)) <> "ZIP" Then
        Debug.Print "拡張子が違います。"
        ExtractZipFile = False
        Exit Function
    End If
    
    If Not objFileSys.FolderExists(DestinationFolderPath) Then
        objFileSys.CreateFolder DestinationFolderPath
    End If
    
    Set objFile = objShell.NameSpace(TargetZipFilePath)
    Set objDestination = objShell.NameSpace(DestinationFolderPath)
    objDestination.CopyHere objFile.Items, 16 '同一ファイル名は上書き
Exit Function
ErrHnd:
    ExtractZipFile = False
    Debug.Print Err.Number, Err.Description
End Function

Public Function FolderExists(PathStrings As Variant) As Boolean
    FolderExists = objFileSys.FolderExists(PathStrings)
End Function

Public Function FileExists(PathStrings As Variant) As Boolean
    FileExists = objFileSys.FileExists(PathStrings)
End Function

Public Function GetFileName(PathStrings As Variant) As String
    GetFileName = objFileSys.GetFileName(PathStrings)
End Function

'
Public Function BuildPath(FolderPathString As Variant, FileNameString As String) As Variant
    BuildPath = objFileSys.BuildPath(FolderPathString, FileNameString)
End Function

Public Function GetAbsolutePathName(FilePathString As Variant) As Variant
    GetAbsolutePathName = objFileSys.GetAbsolutePathName(FilePathString)
End Function

Public Function GetBaseName(FilePathString As Variant) As String
    GetBaseName = objFileSys.GetBaseName(FilePathString)
End Function

Public Function GetExtensionName(FilePathString As Variant) As Variant
    GetExtensionName = objFileSys.GetExtensionName(FilePathString)
End Function

Public Function GetParentFolderName(FilePathString As Variant) As String
    GetParentFolderName = objFileSys.GetParentFolderName(FilePathString)
End Function

Public Function CopyFile(TargetFilePath As Variant, DestinationFilePath As Variant) As Boolean
On Error GoTo ErrHnd
    CopyFile = True
    
    objFileSys.CopyFile TargetFilePath, DestinationFilePath
Exit Function
ErrHnd:
    CopyFile = False
    Debug.Print Err.Number, Err.Description
End Function

Public Function CopyFolder(TargetFolderPath As Variant, DestinationFolderPath As Variant) As Boolean
On Error GoTo ErrHnd
    CopyFolder = True
    
    objFileSys.CopyFolder TargetFolderPath, DestinationFolderPath
Exit Function
ErrHnd:
    CopyFolder = False
    Debug.Print Err.Number, Err.Description
End Function

Public Function MoveFile(TargetFilePath As Variant, DestinationFolderPath As Variant) As Boolean
On Error GoTo ErrHnd
    MoveFile = True
    
    objFileSys.MoveFile TargetFilePath, DestinationFolderPath
Exit Function
ErrHnd:
    MoveFile = False
    Debug.Print Err.Number, Err.Description
End Function

Public Function MoveFolder(TargetFolderPath As Variant, DestinationFolderPath As Variant) As Boolean
On Error GoTo ErrHnd
    MoveFolder = True
    
    objFileSys.MoveFolder TargetFolderPath, DestinationFolderPath
Exit Function
ErrHnd:
    MoveFolder = False
    Debug.Print Err.Number, Err.Description
End Function

Public Function DeleteFile(TargetFilePath As Variant) As Boolean
On Error GoTo ErrHnd
    DeleteFile = True
    
    objFileSys.DeleteFile TargetFilePath
Exit Function
ErrHnd:
    DeleteFile = False
    Debug.Print Err.Number, Err.Description
End Function

Public Function DeleteFolder(TargetFolderPath As Variant) As Boolean
On Error GoTo ErrHnd
    DeleteFolder = True
    
    objFileSys.DeleteFolder TargetFolderPath
Exit Function
ErrHnd:
    DeleteFolder = False
    Debug.Print Err.Number, Err.Description
End Function

Public Function CreateFolder(TargetFolderPath As Variant) As Boolean
On Error GoTo ErrHnd
    CreateFolder = True
    
    objFileSys.CreateFolder TargetFolderPath
Exit Function
ErrHnd:
    CreateFolder = False
    Debug.Print Err.Number, Err.Description
End Function