access2010 FileSystemObject その2

もういい。めんどうだ
きちんと動く気がしない

Option Compare Database
Option Explicit

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
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 Variant　
'Booleanにしてたけどなんか変
'基本的には上書き仕様。アーカイブに追加は無し。
On Error GoTo ErrHnd

Dim n As Integer
Dim strZipData 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
'zip存在してたら削除して作り直し
    If objFileSys.FileExists(ZipFilePathString) Then
       objFileSys.DeleteFile ZipFilePathString
    End If
    objFileSys.CreateTextFile(ZipFilePathString, False).Write strZipData
    
    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, 20 'ここが効かない
'追加ファイルごとにループで待機することで、でかファイルでもエラーでなーす。
'だけど経過ダイアログが消せてないからキャンセル押下で無限ループ
        Do Until objDestination.Items().Count = n + 1
            DoEvents
            Sleep 1000
        Loop
    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