□技術メモ - VB6 ファイル処理

※管理人の個人的な技術メモです。このページの内容の実行結果について
管理人はいかなる責任も負いかねますのでご自身の責任でお試しください。

-----------------------------------------------------------

○VB6におけるファイル処理
実行にはCStrListクラスが必要です。

CFsObject.cls
--------
Option Explicit

'==============================
'-->FsObject メソッド一覧

'----  実行に必要なクラス
'CStrList
'----  ファイル関連
'AddYen
'SplitPath
'CreateFdr
'----  存在確認
'IsExistFdr
'IsExistFile
'----  一覧取得
'GetFolders
'GetFiles
'----  Read Write
'WriteString
'ReadString
'ReadString2
'WriteList
'ReadList
'<--ここまで
'==============================

'名称：CFsObject
'機能：ファイル関連処理
'備考：Appに１つ作成する

'----メンバ変数
Private fso As FileSystemObject

Private mFolder As Folder
Private mFolders As Folders
Private mFile As File
Private mFiles As Files

'----内部定数
Private Const csYen As String = "\"

'----コンストラクタ
Private Sub Class_Initialize()
    Set fso = New FileSystemObject
End Sub

Private Sub Class_Terminate()
    Set fso = Nothing
    
    Set mFolder = Nothing
    Set mFolders = Nothing
    Set mFile = Nothing
    Set mFiles = Nothing
End Sub

'==================================
'内部関数
'==================================
'ファイル出力(Private)
'引数：ファイルパス, String, List, Append
Private Function WriteStrList(psPath As String, _
            Optional psLine As String = "", _
            Optional paList As CStrList = Nothing, _
            Optional pbAppend As Boolean = False) As Boolean
On Error GoTo ErrProc
    WriteStrList = False
    Dim ts As TextStream
    Dim iCnt As Long
    Dim iNum As Long
    
    If Not pbAppend Then    '新規書き込み
        Set ts = fso.OpenTextFile(psPath, ForWriting, True, TristateTrue)
        '引数:パス, 1=ForRead 2=ForWrite 8=ForAppend, CreateFile, False=ANSI True=Unicode
    Else                    '追加書き込み
        Set ts = fso.OpenTextFile(psPath, ForAppending, False, TristateTrue)
    End If
    
    'ファイル出力
    If paList Is Nothing Then
        Call ts.WriteLine(psLine)
    Else
        iNum = paList.size
        For iCnt = 0 To iNum - 1
            Call ts.WriteLine(paList.getItem(iCnt))
        Next iCnt
    End If
    WriteStrList = True
    
ExitProc:
    '終了処理
    On Error Resume Next
    ts.Close
    Set ts = Nothing
    Exit Function
    
ErrProc:
        '備考:エラーハンドリング内では On Error Resume Nextは無効
    Debug.Print Err.Number & ":" & Err.Description
        
        'goto ExitProcでは通常処理に戻らないことに注意
        'Resume **** で戻ること
    Resume ExitProc
    
End Function
            
'ファイル読込(Private)
'引数：ファイルパス, String, List
Private Function ReadStrList(psPath As String, _
            Optional psLine As String = "", _
            Optional paList As CStrList = Nothing _
            ) As Boolean
On Error GoTo ErrProc
    ReadStrList = False
    psLine = ""
    Dim ts As TextStream

    Set ts = fso.OpenTextFile(psPath, ForReading, False, TristateTrue)
    '引数:パス, 1=ForRead 2=ForWrite 8=ForAppend, CreateFile, False=ANSI True=Unicode

    '文字列読み込み
    If paList Is Nothing Then
        psLine = ts.ReadLine
    Else
        Do While ts.AtEndOfStream
            Call paList.addItem(ts.ReadLine)
        Loop
    End If
    ReadStrList = True
    
ExitProc:
    '終了処理
    On Error Resume Next
    ts.Close
    Set ts = Nothing
    Exit Function

ErrProc:
        '備考:エラーハンドリング内では On Error Resume Nextは無効
    Debug.Print Err.Number & ":" & Err.Description
        
        'goto ExitProcでは通常処理に戻らないことに注意
        'Resume **** で戻ること
    Resume ExitProc
    
End Function

'==================================
'公開関数
'==================================
'YEN追加
'機能：参照および戻り値で返す
Public Function AddYen(ByRef strPath As String) As String
    AddYen = strPath
    Dim strRightOne As String
    If 1 <= Len(strPath) Then
        strRightOne = Right(strPath, 1)
        If strRightOne <> csYen Then
            strPath = strPath & csYen
        End If
    End If
    AddYen = strPath
End Function

'パス分割
'引数：ファイルのフルパス, フォルダパス, ファイル名
'備考：ファイルのフルパスであることが前提
Public Function SplitPath(ByVal psPath, _
            ByRef psFolder As String, _
            ByRef psFile As String) As Boolean
On Error GoTo ErrProc
    SplitPath = False
    psFolder = ""
    psFile = ""
    Dim lPos As Long
    
    lPos = InStrRev(psPath, csYen)
    psFolder = Mid(psPath, 1, lPos)
    psFile = Mid(psPath, lPos + 1)
    SplitPath = True

ExitProc:
    Exit Function

ErrProc:
    Debug.Print Err.Number & ":" & Err.Description
    Resume ExitProc

End Function

'フォルダ作成
'戻り値：T 成功, F 失敗
'備考　：失敗ならFalseで返る。
'フォルダ存在=Falseであることを確認してから使用すること。
Public Function CreateFdr(ByVal psPath As String, _
            ByVal psFolder As String) As Boolean
On Error GoTo ErrProc
    CreateFdr = False
    Dim strWk As String
    Dim objFolder As Folder
    Set objFolder = Nothing
    
    If fso.FolderExists(psPath) Then
        strWk = AddYen(psPath) & psFolder
        Set objFolder = fso.CreateFolder(strWk)
        If Not objFolder Is Nothing Then
            CreateFdr = True
        End If
    End If

ExitProc:
    On Error Resume Next
    Set objFolder = Nothing
    Exit Function

ErrProc:
    Debug.Print Err.Number & ":" & Err.Description
    Resume ExitProc

End Function

'フォルダ存在確認
'引数：フォルダのフルパス
Public Function IsExistFdr(psFolder As String) As Boolean
    IsExistFdr = fso.FolderExists(psFolder)
End Function

'ファイル存在確認
'引数：ファイルのフルパス
Public Function IsExistFile(psFile As String) As Boolean
    IsExistFile = fso.FileExists(psFile)
End Function

'フォルダ一覧取得
'引数：対象フォルダ, フォルダ一覧
Public Function GetFolders(psPath As String, psList As CStrList) As Boolean
On Error GoTo ErrProc
    GetFolders = False
    Dim objFolder As Folder
    Set objFolder = Nothing

    Set mFolder = fso.GetFolder(psPath)
    Set mFolders = mFolder.SubFolders
    For Each objFolder In mFolders
        Call psList.addItem(objFolder.Path)
        ''''Debug.Print objFolder.Path
    Next
    GetFolders = True

ExitProc:
    Set objFolder = Nothing
    Exit Function

ErrProc:
    Debug.Print Err.Number & ":" & Err.Description
    Resume ExitProc
    
End Function

'ファイル一覧取得
'引数：対象フォルダ, ファイル一覧
Public Function GetFiles(psPath As String, psList As CStrList) As Boolean
On Error GoTo ErrProc
    GetFiles = False
    Dim objFile As File
    Set objFile = Nothing

    Set mFolder = fso.GetFolder(psPath)
    Set mFiles = mFolder.Files
    For Each objFile In mFiles
        Call psList.addItem(objFile.Path)
        ''''Debug.Print objFile.Path
    Next
    GetFiles = True

ExitProc:
    Set objFile = Nothing
    Exit Function

ErrProc:
    Debug.Print Err.Number & ":" & Err.Description
    Resume ExitProc
    
End Function

'１行書き込み
'引数：ファイルパス, String
Public Function WriteString(psPath As String, _
            psLine As String, _
            Optional pbAppend As Boolean = False _
            ) As Boolean
    
    WriteString = WriteStrList(psPath, psLine, , pbAppend)
    
End Function

'１行読み込み
'引数　：ファイルパス
'戻り値：１行文字列( "" なら失敗)
Public Function ReadString(psPath As String) As String
    Dim strLine As String
    
    If True = ReadStrList(psPath, strLine) Then
        ReadString = strLine
    Else
        ReadString = ""
    End If
    
End Function

'１行読み込み
'引数：ファイルパス, String
Public Function ReadString2(psPath As String, _
            psLine As String) As Boolean
    
    ReadString2 = ReadStrList(psPath, psLine)
    
End Function

'リスト書き込み
'引数：ファイルパス, List
Public Function WriteList(psPath As String, _
            paList As CStrList, _
            Optional pbAppend As Boolean = False _
            ) As Boolean
    
    WriteList = WriteStrList(psPath, , paList, pbAppend)
    
End Function

'リスト読み込み
'引数：ファイルパス, List
Public Function ReadList(psPath As String, _
            paList As CStrList) As Boolean
    
    ReadList = ReadStrList(psPath, , paList)
    
End Function
--------