Phil said:
Hi Dirk,
Yes, I would love to have the code then I can decide which way to go.
Okay. This particular form is called "frmFileList", and it has three
text boxes ...
txtFolder - in form header section
txtPattern - in detail section.
Default Value property = "*.*"
txtAttributes - in form detail section, but invisible.
Default Value property = 0.
.... a big list box ...
lstFiles - to display the list of files
.... and two command buttons at the bottom ...
cmdOK - caption "OK" - to approve the selected file and hide the
form
cmdClose - caption "Cancel" - to close the form.
OpenArgs:
-----------
The form expects to be opened in dialog mode, with arguments passed via
the OpenArgs argument of the DoCmd.OpenForm method. The argument string
should be composed of optional "keyword=vaue" pairs, separated by the
pipe character "|". All keywords, and the OpenArgs string itself, are
optional. Supported keywords are:
Folder=<folder path>
Path to the folder to be listed, with no trailing "\".
Default is the system's current directory.
Caption=<text for form caption>
Text to be displayed as the caption of the form.
Default is the form's Caption property.
Pattern=<matching pattern for files to be listed>
Pattern (as recognized by the Dir function) that the names
of the files to be listed must match.
Default is "*.*".
Attributes=<required file attributes>
Attributes (as recognized by the Dir function) that the
files to be listed must match.
Default is 0 (normal files).
ChangeFolder=<True or False, -1 or 0>
Controls whether the user is allowed to change
the folder.
Default is 0 (False).
Limits:
------
This form uses a statically sized array of 1000 files. Therefore it
will not list more than 1000 files in a folder. You can increase that
limit if you need to, or set it up to dynamically resize the array.
------ start of code for form module ------
Option Compare Database
Option Explicit
Function FillFileList( _
fld As Control, _
ID As Variant, _
row As Variant, _
col As Variant, _
code As Variant) _
As Variant
Static avarFiles(1000) As Variant
Static intEntries As Integer
Dim ReturnVal As Variant
ReturnVal = Null
Select Case code
Case acLBInitialize ' Initialize.
intEntries = 0
avarFiles(intEntries) = _
Dir(Me.txtFolder & "\" & Nz(Me.txtPattern, "*.*"), _
CLng(Me.txtAttributes))
Do Until avarFiles(intEntries) = vbNullString _
Or intEntries >= 1000
intEntries = intEntries + 1
avarFiles(intEntries) = Dir
Loop
If intEntries > 1 Then
QSArray avarFiles, LBound(avarFiles), intEntries - 1
End If
ReturnVal = intEntries
Case acLBOpen ' Open.
' Generate unique ID for control.
ReturnVal = Timer
Case acLBGetRowCount ' Get number of rows.
ReturnVal = intEntries
Case acLBGetColumnCount ' Get number of columns.
ReturnVal = 1
Case acLBGetColumnWidth ' Column width.
' -1 forces use of default width.
ReturnVal = -1
Case acLBGetValue ' Get data.
ReturnVal = avarFiles(row)
Case acLBEnd ' End.
Erase avarFiles
End Select
FillFileList = ReturnVal
End Function
Private Sub QSArray(_
arrIn() As Variant, _
ByVal intLowBound As Integer, _
ByVal intHighBound As Integer)
Dim intX As Integer
Dim intY As Integer
Dim varMidBound As Variant
Dim varTmp As Variant
If intHighBound > intLowBound Then
varMidBound = arrIn((intLowBound + intHighBound) \ 2)
intX = intLowBound
intY = intHighBound
Do While intX <= intY
If arrIn(intX) >= varMidBound And arrIn(intY) <= varMidBound Then
varTmp = arrIn(intX)
arrIn(intX) = arrIn(intY)
arrIn(intY) = varTmp
intX = intX + 1
intY = intY - 1
Else
If arrIn(intX) < varMidBound Then
intX = intX + 1
End If
If arrIn(intY) > varMidBound Then
intY = intY - 1
End If
End If
Loop
Call QSArray(arrIn(), intLowBound, intY)
Call QSArray(arrIn(), intX, intHighBound)
End If
End Sub
Private Sub cmdClose_Click()
DoCmd.Close acForm, Me.Name, acSaveNo
End Sub
Private Sub cmdOK_Click()
If IsNull(Me.lstFiles) Then
MsgBox "You must choose a file first, or else click the Cancel
button."
Exit Sub
Else
Me.Visible = False
End If
End Sub
Private Sub Form_Open(Cancel As Integer)
' Dim astrArgs() As String ' A2K+
' Dim astrThisArg() As String ' A2K+
Dim astrArgs As Variant
Dim astrThisArg As Variant
Dim I As Integer
astrArgs = Split(Trim(Me.OpenArgs & ""), "|", -1, vbBinaryCompare)
For I = LBound(astrArgs) To UBound(astrArgs)
' astrThisArg = Split(astrArgs(I), "=", 2, vbBinaryCompare)
'A2K+
astrThisArg = Split(CStr(astrArgs(I)), "=", 2, vbBinaryCompare)
Select Case astrThisArg(0)
Case "Folder": Me.txtFolder = astrThisArg(1)
Case "Caption": Me.Caption = astrThisArg(1)
Case "Pattern": Me.txtPattern = astrThisArg(1)
Case "Attributes": Me.txtAttributes = astrThisArg(1)
Case "ChangeFolder"
Me.FormHeader.Visible = CBool(astrThisArg(1))
End Select
Next I
If Len(Me.txtFolder & vbNullString) = 0 Then
Me.txtFolder = CurDir
End If
If Len(Me.txtPattern & vbNullString) = 0 Then
Me.txtPattern = "*.*"
End If
' Having set all our initial properties, fill the list box with a
list
' of the matching files.
Me.lstFiles.RowSourceType = "FillFileList"
End Sub
Private Sub lstFiles_DblClick(Cancel As Integer)
' Double-clicking a file is the same as selecting the file
' and clicking the OK button.
Call cmdOK_Click
End Sub
Private Sub txtFolder_AfterUpdate()
Me.lstFiles.Requery
End Sub
Private Sub txtPattern_AfterUpdate()
Me.lstFiles.Requery
End Sub
------ end of code for form module ------
How to call it:
--------------
I have the following function defined in a standard module to display
the form and return the user's selection. Watch out for lines wrapped
by the newsreader.
----- start of function code -----
Function fncPickAFile( _
ByRef strFolder As String, _
Optional strPattern As String = "*.*", _
Optional strCaption As String, _
Optional fChangeFolder As Boolean = False, _
Optional lngAttributes As Long = vbNormal Or vbReadOnly) _
As String
' Display the form "frmFileList" in dialog mode to prompt the user
to
' select a file, and return the file selected, or a null string if
no
' file was selected.
'
'Arguments:
'
' strFolder - as passed, the folder whose files are to be displayed.
If a
' null string is passed in this argument, the user's current
directory
' (as returned by CurDir) will be used. If the optional
argument
' fChangeFolder is True, on return this argument will be set
to the
' folder from which the file was actually chosen.
'
' strPattern - the initial pattern of file names to be searched for,
using the
' standard wild-card characters "*" and "?". The user may
override this
' pattern.
'
' strCaption - If specified, overrides the default caption on the
form.
'
' fChangeFolder - If set to True, the user has the ability to change
the folder
' whose files are to be listed, and the folder actually used
will be returned
' in the strFolder argument. If False (the default) only
files in this
' folder will be listed.
'
' lngAttributes - Specifies the attributes for the files to be
listed. See the
' documentation of the Dir() function for details. By
default, normal or
' read-only files will be listed for selection.
'
'Returns:
' If a file was chosen, returns the name of that file. If no file
was chosen --
' the user cancelled or closed the form without choosing a file --
returns a
' null string.
Dim strFormArgs As String
strFormArgs = _
"Folder=" & strFolder & _
"|" & "Pattern=" & strPattern & _
"|" & "Caption=" & strCaption & _
"|" & "ChangeFolder=" & fChangeFolder & _
"|" & "Attributes=" & lngAttributes
DoCmd.OpenForm "frmFileList", _
WindowMode:=acDialog, _
OpenArgs:=strFormArgs
If IsLoaded("frmFileList") Then
With Forms!frmFilelist
fncPickAFile = !lstFiles & ""
If fChangeFolder Then
strFolder = !txtFolder
End If
End With
DoCmd.Close acForm, "frmFileList", acSaveNo
End If
End Function
----- end of function code -----
Have fun!
