VBA文件处理

Option Explicit

' ▽▽▽▽▽▽▽▽▽▽▽▽▽▽▽▽▽▽
' Excel对象
' △△△△△△△△△△△△△△△△△△

' Open
Public Function FileOpen_ByExcel(ByVal FileName As String, ByRef Target As Workbook) As Boolean

    On Error GoTo OpenFileError

    Set Target = Workbooks.Open(FileName:=FileName, ReadOnly:=False)
    FileOpen_ByExcel = True
    Exit Function

OpenFileError:
    FileOpen_ByExcel = False

End Function

' Save
Public Function FileSave_ByExcel(ByVal FileName As String, ByVal Target As Workbook) As Boolean

    On Error GoTo SaveFileError

    If FileName = "" Then
        Target.Save
    Else
        Target.SaveAs FileName:=FileName
    End If
    FileSave_ByExcel = True
    Exit Function

SaveFileError:
    FileSave_ByExcel = False

End Function

' Close
Public Function FileClose_ByExcel(ByVal Target As Workbook) As Boolean

    On Error GoTo FileCloseError

    Target.Close savechanges:=False
    FileClose_ByExcel = True
    Exit Function

FileCloseError:
    FileClose_ByExcel = False

End Function

' ▽▽▽▽▽▽▽▽▽▽▽▽▽▽▽▽▽▽
' FileSystemObject
' △△△△△△△△△△△△△△△△△△

' Folder
' CreateFolder
Public Function FolderCreate_ByFSO(ByVal FolderName As String, ByVal DeleteFlg As Boolean) As Boolean

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

    On Error GoTo FolderCreateError

    If FSO.FolderExists(FolderName) Then
        If DeleteFlg Then
            FSO.DeleteFolder (FolderName)
        Else
            Set FSO = Nothing
            FolderCreate_ByFSO = True
            Exit Function
        End If
    End If

    Dim ParentFolderName As String
    ParentFolderName = FSO.GetParentFolderName(FolderName)
    If FSO.FolderExists(ParentFolderName) = False Then
        If FolderCreate_ByFSO(ParentFolderName, False) = False Then
            GoTo FolderCreateError
        End If
    End If

    FSO.CreateFolder (FolderName)
    Set FSO = Nothing
    FolderCreate_ByFSO = True
    Exit Function

FolderCreateError:
    Set FSO = Nothing
    FolderCreate_ByFSO = False

End Function

' CreateFile
Public Function FileCreate_ByFSO(ByVal FileName As String, ByVal DeleteFlg As Boolean) As Boolean

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

    On Error GoTo FileCreateError

    If FSO.FileExists(FileName) Then
        If DeleteFlg Then
            FSO.DeleteFile (FileName)
        Else
            Set FSO = Nothing
            FileCreate_ByFSO = True
            Exit Function
        End If
    End If

    Dim ParentFolderName As String
    ParentFolderName = FSO.GetParentFolderName(FileName)
    If FSO.FolderExists(ParentFolderName) = False Then
        If FolderCreate_ByFSO(ParentFolderName, False) = False Then
            GoTo FileCreateError
        End If
    End If

    FSO.CreateTextFile (FileName)
    Set FSO = Nothing
    FileCreate_ByFSO = True
    Exit Function

FileCreateError:
    Set FSO = Nothing
    FileCreate_ByFSO = False

End Function
'
'' OpenTextFile
'Public Function OpenTextFile_ByFSO(ByVal FileName As String) As String
'
'    Const ForReading As Integer = 1
'    Const CreateFlgFalse As Boolean = False
'
'    Dim FSO As Object, TextFile As Object, TextStr As String
'    Set FSO = CreateObject("Scripting.FileSystemObject")
'
'    On Error GoTo OpenTextFileError
'
'    Set TextFile = FSO.OpenTextFile(FileName, ForReading, CreateFlgFalse)
'    TextStr = TextFile.Readall
'
'    TextFile.Close
'    Set FSO = Nothing
'
'    OpenTextFile_ByFSO = TextStr
'    Exit Function
'
'OpenTextFileError:
'
'    TextFile.Close
'    Set FSO = Nothing
'    OpenTextFile_ByFSO = ""
'
'End Function
'
'' OpenTextFile
'Public Function WriteTextFile_ByFSO(ByVal FileName As String, ByVal Buffer As String) As Boolean
'
'    If FileCreate_ByFSO(FileName, True) = False Then
'        WriteTextFile_ByFSO = False
'        Exit Function
'    End If
'
'    Const ForWriting As Integer = 2
'    Const CreateFlgTrue As Boolean = True
'
'    Dim FSO As Object, TextFile As Object
'    Set FSO = CreateObject("Scripting.FileSystemObject")
'
'    On Error GoTo OpenTextFileError
'
'    Set TextFile = FSO.OpenTextFile(FileName, ForWriting, CreateFlgTrue)
'    TextFile.Write (Buffer)
'
'    TextFile.Close
'    Set FSO = Nothing
'
'    WriteTextFile_ByFSO = True
'    Exit Function
'
'OpenTextFileError:
'
'    TextFile.Close
'    Set FSO = Nothing
'    WriteTextFile_ByFSO = False
'
'End Function

Public Function OpenTextFile_ByADODBStream(FileName As String) As String
    Dim FileBody As String

    Dim ADODBStream As Object
    Set ADODBStream = CreateObject("ADODB.Stream")

    With ADODBStream
        .Type =
        .Mode =
        .Open
        .LoadFromFile FileName
        .Position =
        .Type =
        .Charset = "utf-8"
        FileBody = .ReadText
        .Close
    End With

    Set ADODBStream = Nothing

    OpenTextFile_ByADODBStream = FileBody

End Function

' WriteTextFile_ByADODBStream
Public Function WriteTextFile_ByADODBStream(ByVal OutFileName As String, ByVal Buffer As String) As Boolean

    If FileCreate_ByFSO(OutFileName, True) = True Then

        Dim ADODBStream As Object
        Set ADODBStream = CreateObject("ADODB.Stream")

        '
        With ADODBStream
            .Type =
            .Charset = "utf-8"
            .Open
            .WriteText Buffer,
            .SaveToFile OutFileName,
            .Close
        End With

        Set ADODBStream = Nothing
        WriteTextFile_ByADODBStream = True
    Else
        WriteTextFile_ByADODBStream = False
    End If

End Function

'
' log
'
Public Function WriteLog(ByVal LogFilePath As String, ByVal msg As String)
    Dim FSO As Object, LOG As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    ' 
    If FSO.FileExists(LogFilePath) = False Then
        FSO.CreateTextFile (LogFilePath)
    End If
    
    ' 
    Set LOG = FSO.OpenTextFile(LogFilePath, 8)
    ' 
    LOG.WriteLine Now & vbTab & msg
    
    Set LOG = Nothing
    Set FSO = Nothing
End Function