【VBA】FSOを使用してファイルの読み・書き・追記を行う

0

    <機能>

    FSO(FileSystemObject)を使ってファイルの読み・書き・追記を行うサンプルです

    (1)ファイルにテキストを書き込む

    (2)ファイルにテキストを追記する

    (3)ファイルからテキストを読み込む

    (4)フォルダを作成する

    (5)ファイルを別フォルダにリネームしてコピーする

    (6)ファイルをワイルドカードを使用して別フォルダにコピーする

    (7)ファイルを削除する

     

    <実行イメージ>

    上記(1)〜()実行後のイメージです

    ()()  ファイル書き込み・追記を行います

    (3)  追記を行ったファイルを読み込み結果をシートに出力します

    ()()  フォルダを作成し作成したファイルを100回コピーします

    ()  100回コピーされたファイルを別フォルダにワイルドカードを使用してコピーします

    (7)  コピーしたファイルからファイル末尾に不可した数値が10の倍数のファイルを削除します

    VBA,FSO,実行イメージ,

    VBA,FSO,読み込みデータをシートに表示,

     

    <動作検証&開発環境>
    Microsoft Office 2016

     

    <使い方>

    (1)参照設定を行います

    [Alt]+[F11]でVBE(VBAエディター)を表示します

    メニューの[ツール(T)]から[参照設定(R)]を選択します

    Microsoft Scripting Runtimeをチェックして[OK]を押下してください

    VBA,FSO,参照設定,MicrosoftScriptingRuntime,

    これによりForReading / TristateFalseなどの定数が使用できるようになります

     

    (2)標準モジュールを追加してソースを貼り付けます

    (3)「FSOでファイルを操作する」 プロシージャを実行します

     

    Option Explicit
    '/*********************************************
    '/ ファイル操作メイン処理
    '/ このプロシージャをコールする
    '/*********************************************

    Public Sub FSOでファイルを操作する()
        Dim strfile As String
        Dim strfolder As String, strfolder2 As String
        Dim strtxt As String, strbuf() As String
        Dim i As Integer
       
        '//データは横浜市の区ごとの総人口と男女別人口
        strtxt = "横浜市全体,3724844,1855985,1868859" & vbCrLf & _
                "鶴見区,285356,147650,137706" & vbCrLf & _
                "神奈川区,238966,121769,117197" & vbCrLf & _
                "西区,98532,49850,48682" & vbCrLf & _
                "中区,148312,78087,70225" & vbCrLf & _
                "南区,194827,97006,97821" & vbCrLf & _
                "保土ヶ谷区,205493,102381,103112" & vbCrLf & _
                "磯子区,166229,81827,84402" & vbCrLf & _
                "金沢区,202229,99167,103062" & vbCrLf & _
                "港北区,344172,174460,169712" & vbCrLf & _
                "戸塚区,275283,135271,140012" & vbCrLf & _
                "港南区,215736,106126,109610" & vbCrLf & _
                "旭区,247144,120168,126976" & vbCrLf & _
                "緑区,180366,89002,91364" & vbCrLf & _
                "瀬谷区,124560,60889,63671" & vbCrLf & _
                "栄区,122171,59729,62442" & vbCrLf & _
                "泉区,154025,75460,78565" & vbCrLf & _
                "青葉区,309692,151182,158510" & vbCrLf & _
                "都筑区,211751,105961,105790" & vbCrLf
        '//ファイルパス
        strfile = ThisWorkbook.Path & "¥fsotest.txt"
       
        '//――――――――――――――――――――――
        '//(1)ファイルにテキストを書き込む
        If Not WriteUsingFSO(strtxt, strfile) Then
            MsgBox "ファイル書き込み(WriteUsingFSO)に失敗しました", vbCritical
            Exit Sub
        End If
       
        '//――――――――――――――――――――――
        '//(2)ファイルにテキストを追記する
        If Not AppendUsingFSO(strtxt, strfile) Then
            MsgBox "ファイルへの追記(AppendUsingFSO)に失敗しました", vbCritical
            Exit Sub
        End If
           
        '//――――――――――――――――――――――
        '//(3)ファイルからテキストを読み込む
        If Not ReadUsingFSO(strbuf, strfile) Then
            MsgBox "ファイル読み込み(ReadUsingFSO)に失敗しました", vbCritical
            Exit Sub
        End If
        '//結果表示
        For i = 0 To UBound(strbuf)
            'セル内折り返しを解除
            Range("A" & CStr(i + 1)).WrapText = False
            '読み込みデータを出力
            Range("A" & CStr(i + 1)).Value = strbuf(i)
        Next
       
        '//――――――――――――――――――――――
        '//(4)フォルダを作成する
        strfolder = ThisWorkbook.Path & "¥" & Format(Now, "yyyymmddhhmmss")
        If Not CreateDirUsingFSO(strfolder) Then
            MsgBox "フォルダ作成(CreateDirUsingFSO)に失敗しました", vbCritical
            Exit Sub
        End If
        '//――――――――――――――――――――――
        '//(5)ファイルを別フォルダにリネームしてコピー
        If Not CopyFileUsingFSO(strfile, strfolder) Then
            MsgBox "ファイルコピー(CopyFileUsingFSO)に失敗しました", vbCritical
            Exit Sub
        End If
       
        '//――――――――――――――――――――――
        '//(6)ファイルをワイルドカードを使用して別フォルダにコピー
        '//先に移動先フォルダを作成する(フォルダ名が重複しないように1秒Wait)
        Application.Wait Now + TimeValue("0:00:01")
        strfolder2 = ThisWorkbook.Path & "¥" & Format(Now, "yyyymmddhhmmss")
        If Not CreateDirUsingFSO(strfolder2) Then
            MsgBox "フォルダ作成(CreateDirUsingFSO2)に失敗しました", vbCritical
            Exit Sub
        End If
        '//strfolderに含まれるすべての".txt"ファイルをstrfolder2にコピーする
        If Not CopyFileUsingFSO2(strfolder, strfolder2) Then
            MsgBox "ファイルコピー(CopyFileUsingFSO2)に失敗しました", vbCritical
            Exit Sub
        End If
       
        '//――――――――――――――――――――――
        '//(7)ファイルを削除する
        '//strfolder2から指定ファイルを削除する
        If Not DeleteFileUsingFSO(strfolder2) Then
            MsgBox "ファイル削除(DeleteFileUsingFSO)に失敗しました", vbCritical
            Exit Sub
        End If
       
    End Sub
    '/*********************************************
    '/ ファイル書き込み(FSOでテキストファイルに書き込み)
    '/  stxt : 書き込みテキスト
    '/  sfil : 書き込みファイル
    '/*********************************************

    Private Function WriteUsingFSO(ByVal stxt As String, ByVal sfil As String) As Boolean
        On Error GoTo LblError
        Dim myfso As Object, writefso As Object
       
        '//初期値Falseを設定
        WriteUsingFSO = False
       
        '//FSOオブジェクトを取得する
        Set myfso = CreateObject("Scripting.FileSystemObject")
        '//TextStreamオブジェクトを[上書き]・[ASCIIファイル]で作成(詳細はDeveloperNetwork参照)
        Set writefso = myfso.CreateTextFile(sfil, True, False)
        '//引数は省略可能なので以下でもよい
        '//Set writefso = myfso.CreateTextFile(sfil)
       
        '//ファイルがなければ作成、あれば上書きとなる
        writefso.Write stxt
        '//TextStreamオブジェクトを閉じる
        writefso.Close
        WriteUsingFSO = True
        Exit Function
       
    LblError:
        '//Falseで戻る
    End Function
    '/*********************************************
    '/ ファイルへ追記(FSOでテキストファイルに追記する)
    '/  stxt : 追記するテキスト
    '/  sfil : 追記ファイル
    '/*********************************************

    Private Function AppendUsingFSO(ByVal stxt As String, ByVal sfil As String) As Boolean
        On Error GoTo LblError
        Dim myfso As Object, appendfso As Object
       
        '//初期値Falseを設定
        AppendUsingFSO = False
       
        '//FSOオブジェクトを取得する
        Set myfso = CreateObject("Scripting.FileSystemObject")
        '//TextStreamオブジェクトを[ファイルの最後に追記]・[ファイルを作成しない]・[ASCIIファイル]で作成(詳細はDeveloperNetwork参照)
        Set appendfso = myfso.OpenTextFile(sfil, ForAppending, False, TristateFalse)
       
        '//ファイルの最後に追記する
        appendfso.Write stxt
        '//TextStreamオブジェクトを閉じる
        appendfso.Close
        AppendUsingFSO = True
        Exit Function
       
    LblError:
        '//Falseで戻る
    End Function
    '/*********************************************
    '/ ファイル読み込み(FSOでテキストファイルから読み込み)
    '/  sbuf : 読み込みテキスト(参照渡し)
    '/  sfil : 読み込みファイル
    '/*********************************************

    Private Function ReadUsingFSO(ByRef sbuf() As String, ByVal sfil As String) As Boolean
        On Error GoTo LblError
        Dim myfso As Object, readfso As Object
        Dim strwk As String
       
        '//初期値Falseを設定
        ReadUsingFSO = False
        ReDim sbuf(0)
        sbuf(0) = ""
       
        '//FSOオブジェクトを取得する
        Set myfso = CreateObject("Scripting.FileSystemObject")
        '//TextStreamオブジェクトを[読み取り専用]・[ファイルを作成しない]・[ASCIIファイルとして開く]で作成(詳細はDeveloperNetwork参照)
        Set readfso = myfso.OpenTextFile(sfil, ForReading, False, TristateFalse)
        '//引数は省略可能なので以下でもよい
        '//Set readfso = myfso.OpenTextFile(sfil,ForReading)
       
        '//TextStreamファイル全体を読み込む(改行コードが読み込めない)
        '//sbuf = readfso.ReadAll
        '//TextStreamファイルを1行ずつ読み込む
        Do While readfso.AtEndOfStream <> True
            strwk = readfso.ReadLine
            If sbuf(UBound(sbuf)) <> "" Then
                ReDim Preserve sbuf(UBound(sbuf) + 1)
                sbuf(UBound(sbuf)) = ""
            End If
            sbuf(UBound(sbuf)) = strwk
        Loop
       
        '//TextStreamオブジェクトを閉じる
        readfso.Close
        ReadUsingFSO = True
        Exit Function
       
    LblError:
        '//Falseで戻る
    End Function
       
    '/*********************************************
    '/ フォルダ作成(FSOでフォルダを作成)
    '/  sfol : 作成フォルダパス
    '/*********************************************

    Private Function CreateDirUsingFSO(ByVal sfol As String) As Boolean
        On Error GoTo LblError
        Dim myfso As Object
       
        '//初期値Falseを設定
        CreateDirUsingFSO = False
       
        '//FSOオブジェクトを取得する
        Set myfso = CreateObject("Scripting.FileSystemObject")
        '//フォルダの存在チェック
        If myfso.FolderExists(sfol) Then GoTo LblError
       
        '//フォルダを作成する
        myfso.CreateFolder sfol
        CreateDirUsingFSO = True
        Exit Function
       
    LblError:
        '//Falseで戻る
    End Function
    '/*********************************************
    '/ ファイルコピー(FSOでファイルをリネームしてコピー)
    '/  sfil : コピー元ファイル
    '/  sfol : コピー先フォルダ
    '/*********************************************

    Private Function CopyFileUsingFSO(ByVal sfil As String, ByVal sfol As String) As Boolean
        On Error GoTo LblError
        Dim myfso As Object
        Dim newfil As String, i As Integer
        Dim strtmp As String
       
        '//初期値Falseを設定
        CopyFileUsingFSO = False
       
        '//FSOオブジェクトを取得する
        Set myfso = CreateObject("Scripting.FileSystemObject")
       
        '//サンプルとして100回コピーする
        strtmp = Right(sfil, Len(sfil) - InStrRev(sfil, "¥"))
        For i = 1 To 100
           
            newfil = sfol & "¥" & Left(strtmp, InStrRev(strtmp, ".") - 1) & "_" & Format(CStr(i), "000") & ".txt"
            'ファイルを指定フォルダにリネームしてコピー
            '[コピー元]・[コピー先]・[ファイルが存在する場合は上書き]でコピー(詳細はDeveloperNetwork参照)
            myfso.CopyFile sfil, newfil, True
        Next
        CopyFileUsingFSO = True
        Exit Function
       
    LblError:
        '//Falseで戻る
    End Function
    '/*********************************************
    '/ ファイルコピー(FSOでワイルドカードを使用してファイルを一括コピー)
    '/ ワイルドカードが使用できるのはファイル名のみです
    '/  sfol1 : コピー元ファイル
    '/  sfol2 : コピー先フォルダ
    '/*********************************************

    Private Function CopyFileUsingFSO2(ByVal sfol1 As String, ByVal sfol2 As String) As Boolean
        On Error GoTo LblError
        Dim myfso As Object
       
        '//初期値Falseを設定
        CopyFileUsingFSO2 = False
       
        '//FSOオブジェクトを取得する
        Set myfso = CreateObject("Scripting.FileSystemObject")
       
        '//[コピー元]・[コピー先]・[ファイルが存在する場合は上書き]でコピー
        '//対象は拡張子が".txt"のファイル
        myfso.CopyFile sfol1 & "¥*.txt", sfol2 & "¥", True
        '//ファイルを移動する場合はMoveFileを使用する
        '//myfso.MoveFile sfol1 & "¥*.txt", sfol2 & "¥"
        CopyFileUsingFSO2 = True
        Exit Function
       
    LblError:
        '//Falseで戻る
    End Function
    '/*********************************************
    '/ ファイル削除(FSOで指定ファイルを削除)
    '/ サンプルとしてファイル名末尾の3桁の数値が10の倍数のファイルを削除
    '/  sfol : ファイル格納フォルダ
    '/*********************************************

    Private Function DeleteFileUsingFSO(ByVal sfol As String) As Boolean
        On Error GoTo LblError
        Dim myfso As Object
        Dim strbuf As String, strtmp As String
       
        '//初期値Falseを設定
        DeleteFileUsingFSO = False
       
        '//FSOオブジェクトを取得する
        Set myfso = CreateObject("Scripting.FileSystemObject")
        '//フォルダ内のファイルを取得して対象なら削除する
        strbuf = Dir(sfol & "¥*.txt", vbNormal)
        Do While strbuf <> ""
            'ファイル末尾の3桁の数値を取得
            strtmp = Replace(Right(strbuf, Len(strbuf) - InStrRev(strbuf, "_")), ".txt", "")
            '10の倍数か判定
            If IsNumeric(strtmp) = False Then GoTo LblNextRecord
            If (CInt(strtmp) Mod 10) = 0 Then
                'ファイルを削除(読み取り専用属性ファイルを削除)(詳細はDeveloperNetwork参照)
                myfso.DeleteFile sfol & "¥" & strbuf, True
            End If
           
    LblNextRecord:
            strbuf = Dir()
        Loop
       
        '//フォルダを作成する
        DeleteFileUsingFSO = True
        Exit Function
       
    LblError:
        '//Falseで戻る
    End Function

    よろしければポチッと押してください


    selected entries

    categories

    calendar

    S M T W T F S
     123456
    78910111213
    14151617181920
    21222324252627
    28293031   
    << October 2018 >>

    profile

    others

    archives