FileAccess

使い方

TODO: 使用例を記述

コード

Option Explicit

Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal Filename As String, FindFileData As WIN32_FIND_DATA) As Long
Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal FindFile As Long, FindFileData As WIN32_FIND_DATA) As Long
Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal Filename As String) As Long
Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

Public Const MAX_PATH = 260
Public Const MAXDWORD = &HFFFF
Public Const INVALID_HANDLE_VALUE = -1
Public Const FILE_ATTRIBUTE_READONLY = &H1
Public Const FILE_ATTRIBUTE_HIDDEN = &H2
Public Const FILE_ATTRIBUTE_SYSTEM = &H4
Public Const FILE_ATTRIBUTE_DIRECTORY = &H10
Public Const FILE_ATTRIBUTE_ARCHIVE = &H20
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const FILE_ATTRIBUTE_TEMPORARY = &H100

Type FILETIME
    LowDateTime As Long
    HighDateTime As Long
End Type

Type WIN32_FIND_DATA
    FileAttributes As Long
    CreationTime As FILETIME
    LastAccessTime As FILETIME
    LastWriteTime As FILETIME
    FileSizeHigh As Long
    FileSizeLow As Long
    Reserved0 As Long
    Reserved1 As Long
    Filename As String * MAX_PATH
    Alternate As String * 14
End Type

' ディレクトリ一覧を取得する
Public Function GetDirs(ByVal Path As String, ByVal Pattern As String, Optional ByVal Recursive As Boolean = False) As String()

    Dim DirCount As Long
    Dim Dirs() As String
    
    DirCount = 0
    ReDim Dirs(31)
    
    Call GetDirs_(DirCount, Dirs, Path, Pattern, Recursive)
    If DirCount = 0 Then
        ReDim Dirs(0)
    Else
        ReDim Preserve Dirs(DirCount - 1)
    End If
    
    GetDirs = Dirs

End Function

' ディレクトリ一覧を取得する
Private Function GetDirs_(ByRef DirCount As Long, ByRef Dirs() As String, ByVal Path As String, ByVal Pattern As String, ByVal Recursive As Boolean)

    Dim Ret As Long
    Dim Handle As Long
    Dim FindData As WIN32_FIND_DATA
    Dim Dir As String
    
    If Right$(Path, 1) <> "\" Then Path = Path & "\"
    
    ' ディレクトリ一覧を取得する
    Handle = FindFirstFile(Path & Pattern, FindData)
    If Handle <> INVALID_HANDLE_VALUE Then
        Do
            Dir = StripNulls(FindData.Filename)
            If (Dir <> ".") And (Dir <> "..") Then
                If GetFileAttributes(Path & Dir) And FILE_ATTRIBUTE_DIRECTORY Then
                    ' ディレクトリ追加
                    Dirs(DirCount) = Path & Dir
                    
                    ' カウントアップと配列調整
                    DirCount = DirCount + 1
                    If DirCount > UBound(Dirs) Then
                        ReDim Preserve Dirs(DirCount * 2 - 1)
                    End If
                    
                    ' 再帰探索
                    If Recursive Then
                        Call GetDirs_(DirCount, Dirs, Path & Dir, Pattern, Recursive)
                    End If
                End If
            End If
            Ret = FindNextFile(Handle, FindData)
        Loop While Ret
        Ret = FindClose(Handle)
    End If

End Function

' ファイル一覧を取得する
Public Function GetFiles(ByVal Path As String, ByVal Pattern As String, Optional ByVal Recursive As Boolean = False) As String()

    Dim FileCount As Long
    Dim Files() As String
    
    FileCount = 0
    ReDim Files(31)
    
    Call GetFiles_(FileCount, Files, Path, Pattern, Recursive)
    If FileCount = 0 Then
        ReDim Files(0)
    Else
        ReDim Preserve Files(FileCount - 1)
    End If
    
    GetFiles = Files

End Function

' ファイル一覧を取得する
Private Function GetFiles_(ByRef FileCount As Long, ByRef Files() As String, ByVal Path As String, ByVal Pattern As String, ByVal Recursive As Boolean)

    Dim Ret As Long
    Dim Handle As Long
    Dim FindData As WIN32_FIND_DATA
    Dim File As String
    
    If Right$(Path, 1) <> "\" Then Path = Path & "\"
    
    ' ディレクトリ一覧を取得する
    Handle = FindFirstFile(Path & "*", FindData)
    If Handle <> INVALID_HANDLE_VALUE Then
        Do
            File = StripNulls(FindData.Filename)
            If (File <> ".") And (File <> "..") Then
                If GetFileAttributes(Path & File) And FILE_ATTRIBUTE_DIRECTORY Then
                    ' 再帰探索
                    If Recursive Then
                        Call GetFiles_(FileCount, Files, Path & File, Pattern, Recursive)
                    End If
                End If
            End If
            Ret = FindNextFile(Handle, FindData)
        Loop While Ret
        Ret = FindClose(Handle)
    End If
    
    ' ファイル一覧を取得する
    Handle = FindFirstFile(Path & Pattern, FindData)
    If Handle <> INVALID_HANDLE_VALUE Then
        Do
            File = StripNulls(FindData.Filename)
            If (File <> ".") And (File <> "..") Then
                If Not GetFileAttributes(Path & File) And FILE_ATTRIBUTE_DIRECTORY Then
                    ' ファイル追加
                    Files(FileCount) = Path & File
                    
                    ' カウントアップと配列調整
                    FileCount = FileCount + 1
                    If FileCount > UBound(Files) Then
                        ReDim Preserve Files(FileCount * 2 - 1)
                    End If
                End If
            End If
            Ret = FindNextFile(Handle, FindData)
        Loop While Ret
        Ret = FindClose(Handle)
    End If

End Function

' ファイル一覧を取得する
Public Function FindFiles(ByVal Path As String, ByVal Pattern As String, ByVal DirCount As Integer, ByVal FileCount As Integer) As Long

    Dim DirName As String
    Dim Filename As String
    Dim Dirs() As String
    Dim Files() As String
    Dim SearchHandle As Long
    Dim WFD As WIN32_FIND_DATA
    Dim Cont As Integer
    
    If Right$(Path, 1) <> "\" Then Path = Path & "\"
    
    DirCount = 0
    FileCount = 0
    
    ReDim Dirs(31)
    ReDim Files(31)
    
    ' ディレクトリ一覧を取得する
    SearchHandle = FindFirstFile(Path & "*", WFD)
    If SearchHandle <> INVALID_HANDLE_VALUE Then
        Cont = True
        Do While Cont
            DirName = StripNulls(WFD.Filename)
            If (DirName <> ".") And (DirName <> "..") Then
                If GetFileAttributes(Path & DirName) And FILE_ATTRIBUTE_DIRECTORY Then
                    Dirs(Dir) = DirName
                    DirCount = DirCount + 1
                    If DirCount > UBound(Dirs) Then
                        ReDim Preserve Dirs(DirCount * 2 - 1)
                    End If
                End If
            End If
            Cont = FindNextFile(SearchHandle, WFD)
        Loop
        Cont = FindClose(SearchHandle)
    End If
    If DirCount = 0 Then
        ReDim Dirs(0)
    Else
        ReDim Preserve Dirs(DirCount - 1)
    End If

   ' ファイル一覧を取得する
    SearchHandle = FindFirstFile(Path & Pattern, WFD)
    Cont = True
    If SearchHandle <> INVALID_HANDLE_VALUE Then
        While Cont
            Filename = StripNulls(WFD.Filename)
            If (Filename <> ".") And (Filename <> "..") And ((GetFileAttributes(Path & Filename) And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY) Then
                FindFiles = FindFiles + (WFD.FileSizeHigh * MAXDWORD) + WFD.FileSizeLow
                Files(FileCount) = Path & Filename
                FileCount = FileCount + 1
                If FileCount > UBound(Files) Then
                    ReDim Preserve Files(FileCount * 2 - 1)
                End If
            End If
            Cont = FindNextFile(SearchHandle, WFD)
        Wend
        Cont = FindClose(SearchHandle)
    End If
    If FileCount = 0 Then
        ReDim Files(0)
    Else
        ReDim Preserve Files(FileCount - 1)
    End If

    ' ディレクトリを再帰的に探索する
    Dim i As Long
    If DirCount > 0 Then
        For i = 0 To UBound(Dirs)
            FindFiles = FindFiles + FindFiles(Path & Dirs(i) & "\", Pattern, DirCount, FileCount)
        Next
    End If

End Function

' UTF8 の場合 True を返す
Public Function IsUTF8(ByVal Filename As String) As Boolean

    On Error GoTo ErrorField

    Dim Filenumber As Integer
    Filenumber = FreeFile
    
    Dim Bytes(2) As Byte
    Open Filename For Binary Access Read As #Filenumber
        Get #Filenumber, 1, Bytes
    Close #Filenumber
    
    IsUTF8 = (Bytes(0) = &HEF And Bytes(1) = &HBB And Bytes(2) = &HBF)
    Exit Function
    
ErrorField:
    IsUTF8 = False

End Function

' テキストを読み込む
Public Function LoadText(ByVal Filename As String, Optional ByVal Charset As String = "UNICODE") As String

    Dim Stream As New ADODB.Stream

    Stream.Open
    Stream.Type = adTypeText
    Stream.Charset = Charset
    Stream.LoadFromFile Filename
    LoadText = Stream.ReadText(adReadAll)
    
    Stream.Close
    Set Stream = Nothing

End Function

' 行単位の文字列配列を返す
Public Function LoadLines(ByVal Filename As String, Optional ByVal Charset As String = "UNICODE") As String()

    Dim Text As String
    Text = LoadText(Filename, Charset)
    Text = Replace(Text, vbCrLf, vbLf)
    Text = Replace(Text, vbCr, vbLf)
    LoadLines = Split(Text, vbLf)

End Function

' テキストを書き込む
Public Function SaveText(ByVal Filename As String, ByRef Text As String, Optional ByVal Charset As String = "UNICODE") As Boolean

    Dim Stream As New ADODB.Stream
    
    Stream.Open
    Stream.Type = adTypeText
    Stream.Charset = Charset
    Stream.WriteText Text
    Stream.SaveToFile Filename, adSaveCreateOverWrite
    
    Stream.Close
    Set Stream = Nothing

End Function

' 行単位の文字列配列を書き込む
Public Function SaveLines(ByVal Filename As String, ByRef Lines() As String, Optional ByVal Charset As String = "UNICODE") As Boolean
    
    Dim Stream As New ADODB.Stream
    
    Stream.Open
    Stream.Type = adTypeText
    Stream.Charset = Charset
    
    Dim i As Long
    For i = LBound(Lines) To UBound(Lines)
        Stream.WriteText Lines(i) & vbCrLf
    Next
    
    Stream.SaveToFile Filename, adSaveCreateOverWrite
    
    Stream.Close
    Set Stream = Nothing

End Function

' テキストを開く
Public Function ViewText(ByVal Filename As String, Optional ByVal Program As String = "notepad")

    Call Shell(Program & " " & Filename, vbNormalFocus)

End Function

' Null文字以降除去
Public Function StripNulls(ByVal Str As String) As String
    
    If InStr(Str, Chr(0)) > 0 Then
        Str = Left$(Str, InStr(Str, Chr(0)) - 1)
    End If
    StripNulls = Str

End Function

  • 最終更新:2015-10-01 15:48:13

このWIKIを編集するにはパスワード入力が必要です

認証パスワード