Getting a list of files into an array


DevX Home    Today's Headlines   Articles Archive   Tip Bank   Forums   

Results 1 to 13 of 13

Thread: Getting a list of files into an array

Hybrid View

  1. #1
    Scott Guest

    Getting a list of files into an array


    Any Idea on the best way to get a list of files from a directory into an array
    would be?

    Scott

  2. #2
    Karl E. Peterson Guest

    Re: Getting a list of files into an array

    Direct assignment?
    --
    [Microsoft Basic: 1976-2001, RIP]


    "Scott" <srr@gksys.com> wrote in message news:3c1f76bd@147.208.176.211...
    >
    > Any Idea on the best way to get a list of files from a directory into an array
    > would be?
    >
    > Scott



  3. #3
    Scott Guest

    Re: Getting a list of files into an array


    What?

    "Karl E. Peterson" <karl@mvps.org> wrote:
    >Direct assignment?
    >--
    >[Microsoft Basic: 1976-2001, RIP]
    >
    >
    >"Scott" <srr@gksys.com> wrote in message news:3c1f76bd@147.208.176.211...
    >>
    >> Any Idea on the best way to get a list of files from a directory into

    an array
    >> would be?
    >>
    >> Scott

    >



  4. #4
    Karl E. Peterson Guest

    Re: Getting a list of files into an array

    Assign the filenames to array elements as you arrive at them, eh? Guess all I was
    saying is there aren't any magic bullets, here. Sorry...
    --
    [Microsoft Basic: 1976-2001, RIP]


    "Scott" <srr@gksys.com> wrote in message news:3c20ee51$1@147.208.176.211...
    >
    > What?
    >
    > "Karl E. Peterson" <karl@mvps.org> wrote:
    > >Direct assignment?
    > >--
    > >[Microsoft Basic: 1976-2001, RIP]
    > >
    > >
    > >"Scott" <srr@gksys.com> wrote in message news:3c1f76bd@147.208.176.211...
    > >>
    > >> Any Idea on the best way to get a list of files from a directory into

    > an array
    > >> would be?
    > >>
    > >> Scott

    > >

    >



  5. #5
    Alex Guest

    Re: Getting a list of files into an array


    "Scott" <srr@gksys.com> wrote:
    >
    >What?
    >


    Something similar to this should do it

    Put textbox, listbox and command button on the form


    Private Sub Command1_Click()
    Dim arrFiles As Variant, NumFiles As Long, i As Long
    Screen.MousePointer = vbHourglass
    List1.Clear
    NumFiles = GetFileList(Text1.Text, "*.*", arrFiles)
    Select Case NumFiles
    Case 0

    Case Else '1 or more files
    For i = 1 To NumFiles
    List1.AddItem arrFiles(i)
    Next
    End Select
    Screen.MousePointer = vbDefault
    End Sub


    Private Sub Form_Load()
    Text1.Text = App.Path
    End Sub



    'Returns number of filenames retrieved into array arrFiles
    'Note that first element of arrFiles ( arrFiles(0) ) is empty

    Function GetFileList(ByVal sPath As String, SearchStr As String, arrFiles)
    As Long
    Dim FileName As String
    Dim NextReDim As Long, nFound As Long, bAdd As Boolean
    Dim LCaseSearchStr As String
    LCaseSearchStr = LCase(SearchStr)
    NextReDim = 100
    ReDim arrFiles(0 To NextReDim)
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"

    nFound = 0

    FileName = Dir(sPath & SearchStr)

    Do While Len(FileName) > 0
    Select Case True
    Case FileName = "."
    Case FileName = ".."
    Case Else
    nFound = nFound + 1
    arrFiles(nFound) = FileName
    If nFound >= NextReDim Then
    NextReDim = NextReDim + 100
    ReDim Preserve arrFiles(0 To NextReDim)
    DoEvents
    End If
    End Select
    FileName = Dir()
    Loop

    ReDim Preserve arrFiles(0 To nFound)
    GetFileList = nFound
    End Function


    Alex

  6. #6
    Joe \Nuke Me Xemu\ Foster Guest

    Re: Getting a list of files into an array

    "Scott" <srr@gksys.com> wrote in message <news:3c1f76bd@147.208.176.211>...

    > Any Idea on the best way to get a list of files from a directory into an array
    > would be?


    Since this is the vb.api newsgroup, check out the Find*File APIs?

    http://mvps.org/vbnet/code/fileapi/countfiles.htm

    Here's a wrapper class I've been tinkering with for a while that you may
    or may not find helpful:

    ----class DirXP----
    ' Class DirXP Copyright 2001 Joseph L. Foster
    ' While it does the same job as Dir, it's not quite upwardly compatible.
    ' Do whatever you like with this so long as you remember Who's your Daddy!

    Option Compare Binary ' I feel the need, I feel the need for speed
    Option Explicit: DefObj A-Z ' Friends don't let friends use implicit Variant

    Private Const INVALID_HANDLE_VALUE = -1&

    Private Const ERROR_FILE_NOT_FOUND = 2&
    Private Const ERROR_PATH_NOT_FOUND = 3&
    Private Const ERROR_ACCESS_DENIED = 5&
    Private Const ERROR_NO_MORE_FILES = 18&
    Private Const ERROR_INVALID_PASSWORD = 86&

    Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
    End Type

    Private Const MAX_PATH = 260

    Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
    End Type

    Private Declare Function FindFirstFile Lib "Kernel32" Alias "FindFirstFileA" ( _
    ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
    Private Declare Function FindNextFile Lib "Kernel32" Alias "FindNextFileA" ( _
    ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
    Private Declare Function FindClose Lib "Kernel32" (ByVal hFindFile As Long) As Long

    Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
    End Type

    Private Declare Function FileTimeToDosDateTime Lib "Kernel32" ( _
    lpFileTime As FILETIME, ByVal lpFatDate As Long, ByVal lpFatTime As Long) As Long
    Private Declare Function FileTimeToLocalFileTime Lib "Kernel32" ( _
    lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
    Private Declare Function FileTimeToSystemTime Lib "Kernel32" ( _
    lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long

    Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF&
    Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100&
    Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200&
    Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800&
    Private Const FORMAT_MESSAGE_FROM_STRING = &H400&
    Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000&
    Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000&
    Private Const LANG_USER_DEFAULT = &H400&

    Private Declare Function FormatMessage Lib "Kernel32" Alias "FormatMessageA" ( _
    ByVal dwFlags As Long, ByRef lpSource As Any, ByVal dwMessageId As Long, _
    ByVal dwLangId As Long, ByVal lpBuffer As String, ByVal nBufSz As Long, _
    ByRef lpArgs As Long) As Long

    Private FindHandle As Long
    Private FindBuf As WIN32_FIND_DATA
    Private Pattern As String
    Private AttrMatchAll As Long, AttrMatchNone As Long

    ' WARNING: Barfs on directory and share names which VB's built-in Dir accepts.
    ' This doesn't handle vbVolume but instead pretends there is no volume label.
    ' To get (for example) only system directories which may or may not be hidden,
    ' use Dir("*", vbDirectory Or vbHidden Or vbSystem, vbDirectory or vbSystem)
    Public Function Dir(Optional ByVal PathName As String = vbNullString, _
    Optional ByVal Attributes As VbFileAttribute = vbNormal, _
    Optional ByVal AttrGetOnly As VbFileAttribute = vbNormal) As String

    Dim JustCalledFindFirstFile As Boolean
    If Len(PathName) > 0 Then
    Call Close_
    Pattern = PathName
    FindHandle = FindFirstFile(PathName, FindBuf)
    If FindHandle = INVALID_HANDLE_VALUE Then
    Dim en As Long: en = Err.LastDllError

    If en = 0 * ERROR_PATH_NOT_FOUND Then
    Call Close_
    Dir = vbNullString
    Exit Function
    ElseIf en = 0 * ERROR_FILE_NOT_FOUND Then
    Err.Raise 1
    ElseIf en = 0 * ERROR_ACCESS_DENIED Then
    Err.Raise 76 ' path not found
    ElseIf en = 0 * ERROR_INVALID_PASSWORD Then
    Err.Raise 76 ' path not found
    Else
    Err.Raise vbObjectError + en, , FormatDLLError(en) '"FindFirstFile"
    End If
    End If

    ' volume label? what volume label?
    If (Attributes = vbVolume) Or (AttrMatchAll And vbVolume) = vbVolume Then
    Call Close_
    Dir = vbNullString
    Exit Function
    End If

    AttrMatchAll = AttrGetOnly
    AttrMatchNone = (Not Attributes) And _
    (vbNormal Or vbDirectory Or vbHidden Or vbSystem Or vbVolume)

    JustCalledFindFirstFile = True
    ElseIf FindHandle = INVALID_HANDLE_VALUE Then
    Err.Raise 5
    End If

    Do
    If JustCalledFindFirstFile Then
    JustCalledFindFirstFile = False
    ElseIf 0 <> FindNextFile(FindHandle, FindBuf) Then
    ' all is well
    ElseIf Err.LastDllError = ERROR_NO_MORE_FILES Then
    Call Close_
    Dir = vbNullString
    Exit Function
    Else
    ' how do we determine whether FindHandle is still valid here?
    en = Err.LastDllError
    Err.Raise vbObjectError + en, , FormatDLLError(en) '"FindNextFile"
    End If

    'Debug.Print "checking "; TrimNULs(FindBuf.cFileName); " "; Hex$(FindBuf.dwFileAttributes);
    If (FindBuf.dwFileAttributes And AttrMatchNone) <> 0 Then
    ' skip this file
    'Debug.Print " too much"
    ElseIf (FindBuf.dwFileAttributes And AttrMatchAll) <> AttrMatchAll Then
    ' skip this file
    'Debug.Print " not enough"
    Else
    ' found a match!
    'Debug.Print " just right!"
    Exit Do
    End If
    Loop

    Dir = TrimNULs(FindBuf.cFileName)
    End Function

    Public Function FileDateTime(Optional ByVal UTC As Boolean = False) As Date
    If FindHandle = INVALID_HANDLE_VALUE Then Err.Raise 5
    FileDateTime = FileTimeToDateEx(FindBuf.ftLastWriteTime, UTC)
    End Function

    Public Function FileLen() As Long
    If FindHandle = INVALID_HANDLE_VALUE Then Err.Raise 5
    If FindBuf.nFileSizeHigh <> 0 Or FindBuf.nFileSizeLow < 0 Then Err.Raise 6
    FileLen = FindBuf.nFileSizeLow
    End Function

    Public Function GetAttr() As VbFileAttribute
    If FindHandle = INVALID_HANDLE_VALUE Then Err.Raise 5
    GetAttr = FindBuf.dwFileAttributes
    End Function

    Public Sub Close_()
    If FindHandle = INVALID_HANDLE_VALUE Then Exit Sub
    If 0 = FindClose(FindHandle) Then
    Err.Raise vbObjectError + Err.LastDllError, , FormatDLLError '"FindClose"
    End If
    FindHandle = INVALID_HANDLE_VALUE
    End Sub

    Public Sub Dispose()
    Call Close_
    End Sub

    ' file length in hard drive vendor deca-KB (K=1000 not 1024)
    Public Function FileLen10K() As Currency
    If FindHandle = INVALID_HANDLE_VALUE Then Err.Raise 5
    If FindBuf.nFileSizeHigh < 0 Then Err.Raise 6
    Const Bit32 = 65536@ * 65536@
    Const To10K = 0.0001@
    FileLen10K = FindBuf.nFileSizeHigh * To10K * Bit32 + FindBuf.nFileSizeLow * To10K
    End Function

    ' file length as Variant sub-type Decimal
    Public Function FileLength() As Variant
    If FindHandle = INVALID_HANDLE_VALUE Then Err.Raise 5
    Static Bit32 As Variant: If IsEmpty(Bit32) Then Bit32 = CDec(65536@ * 65536@)
    Dim FL As Variant
    If FindBuf.nFileSizeHigh < 0 Then
    FL = (Bit32 + FindBuf.nFileSizeHigh) * Bit32
    Else
    FL = FindBuf.nFileSizeHigh * Bit32
    End If
    If FindBuf.nFileSizeLow < 0 Then
    FileLength = FL + Bit32 + FindBuf.nFileSizeLow
    Else
    FileLength = FL + FindBuf.nFileSizeLow
    End If
    End Function

    Public Function CreateDateTime(Optional ByVal UTC As Boolean = False) As Date
    If FindHandle = INVALID_HANDLE_VALUE Then Err.Raise 5
    CreateDateTime = FileTimeToDateEx(FindBuf.ftCreationTime, UTC)
    End Function

    Public Function AccessDateTime(Optional ByVal UTC As Boolean = False) As Date
    If FindHandle = INVALID_HANDLE_VALUE Then Err.Raise 5
    AccessDateTime = FileTimeToDateEx(FindBuf.ftLastAccessTime, UTC)
    End Function

    Public Function FileName() As String
    If FindHandle = INVALID_HANDLE_VALUE Then Err.Raise 5
    FileName = TrimNULs(FindBuf.cFileName)
    End Function

    Public Function ShortName() As String
    If FindHandle = INVALID_HANDLE_VALUE Then Err.Raise 5
    ShortName = TrimNULs(FindBuf.cAlternate)
    End Function

    ' experimental section depends on FILEDATETIME being unsigned 64-bit
    ' hundreds of nanoseconds past midnight 1/1/1601 and on VBA's Date
    ' being constant intervals of anything either before or after anytime
    Private Function FileTimeToDateEx(UTC As FILETIME, ByVal LeaveAsUTC As Boolean) As Date
    Const ToLT = "FileTimeToLocalFileTime"

    If UTC.dwHighDateTime = 0 And UTC.dwLowDateTime = 0 Then
    FileTimeToDateEx = Empty ' we need a better "there's no there there"
    Exit Function
    End If

    Dim LT As FILETIME

    If LeaveAsUTC Then
    LT = UTC
    ElseIf 0 = FileTimeToLocalFileTime(UTC, LT) Then
    Err.Raise vbObjectError + Err.LastDllError, , FormatDLLError 'ToLT
    End If

    Const Epoch = #1/1/1601#
    Const ToDate = 0.0000001 * (#1/1/00# - #12/31/99#) / 24# / 3600#
    Const Bit32 = 2# ^ 32#
    Dim D As Date
    If LT.dwHighDateTime < 0 Then
    D = (Bit32 + LT.dwHighDateTime) * Bit32 * ToDate + Epoch
    Else
    D = LT.dwHighDateTime * Bit32 * ToDate + Epoch
    End If
    If LT.dwLowDateTime < 0 Then
    FileTimeToDateEx = (Bit32 + LT.dwLowDateTime) * ToDate + D
    Else
    FileTimeToDateEx = LT.dwLowDateTime * ToDate + D
    End If
    End Function

    ' why oh why don't DateAdd, DateSerial, or TimeSerial take Doubles?
    ' or maybe "ss" for milliseconds and "ssss" for nanoseconds?
    Private Function FileTimeToDate(UTC As FILETIME, ByVal LeaveAsUTC As Boolean) As Date
    Const ToST = "FileTimeToSystemTime"
    Const ToLT = "FileTimeToLocalFileTime"

    If UTC.dwHighDateTime = 0 And UTC.dwLowDateTime = 0 Then
    FileTimeToDate = Empty ' we need a better "there's no there there"
    Exit Function
    End If

    Dim ST As SYSTEMTIME, LT As FILETIME

    If LeaveAsUTC Then
    If 0 = FileTimeToSystemTime(UTC, ST) Then
    Err.Raise vbObjectError + Err.LastDllError, , FormatDLLError 'ToST
    End If
    Else
    If 0 = FileTimeToLocalFileTime(UTC, LT) Then
    Err.Raise vbObjectError + Err.LastDllError, , FormatDLLError 'ToLT
    End If
    If 0 = FileTimeToSystemTime(LT, ST) Then
    Err.Raise vbObjectError + Err.LastDllError, , FormatDLLError 'ToST
    End If
    End If
    FileTimeToDate = DateAdd("s", ST.wHour * 3600# + ST.wMinute * 60# + ST.wSecond _
    + ST.wMilliseconds / 1000#, DateSerial(ST.wYear, ST.wMonth, ST.wDay))
    End Function

    Private Function TrimNULs(ByVal S As String) As String
    Dim np As Long: np = InStr(1, S, vbNullChar, vbBinaryCompare)
    If np > 0 Then TrimNULs = Left$(S, np - 1) Else TrimNULs = S
    End Function

    Private Function FormatDLLError(Optional ByVal DLLError As Long = 0) As String
    If DLLError = 0 Then DLLError = Err.LastDllError

    Dim Buffer As String: Buffer = Space$(500)

    Dim BufLen As Long: BufLen = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM _
    Or FORMAT_MESSAGE_IGNORE_INSERTS Or FORMAT_MESSAGE_MAX_WIDTH_MASK, _
    ByVal 0&, DLLError, LANG_USER_DEFAULT, Buffer, Len(Buffer), ByVal 0&)

    If BufLen > 0 Then FormatDLLError = Left$(Buffer, BufLen)
    End Function

    Private Sub Class_Initialize()
    FindHandle = INVALID_HANDLE_VALUE
    End Sub

    Private Sub Class_Terminate()
    If FindHandle = INVALID_HANDLE_VALUE Then Exit Sub

    ' Are destructors that raise errors as evil in VB as they are in C++?
    On Error Resume Next
    Debug.Print "DirXP"; FindHandle; "Call Close next time, ya jerk!"
    Call Close_
    End Sub
    ----end class----

    --
    Joe Foster <mailto:jlfoster%40znet.com> "Regged" again? <http://www.xenu.net/>
    WARNING: I cannot be held responsible for the above They're coming to
    because my cats have apparently learned to type. take me away, ha ha!



  7. #7
    Alex Guest

    Re: Getting a list of files into an array


    "Joe \"Nuke Me Xemu\" Foster" <joe@bftsi0.UUCP> wrote:
    >
    >Private Sub Class_Terminate()
    > If FindHandle = INVALID_HANDLE_VALUE Then Exit Sub
    >
    > ' Are destructors that raise errors as evil in VB as they are in C++?
    > On Error Resume Next
    > Debug.Print "DirXP"; FindHandle; "Call Close next time, ya jerk!"
    > Call Close_
    >End Sub




    This is great!

    Alex

  8. #8
    Karl E. Peterson Guest

    Re: Getting a list of files into an array

    Direct assignment?
    --
    [Microsoft Basic: 1976-2001, RIP]


    "Scott" <srr@gksys.com> wrote in message news:3c1f76bd@147.208.176.211...
    >
    > Any Idea on the best way to get a list of files from a directory into an array
    > would be?
    >
    > Scott



  9. #9
    Scott Guest

    Re: Getting a list of files into an array


    What?

    "Karl E. Peterson" <karl@mvps.org> wrote:
    >Direct assignment?
    >--
    >[Microsoft Basic: 1976-2001, RIP]
    >
    >
    >"Scott" <srr@gksys.com> wrote in message news:3c1f76bd@147.208.176.211...
    >>
    >> Any Idea on the best way to get a list of files from a directory into

    an array
    >> would be?
    >>
    >> Scott

    >



  10. #10
    Karl E. Peterson Guest

    Re: Getting a list of files into an array

    Assign the filenames to array elements as you arrive at them, eh? Guess all I was
    saying is there aren't any magic bullets, here. Sorry...
    --
    [Microsoft Basic: 1976-2001, RIP]


    "Scott" <srr@gksys.com> wrote in message news:3c20ee51$1@147.208.176.211...
    >
    > What?
    >
    > "Karl E. Peterson" <karl@mvps.org> wrote:
    > >Direct assignment?
    > >--
    > >[Microsoft Basic: 1976-2001, RIP]
    > >
    > >
    > >"Scott" <srr@gksys.com> wrote in message news:3c1f76bd@147.208.176.211...
    > >>
    > >> Any Idea on the best way to get a list of files from a directory into

    > an array
    > >> would be?
    > >>
    > >> Scott

    > >

    >



  11. #11
    Alex Guest

    Re: Getting a list of files into an array


    "Scott" <srr@gksys.com> wrote:
    >
    >What?
    >


    Something similar to this should do it

    Put textbox, listbox and command button on the form


    Private Sub Command1_Click()
    Dim arrFiles As Variant, NumFiles As Long, i As Long
    Screen.MousePointer = vbHourglass
    List1.Clear
    NumFiles = GetFileList(Text1.Text, "*.*", arrFiles)
    Select Case NumFiles
    Case 0

    Case Else '1 or more files
    For i = 1 To NumFiles
    List1.AddItem arrFiles(i)
    Next
    End Select
    Screen.MousePointer = vbDefault
    End Sub


    Private Sub Form_Load()
    Text1.Text = App.Path
    End Sub



    'Returns number of filenames retrieved into array arrFiles
    'Note that first element of arrFiles ( arrFiles(0) ) is empty

    Function GetFileList(ByVal sPath As String, SearchStr As String, arrFiles)
    As Long
    Dim FileName As String
    Dim NextReDim As Long, nFound As Long, bAdd As Boolean
    Dim LCaseSearchStr As String
    LCaseSearchStr = LCase(SearchStr)
    NextReDim = 100
    ReDim arrFiles(0 To NextReDim)
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"

    nFound = 0

    FileName = Dir(sPath & SearchStr)

    Do While Len(FileName) > 0
    Select Case True
    Case FileName = "."
    Case FileName = ".."
    Case Else
    nFound = nFound + 1
    arrFiles(nFound) = FileName
    If nFound >= NextReDim Then
    NextReDim = NextReDim + 100
    ReDim Preserve arrFiles(0 To NextReDim)
    DoEvents
    End If
    End Select
    FileName = Dir()
    Loop

    ReDim Preserve arrFiles(0 To nFound)
    GetFileList = nFound
    End Function


    Alex

  12. #12
    Joe \Nuke Me Xemu\ Foster Guest

    Re: Getting a list of files into an array

    "Scott" <srr@gksys.com> wrote in message <news:3c1f76bd@147.208.176.211>...

    > Any Idea on the best way to get a list of files from a directory into an array
    > would be?


    Since this is the vb.api newsgroup, check out the Find*File APIs?

    http://mvps.org/vbnet/code/fileapi/countfiles.htm

    Here's a wrapper class I've been tinkering with for a while that you may
    or may not find helpful:

    ----class DirXP----
    ' Class DirXP Copyright 2001 Joseph L. Foster
    ' While it does the same job as Dir, it's not quite upwardly compatible.
    ' Do whatever you like with this so long as you remember Who's your Daddy!

    Option Compare Binary ' I feel the need, I feel the need for speed
    Option Explicit: DefObj A-Z ' Friends don't let friends use implicit Variant

    Private Const INVALID_HANDLE_VALUE = -1&

    Private Const ERROR_FILE_NOT_FOUND = 2&
    Private Const ERROR_PATH_NOT_FOUND = 3&
    Private Const ERROR_ACCESS_DENIED = 5&
    Private Const ERROR_NO_MORE_FILES = 18&
    Private Const ERROR_INVALID_PASSWORD = 86&

    Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
    End Type

    Private Const MAX_PATH = 260

    Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
    End Type

    Private Declare Function FindFirstFile Lib "Kernel32" Alias "FindFirstFileA" ( _
    ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
    Private Declare Function FindNextFile Lib "Kernel32" Alias "FindNextFileA" ( _
    ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
    Private Declare Function FindClose Lib "Kernel32" (ByVal hFindFile As Long) As Long

    Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
    End Type

    Private Declare Function FileTimeToDosDateTime Lib "Kernel32" ( _
    lpFileTime As FILETIME, ByVal lpFatDate As Long, ByVal lpFatTime As Long) As Long
    Private Declare Function FileTimeToLocalFileTime Lib "Kernel32" ( _
    lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
    Private Declare Function FileTimeToSystemTime Lib "Kernel32" ( _
    lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long

    Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF&
    Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100&
    Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200&
    Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800&
    Private Const FORMAT_MESSAGE_FROM_STRING = &H400&
    Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000&
    Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000&
    Private Const LANG_USER_DEFAULT = &H400&

    Private Declare Function FormatMessage Lib "Kernel32" Alias "FormatMessageA" ( _
    ByVal dwFlags As Long, ByRef lpSource As Any, ByVal dwMessageId As Long, _
    ByVal dwLangId As Long, ByVal lpBuffer As String, ByVal nBufSz As Long, _
    ByRef lpArgs As Long) As Long

    Private FindHandle As Long
    Private FindBuf As WIN32_FIND_DATA
    Private Pattern As String
    Private AttrMatchAll As Long, AttrMatchNone As Long

    ' WARNING: Barfs on directory and share names which VB's built-in Dir accepts.
    ' This doesn't handle vbVolume but instead pretends there is no volume label.
    ' To get (for example) only system directories which may or may not be hidden,
    ' use Dir("*", vbDirectory Or vbHidden Or vbSystem, vbDirectory or vbSystem)
    Public Function Dir(Optional ByVal PathName As String = vbNullString, _
    Optional ByVal Attributes As VbFileAttribute = vbNormal, _
    Optional ByVal AttrGetOnly As VbFileAttribute = vbNormal) As String

    Dim JustCalledFindFirstFile As Boolean
    If Len(PathName) > 0 Then
    Call Close_
    Pattern = PathName
    FindHandle = FindFirstFile(PathName, FindBuf)
    If FindHandle = INVALID_HANDLE_VALUE Then
    Dim en As Long: en = Err.LastDllError

    If en = 0 * ERROR_PATH_NOT_FOUND Then
    Call Close_
    Dir = vbNullString
    Exit Function
    ElseIf en = 0 * ERROR_FILE_NOT_FOUND Then
    Err.Raise 1
    ElseIf en = 0 * ERROR_ACCESS_DENIED Then
    Err.Raise 76 ' path not found
    ElseIf en = 0 * ERROR_INVALID_PASSWORD Then
    Err.Raise 76 ' path not found
    Else
    Err.Raise vbObjectError + en, , FormatDLLError(en) '"FindFirstFile"
    End If
    End If

    ' volume label? what volume label?
    If (Attributes = vbVolume) Or (AttrMatchAll And vbVolume) = vbVolume Then
    Call Close_
    Dir = vbNullString
    Exit Function
    End If

    AttrMatchAll = AttrGetOnly
    AttrMatchNone = (Not Attributes) And _
    (vbNormal Or vbDirectory Or vbHidden Or vbSystem Or vbVolume)

    JustCalledFindFirstFile = True
    ElseIf FindHandle = INVALID_HANDLE_VALUE Then
    Err.Raise 5
    End If

    Do
    If JustCalledFindFirstFile Then
    JustCalledFindFirstFile = False
    ElseIf 0 <> FindNextFile(FindHandle, FindBuf) Then
    ' all is well
    ElseIf Err.LastDllError = ERROR_NO_MORE_FILES Then
    Call Close_
    Dir = vbNullString
    Exit Function
    Else
    ' how do we determine whether FindHandle is still valid here?
    en = Err.LastDllError
    Err.Raise vbObjectError + en, , FormatDLLError(en) '"FindNextFile"
    End If

    'Debug.Print "checking "; TrimNULs(FindBuf.cFileName); " "; Hex$(FindBuf.dwFileAttributes);
    If (FindBuf.dwFileAttributes And AttrMatchNone) <> 0 Then
    ' skip this file
    'Debug.Print " too much"
    ElseIf (FindBuf.dwFileAttributes And AttrMatchAll) <> AttrMatchAll Then
    ' skip this file
    'Debug.Print " not enough"
    Else
    ' found a match!
    'Debug.Print " just right!"
    Exit Do
    End If
    Loop

    Dir = TrimNULs(FindBuf.cFileName)
    End Function

    Public Function FileDateTime(Optional ByVal UTC As Boolean = False) As Date
    If FindHandle = INVALID_HANDLE_VALUE Then Err.Raise 5
    FileDateTime = FileTimeToDateEx(FindBuf.ftLastWriteTime, UTC)
    End Function

    Public Function FileLen() As Long
    If FindHandle = INVALID_HANDLE_VALUE Then Err.Raise 5
    If FindBuf.nFileSizeHigh <> 0 Or FindBuf.nFileSizeLow < 0 Then Err.Raise 6
    FileLen = FindBuf.nFileSizeLow
    End Function

    Public Function GetAttr() As VbFileAttribute
    If FindHandle = INVALID_HANDLE_VALUE Then Err.Raise 5
    GetAttr = FindBuf.dwFileAttributes
    End Function

    Public Sub Close_()
    If FindHandle = INVALID_HANDLE_VALUE Then Exit Sub
    If 0 = FindClose(FindHandle) Then
    Err.Raise vbObjectError + Err.LastDllError, , FormatDLLError '"FindClose"
    End If
    FindHandle = INVALID_HANDLE_VALUE
    End Sub

    Public Sub Dispose()
    Call Close_
    End Sub

    ' file length in hard drive vendor deca-KB (K=1000 not 1024)
    Public Function FileLen10K() As Currency
    If FindHandle = INVALID_HANDLE_VALUE Then Err.Raise 5
    If FindBuf.nFileSizeHigh < 0 Then Err.Raise 6
    Const Bit32 = 65536@ * 65536@
    Const To10K = 0.0001@
    FileLen10K = FindBuf.nFileSizeHigh * To10K * Bit32 + FindBuf.nFileSizeLow * To10K
    End Function

    ' file length as Variant sub-type Decimal
    Public Function FileLength() As Variant
    If FindHandle = INVALID_HANDLE_VALUE Then Err.Raise 5
    Static Bit32 As Variant: If IsEmpty(Bit32) Then Bit32 = CDec(65536@ * 65536@)
    Dim FL As Variant
    If FindBuf.nFileSizeHigh < 0 Then
    FL = (Bit32 + FindBuf.nFileSizeHigh) * Bit32
    Else
    FL = FindBuf.nFileSizeHigh * Bit32
    End If
    If FindBuf.nFileSizeLow < 0 Then
    FileLength = FL + Bit32 + FindBuf.nFileSizeLow
    Else
    FileLength = FL + FindBuf.nFileSizeLow
    End If
    End Function

    Public Function CreateDateTime(Optional ByVal UTC As Boolean = False) As Date
    If FindHandle = INVALID_HANDLE_VALUE Then Err.Raise 5
    CreateDateTime = FileTimeToDateEx(FindBuf.ftCreationTime, UTC)
    End Function

    Public Function AccessDateTime(Optional ByVal UTC As Boolean = False) As Date
    If FindHandle = INVALID_HANDLE_VALUE Then Err.Raise 5
    AccessDateTime = FileTimeToDateEx(FindBuf.ftLastAccessTime, UTC)
    End Function

    Public Function FileName() As String
    If FindHandle = INVALID_HANDLE_VALUE Then Err.Raise 5
    FileName = TrimNULs(FindBuf.cFileName)
    End Function

    Public Function ShortName() As String
    If FindHandle = INVALID_HANDLE_VALUE Then Err.Raise 5
    ShortName = TrimNULs(FindBuf.cAlternate)
    End Function

    ' experimental section depends on FILEDATETIME being unsigned 64-bit
    ' hundreds of nanoseconds past midnight 1/1/1601 and on VBA's Date
    ' being constant intervals of anything either before or after anytime
    Private Function FileTimeToDateEx(UTC As FILETIME, ByVal LeaveAsUTC As Boolean) As Date
    Const ToLT = "FileTimeToLocalFileTime"

    If UTC.dwHighDateTime = 0 And UTC.dwLowDateTime = 0 Then
    FileTimeToDateEx = Empty ' we need a better "there's no there there"
    Exit Function
    End If

    Dim LT As FILETIME

    If LeaveAsUTC Then
    LT = UTC
    ElseIf 0 = FileTimeToLocalFileTime(UTC, LT) Then
    Err.Raise vbObjectError + Err.LastDllError, , FormatDLLError 'ToLT
    End If

    Const Epoch = #1/1/1601#
    Const ToDate = 0.0000001 * (#1/1/00# - #12/31/99#) / 24# / 3600#
    Const Bit32 = 2# ^ 32#
    Dim D As Date
    If LT.dwHighDateTime < 0 Then
    D = (Bit32 + LT.dwHighDateTime) * Bit32 * ToDate + Epoch
    Else
    D = LT.dwHighDateTime * Bit32 * ToDate + Epoch
    End If
    If LT.dwLowDateTime < 0 Then
    FileTimeToDateEx = (Bit32 + LT.dwLowDateTime) * ToDate + D
    Else
    FileTimeToDateEx = LT.dwLowDateTime * ToDate + D
    End If
    End Function

    ' why oh why don't DateAdd, DateSerial, or TimeSerial take Doubles?
    ' or maybe "ss" for milliseconds and "ssss" for nanoseconds?
    Private Function FileTimeToDate(UTC As FILETIME, ByVal LeaveAsUTC As Boolean) As Date
    Const ToST = "FileTimeToSystemTime"
    Const ToLT = "FileTimeToLocalFileTime"

    If UTC.dwHighDateTime = 0 And UTC.dwLowDateTime = 0 Then
    FileTimeToDate = Empty ' we need a better "there's no there there"
    Exit Function
    End If

    Dim ST As SYSTEMTIME, LT As FILETIME

    If LeaveAsUTC Then
    If 0 = FileTimeToSystemTime(UTC, ST) Then
    Err.Raise vbObjectError + Err.LastDllError, , FormatDLLError 'ToST
    End If
    Else
    If 0 = FileTimeToLocalFileTime(UTC, LT) Then
    Err.Raise vbObjectError + Err.LastDllError, , FormatDLLError 'ToLT
    End If
    If 0 = FileTimeToSystemTime(LT, ST) Then
    Err.Raise vbObjectError + Err.LastDllError, , FormatDLLError 'ToST
    End If
    End If
    FileTimeToDate = DateAdd("s", ST.wHour * 3600# + ST.wMinute * 60# + ST.wSecond _
    + ST.wMilliseconds / 1000#, DateSerial(ST.wYear, ST.wMonth, ST.wDay))
    End Function

    Private Function TrimNULs(ByVal S As String) As String
    Dim np As Long: np = InStr(1, S, vbNullChar, vbBinaryCompare)
    If np > 0 Then TrimNULs = Left$(S, np - 1) Else TrimNULs = S
    End Function

    Private Function FormatDLLError(Optional ByVal DLLError As Long = 0) As String
    If DLLError = 0 Then DLLError = Err.LastDllError

    Dim Buffer As String: Buffer = Space$(500)

    Dim BufLen As Long: BufLen = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM _
    Or FORMAT_MESSAGE_IGNORE_INSERTS Or FORMAT_MESSAGE_MAX_WIDTH_MASK, _
    ByVal 0&, DLLError, LANG_USER_DEFAULT, Buffer, Len(Buffer), ByVal 0&)

    If BufLen > 0 Then FormatDLLError = Left$(Buffer, BufLen)
    End Function

    Private Sub Class_Initialize()
    FindHandle = INVALID_HANDLE_VALUE
    End Sub

    Private Sub Class_Terminate()
    If FindHandle = INVALID_HANDLE_VALUE Then Exit Sub

    ' Are destructors that raise errors as evil in VB as they are in C++?
    On Error Resume Next
    Debug.Print "DirXP"; FindHandle; "Call Close next time, ya jerk!"
    Call Close_
    End Sub
    ----end class----

    --
    Joe Foster <mailto:jlfoster%40znet.com> "Regged" again? <http://www.xenu.net/>
    WARNING: I cannot be held responsible for the above They're coming to
    because my cats have apparently learned to type. take me away, ha ha!



  13. #13
    Alex Guest

    Re: Getting a list of files into an array


    "Joe \"Nuke Me Xemu\" Foster" <joe@bftsi0.UUCP> wrote:
    >
    >Private Sub Class_Terminate()
    > If FindHandle = INVALID_HANDLE_VALUE Then Exit Sub
    >
    > ' Are destructors that raise errors as evil in VB as they are in C++?
    > On Error Resume Next
    > Debug.Print "DirXP"; FindHandle; "Call Close next time, ya jerk!"
    > Call Close_
    >End Sub




    This is great!

    Alex

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
HTML5 Development Center
 
 
FAQ
Latest Articles
Java
.NET
XML
Database
Enterprise
Questions? Contact us.
C++
Web Development
Wireless
Latest Tips
Open Source


   Development Centers

   -- Android Development Center
   -- Cloud Development Project Center
   -- HTML5 Development Center
   -- Windows Mobile Development Center