Getting a list of files into an array

[Scott]

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

Scott

[Karl E. Peterson]

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

[Karl E. Peterson]

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

[Scott]

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
>

[Scott]

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
>

[Karl E. Peterson]

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
> >
>

[Karl E. Peterson]

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
> >
>

[Alex]

"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

[Alex]

"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

[Joe \Nuke Me Xemu\ Foster]

"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!

[Joe \Nuke Me Xemu\ Foster]

"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!

[Alex]

"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

[Alex]

"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