VBA文件处理

Const ForReading = 1, ForWriting = 2, ForAppending = 8

'概要：     フォルダー選択ダイアローグを出して、フォルダを選択
'引数：     無し
'戻り値：   getFilePath　選択されたパス
Function getFilePath() As String
    Dim fd As FileDialog
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "フォルダを開く"
        If .Show = -1 Then
            getFilePath= .SelectedItems(1)
        End If
    End With
End Function

'概要：     指定された行番を読む
'引数：     strRowNo　行番
'戻り値：   readRowNo　指定行目の内容
Function readRowNo(strPath As String, strRowNo As Integer) As String
    Dim FileObj
    Dim FilePath
    Dim strNY As String
    
    Set FileObj = CreateObject("Scripting.FileSystemObject")
    Set File = FileObj.openTextFile(strPath, 1)
    
    For i = 1 To strRowNo
        File.SkipLine
    Next

    readRowNo = File.readLine
     
    File.Close
    Set File = Nothing
    Set FileObj = Nothing
End Function

'概要：     フォルダー中のファイル一覧（全てファイル）を取得（サブフォルダー含む）
'引数：     strInPath　パス, arrOutput 戻す配列
'戻り値：   makeFileList「true:ファイル有り,　false:ファイル無し」
Function makeFileList(strInPath As String, arrOutput() As String) As Boolean    
    Dim fso As Object
    Dim fd As Object
    
    makeFileList = False
    
    ReDim arrOutput(0)
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fd = fso.GetFolder(strInPath)
    searchFiles fd, arrOutput
    
    Set fso = Nothing
    Set fd = Nothing
    
    If 0 < UBound(arrOutput, 1) Then
        ReDim Preserve arrOutput(UBound(arrOutput, 1) - 1)
    Else
        Exit Function
    End If
    
    makeFileList = True
    
End Function

'概要：     フォルダー中のファイル一覧（指定拡張子）を取得（サブフォルダー含む）
'引数：     strInPath:パス, strFileType:ファイル類型 ,arrOutput 戻す配列
'戻り値：   makeFileList「true:ファイル有り,　false:ファイル無し」
Function makeFileList(strInPath As String, strFileType As String, arrOutput() As String) As Boolean
    
    Dim fso As Object
    Dim fd As Object
    
    makeFileList = False
    
    ReDim arrOutput(0)
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fd = fso.GetFolder(strInPath)
    searchFiles fd, strFileType, arrOutput
    
    Set fso = Nothing
    Set fd = Nothing
    
    If 0 < UBound(arrOutput, 1) Then
        ReDim Preserve arrOutput(UBound(arrOutput, 1) - 1)
    Else
        Exit Function
    End If
    
    makeFileList = True
    
End Function

'概要：     フォルダー中のファイル一覧（全てファイル）を取得
'引数：     fd　フォルダー対象, arrOutput 戻す配列
'戻り値：   searchFiles「true:ファイル有り,　false:ファイル無し」
Function searchFiles(fd As Object, arrOutput() As String) As Boolean    
    Dim fl As Object
    Dim sfd As Object 
    searchFiles = False
  
    For Each fl In fd.Files
    	ReDim Preserve arrOutput(UBound(arrOutput, 1) + 1)
        arrOutput(UBound(arrOutput, 1) - 1) = fl.Path
    Next fl
    
    If fd.SubFolders.Count = 0 Then
        Exit Function
    End If
    
    For Each sfd In fd.SubFolders
        searchFiles sfd, strFileType, arrOutput
    Next
    
    Set sfd = Nothing    
    searchFiles = True  
End Function

'概要：     フォルダー中のファイル一覧（指定拡張子）を取得
'引数：     fd　フォルダー対象, strFileType:ファイル類型, arrOutput 戻す配列
'戻り値：   searchFiles「true:ファイル有り,　false:ファイル無し」
Function searchFiles(fd As Object, strFileType As String, arrOutput() As String) As Boolean
    
    Dim fl As Object
    Dim sfd As Object
    Dim sTmp As String
    
    sTmp = ""
  
    searchFiles = False
  
    sTmp = Split(strFileType, ".")(1)
    sTmp = "." & sTmp
    For Each fl In fd.Files
        If UCase(Right(fl.Path, Len(sTmp))) = UCase(sTmp) Then
            ReDim Preserve arrOutput(UBound(arrOutput, 1) + 1)
            arrOutput(UBound(arrOutput, 1) - 1) = fl.Path
        End If
    Next fl
    
    If fd.SubFolders.Count = 0 Then
        Exit Function
    End If
    
    For Each sfd In fd.SubFolders
        searchFiles sfd, strFileType, arrOutput
    Next
    
    Set sfd = Nothing
    
    searchFiles = True
  
End Function

'概要：     ファイル内容を取得
'引数：     strFileName　ファイル名, arrContent ファイル正文配列
'戻り値：   readFile「true:正常,　false:異常」
Function readFile(strFileName As String, arrContent As Variant) As Boolean

    Dim fso As Object
    Dim sFile As Object

    readFile = False
    
    If isFileExists(strFileName) Then
        'NULL
    Else
        Exit Function
    End If
    
    ReDim arrContent(0)
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set sFile = fso.openTextFile(strFileName, 1)

    Do While Not sFile.AtEndOfStream
        ReDim Preserve arrContent(UBound(arrContent, 1) + 1)
        arrContent(UBound(arrContent, 1) - 1) = sFile.readLine
    Loop
    
    sFile.Close

    Set fso = Nothing
    Set sFile = Nothing
    
    If 0 < UBound(arrContent, 1) Then
        ReDim Preserve arrContent(UBound(arrContent, 1) - 1)
    Else
        Exit Function
    End If

    readFile = True    
End Function

'概要：     ファイル存在を判定
'引数：     strFileName　ファイル名
'戻り値：   isFileExists「true:存在,　false:存在しない」
Function isFileExists(strFileName As String) As Boolean   
 
    Dim fs As Object 
    Set fs = CreateObject("Scripting.FileSystemObject")

    If fs.FileExists(strFileName) Then
        isFileExists = True
    Else
        isFileExists = False
    End If    

    Set fs = Nothing

End Function

'概要：     ファイルに内容を記入
'引数：     strFileName:ファイル名, arrContent：記入したい内容, intIoMode:処理モード, booCreate:ファイル存在無し「true:作成, false:作成しない」
'戻り値：   無し
Function writeFile(strFileName As String, arrContent() As String, _
                   ByVal intIoMode As integer, ByVal booCreate As Boolean) As Boolean

    Dim fso As Object
    Dim sFile As Object
    Dim i As Long
    
    i = 0

    writeFile = False
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Select Case intIoMode 
        Case 8	'追加
            Set sFile = fso.openTextFile(strFileName, 8, booCreate)
        Case 1	'読む
            Set sFile = fso.openTextFile(strFileName, 1, booCreate)
        Case 2	'書く
            Set sFile = fso.openTextFile(strFileName, 2, booCreate)
    End Select
    
    For i = 0 To UBound(arrContent, 1)
        sFile.writeLine (arrContent(i))
    Next i
    
    sFile.Close

    Set fso = Nothing
    Set sFile = Nothing

    writeFile = True
    
End Function

'概要：     ログタイトルを記入
'引数：     strOutFile　目標ファイル名
'戻り値：   無し
Function writeLogHeader(strOutFile As String)

    Dim cOutput() As String
    
    ReDim cOutput(0)

    'タイトルを指定
    cOutput(0) = """" & "No." & """" & vbTab
    cOutput(0) = cOutput(0) & """" & "Source File" & """" & vbTab
    cOutput(0) = cOutput(0) & """" & "Row Number" & """" & vbTab
    cOutput(0) = cOutput(0) & """" & "Row Infor" & """"

    Call writeFile(strOutFile, cOutput, ForAppending, True)
    
End Function

'概要：     ログ正文を記入
'引数：     strOutFile:ファイル名, lNum:順番, strSrcFile:ソースファイル, lngRownum:行番, strRowContent:行正文
'戻り値：   無し
Function writeLog(strOutFile As String, lNum As Long, strSrcFile As String, lngRownum As Long, strRowContent As String)

    Dim cOutput() As String
    
    ReDim cOutput(0)
    cOutput(0) = Chr(34) & lNum & Chr(34) & vbTab
    cOutput(0) = cOutput(0) & Chr(34) & strSrcFile & Chr(34) & vbTab
    cOutput(0) = cOutput(0) & Chr(34) & lngRownum & Chr(34) & vbTab
    'cOutput(0) = cOutput(0) & Chr(34) & strRowContent & Chr(34)
    cOutput(0) = cOutput(0) & strRowContent
    Call writeFile(strOutFile, cOutput, ForAppending, True)
    
End Function

'概要：     指定パスのファイルを消す
'引数：     strFilePath:目標パス
'戻り値：   true:操作成功, false:操作失敗
Function deleteAllFiles(ByVal strFilePath As String) As Boolean    
    Dim arrOutput() As String
    Call makeFileList(strFilePath, arrOutput)    
    For i = 0 To UBound(arrOutput)
        If isFileExists(arrOutput(i)) Then        
            Kill arrOutput(i)            
        End If
    Next i    
    deleteAllFiles = True
End Function