Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations strongm on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Ken Getz Open File Dialog And Multiselect Large Number Files

Status
Not open for further replies.

patriciaxxx

Programmer
Jan 30, 2012
277
GB
I Can’t get the Open File Dialog by Ken Getz to work in multiselect for large numbers of files.

To be more precise it works, or at least I can’t seem to raise an error, when the multiselect flag is not used ie selecting a single file. It too works in multiselect for small number of files say 6 or 8. but if you want to select a whole big bunch of files say 100 or something then it returns no files?

I know Ken’s code is really quite old, and that’s probably the problem.

What I don’t know, and it’s not through a lack of searching, is whether there is a fix or update to his code which can be applied to make it work properly or whether it just won’t work properly. By properly I of course mean being able to return however many files you selected when in multiselect mode?

I have posted the full code below in the hope that someone will know the answer and let me know.

Code:
Option Compare Database
Option Explicit

'***************** Code Start **************
'This code was originally written by Ken Getz.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code courtesy of:
'Microsoft Access 95 How-To
'Ken Getz and Paul Litwin
'Waite Group Press, 1996

'Also based on code here:
'[URL unfurl="true"]http://www.mvps.org/vbnet/index.html?code/callback/browsecallback.htm[/URL]

Type tagOPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    strFilter As String
    strCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    strFile As String
    nMaxFile As Long
    strFileTitle As String
    nMaxFileTitle As Long
    strInitialDir As String
    strTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    strDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

Public Const WM_INITDIALOG = &H110
Private Const SW_SHOWNORMAL = 1

Private Type POINTAPI
    x As Long
    Y As Long
End Type

Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Public Declare Function GetParent Lib "user32" _
    (ByVal hWnd As Long) As Long

Public Declare Function MoveWindow Lib "user32" _
    (ByVal hWnd As Long, _
    ByVal x As Long, _
    ByVal Y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal bRepaint As Long) As Long

Public Declare Function GetWindowRect Lib "user32" _
    (ByVal hWnd As Long, _
    lpRect As RECT) As Long

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Declare Function aht_apiGetOpenFileName Lib "comdlg32.dll" _
    Alias "GetOpenFileNameA" (OFN As tagOPENFILENAME) As Boolean

Declare Function aht_apiGetSaveFileName Lib "comdlg32.dll" _
    Alias "GetSaveFileNameA" (OFN As tagOPENFILENAME) As Boolean
    Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long

Global Const ahtOFN_READONLY = &H1
Global Const ahtOFN_OVERWRITEPROMPT = &H2
Global Const ahtOFN_HIDEREADONLY = &H4
Global Const ahtOFN_NOCHANGEDIR = &H8
Global Const ahtOFN_SHOWHELP = &H10
'You won't use these.
Global Const ahtOFN_ENABLEHOOK = &H20
'Global Const ahtOFN_ENABLETEMPLATE = &H40
'Global Const ahtOFN_ENABLETEMPLATEHANDLE = &H80
Global Const ahtOFN_NOVALIDATE = &H100
Global Const ahtOFN_ALLOWMULTISELECT = &H200
Global Const ahtOFN_EXTENSIONDIFFERENT = &H400
Global Const ahtOFN_PATHMUSTEXIST = &H800
Global Const ahtOFN_FILEMUSTEXIST = &H1000
Global Const ahtOFN_CREATEPROMPT = &H2000
Global Const ahtOFN_SHAREAWARE = &H4000
Global Const ahtOFN_NOREADONLYRETURN = &H8000
Global Const ahtOFN_NOTESTFILECREATE = &H10000
Global Const ahtOFN_NONETWORKBUTTON = &H20000
Global Const ahtOFN_NOLONGNAMES = &H40000
'New for Windows 95
Global Const ahtOFN_EXPLORER = &H80000
Global Const ahtOFN_NODEREFERENCELINKS = &H100000
Global Const ahtOFN_LONGNAMES = &H200000

Function TestIt()
Dim strFilter As String
Dim lngFlags As Long
strFilter = ahtAddFilterItem(strFilter, "Access Files (*.mda, *.mdb)", _
    "*.MDA;*.MDB")
strFilter = ahtAddFilterItem(strFilter, "dBASE Files (*.dbf)", "*.DBF")
strFilter = ahtAddFilterItem(strFilter, "Text Files (*.txt)", "*.TXT")
strFilter = ahtAddFilterItem(strFilter, "All Files (*.*)", "*.*")

'Uncomment this line to try the example
'allowing multiple file names:
'lngFlags = ahtOFN_ALLOWMULTISELECT Or ahtOFN_EXPLORER

Dim result As Variant

result = ahtCommonFileOpenSave(InitialDir:="C:\", _
    FILTER:=strFilter, FilterIndex:=3, Flags:=lngFlags, _
    DialogTitle:="Hello! Open Me!")

If lngFlags And ahtOFN_ALLOWMULTISELECT Then
    If IsArray(result) Then
        Dim i As Integer
        For i = 0 To UBound(result)
            MsgBox result(i)
        Next i
    Else
        MsgBox result
    End If
Else
    MsgBox result
End If

'Since you passed in a variable for lngFlags,
'the function places the output flags value in the variable.
Debug.Print Hex(lngFlags)
End Function

Function GetOpenFile(Optional varDirectory As Variant, _
    Optional varTitleForDialog As Variant) As Variant
'Here's an example that gets an Access database name.
Dim strFilter As String
Dim lngFlags As Long
Dim varFileName As Variant
'Specify that the chosen file must already exist,
'don't change directories when you're done
'Also, don't bother displaying
'the read-only box. It'll only confuse people.
lngFlags = ahtOFN_FILEMUSTEXIST Or _
    ahtOFN_HIDEREADONLY Or ahtOFN_NOCHANGEDIR
If IsMissing(varDirectory) Then
    varDirectory = ""
End If
If IsMissing(varTitleForDialog) Then
    varTitleForDialog = ""
End If

'Define the filter string and allocate space in the "c"
'string Duplicate this line with changes as necessary for
'more file templates.
strFilter = ahtAddFilterItem(strFilter, _
    "Access (*.mdb)", "*.MDB;*.MDA")
'Now actually call to get the file name.
varFileName = ahtCommonFileOpenSave( _
    OpenFile:=True, _
    InitialDir:=varDirectory, _
    FILTER:=strFilter, _
    Flags:=lngFlags, _
    DialogTitle:=varTitleForDialog)
If Not IsNull(varFileName) Then
    varFileName = TrimNull(varFileName)
End If
GetOpenFile = varFileName
End Function

Function ahtCommonFileOpenSave( _
    Optional ByRef Flags As Variant, _
    Optional ByVal InitialDir As Variant, _
    Optional ByVal FILTER As Variant, _
    Optional ByVal FilterIndex As Variant, _
    Optional ByVal DefaultExt As Variant, _
    Optional ByVal FileName As Variant, _
    Optional ByVal DialogTitle As Variant, _
    Optional ByVal hWnd As Variant, _
    Optional ByVal OpenFile As Variant) As Variant
'This is the entry point you'll use to call the common
'file open/save dialog. The parameters are listed
'below, and all are optional.

'In:
'Flags: one or more of the ahtOFN_* constants, OR'd together.
'InitialDir: the directory in which to first look
'Filter: a set of file filters, set up by calling
'AddFilterItem. See examples.
'FilterIndex: 1-based integer indicating which filter
'set to use, by default (1 if unspecified)
'DefaultExt: Extension to use if the user doesn't enter one.
'Only useful on file saves.
'FileName: Default value for the file name text box.
'DialogTitle: Title for the dialog.
'hWnd: parent window handle
'OpenFile: Boolean(True=Open File/False=Save As)
'Out:
'Return Value: Either Null or the selected filename
Dim OFN As tagOPENFILENAME
Dim strFileName As String
Dim strFileTitle As String
Dim fResult As Boolean
'Give the dialog a caption title.
If IsMissing(InitialDir) Then InitialDir = CurDir
If IsMissing(FILTER) Then FILTER = ""
If IsMissing(FilterIndex) Then FilterIndex = 1
If IsMissing(Flags) Then Flags = 0&
If IsMissing(DefaultExt) Then DefaultExt = ""
If IsMissing(FileName) Then FileName = ""
If IsMissing(DialogTitle) Then DialogTitle = ""
If IsMissing(hWnd) Then hWnd = Application.hWndAccessApp
If IsMissing(OpenFile) Then OpenFile = True
'Allocate string space for the returned strings.
strFileName = Left(FileName & String(512, 0), 512)
strFileTitle = String(512, 0)
'Set up the data structure before you call the function
With OFN
    .lStructSize = Len(OFN)
    .hwndOwner = hWnd
    .strFilter = FILTER
    .nFilterIndex = FilterIndex
    .strFile = strFileName
    .nMaxFile = Len(strFileName)
    .strFileTitle = strFileTitle
    .nMaxFileTitle = Len(strFileTitle)
    .strTitle = DialogTitle
    'We must specify the EXPLORER and HOOK flaga since we are using a hook
    .Flags = Flags Or ahtOFN_EXPLORER Or ahtOFN_ENABLEHOOK
    .strDefExt = DefaultExt
    .strInitialDir = InitialDir
    'Didn't think most people would want to deal with
    'these options.
    .hInstance = 0
    'strCustomFilter = ""
    'nMaxCustFilter = 0
    .lpfnHook = FARPROC(AddressOf FileDialogHook)
    
    'New for NT 4.0
    .strCustomFilter = String(255, 0)
    .nMaxCustFilter = 255
End With
'This will pass the desired data structure to the
'Windows API, which will in turn it uses to display
'the Open/Save As Dialog.
If OpenFile Then
    fResult = aht_apiGetOpenFileName(OFN)
Else
    fResult = aht_apiGetSaveFileName(OFN)
End If

'The function call filled in the strFileTitle member
'of the structure. You'll have to write special code
'to retrieve that if you're interested.

'The function call filled in the strFileTitle member
'of the structure. You'll have to write special code
'to retrieve that if you're interested.
If fResult Then
    'You might care to check the Flags member of the
    'structure to get information about the chosen file.
    'In this example, if you bothered to pass in a
    'value for Flags, we'll fill it in with the outgoing
    'Flags value.
    If Not IsMissing(Flags) Then Flags = OFN.Flags
    If Flags And ahtOFN_ALLOWMULTISELECT Then
        'Return the full array.
        Dim items As Variant
        Dim value As String
        value = OFN.strFile
        'Get rid of empty items:
        Dim i As Integer
        For i = Len(value) To 1 Step -1
            If Mid$(value, i, 1) <> Chr$(0) Then
                Exit For
            End If
        Next i
        value = Mid(value, 1, i)
        
        'Break the list up at null characters:
        items = Split(value, Chr(0))
        
        'Loop through the items in the "array",
        'and build full file names:
        Dim numItems As Integer
        Dim result() As String
        
        numItems = UBound(items) + 1
        If numItems > 1 Then
            ReDim result(0 To numItems - 2)
            For i = 1 To numItems - 1
                result(i - 1) = FixPath(items(0)) & items(i)
            Next i
            ahtCommonFileOpenSave = result
        Else
            'If you only select a single item,
            'Windows just places it in item 0.
            ahtCommonFileOpenSave = items(0)
        End If
    Else
        ahtCommonFileOpenSave = TrimNull(OFN.strFile)
    End If
Else
    ahtCommonFileOpenSave = vbNullString
End If
End Function

Function ahtAddFilterItem(strFilter As String, _
strDescription As String, Optional varItem As Variant) As String
'Tack a new chunk onto the file filter.
'That is, take the old value, stick onto it the description,
'(like "Databases"), a null character, the skeleton
'(like "*.mdb;*.mda") and a final null character.

If IsMissing(varItem) Then varItem = "*.*"
ahtAddFilterItem = strFilter & _
    strDescription & vbNullChar & _
    varItem & vbNullChar
End Function

Private Function TrimNull(ByVal strItem As String) As String
Dim intPos As Integer
intPos = InStr(strItem, vbNullChar)
If intPos > 0 Then
    TrimNull = Left(strItem, intPos - 1)
Else
    TrimNull = strItem
End If
End Function

Private Function FixPath(ByVal path As String) As String
If Right$(path, 1) <> "\" Then
    FixPath = path & "\"
Else
    FixPath = path
End If
End Function
'************** Code End *****************

Public Function FARPROC(ByVal pfn As Long) As Long

'A dummy procedure that receives and returns
'the return value of the AddressOf operator.

'Obtain and set the address of the callback
'This workaround is needed as you can't assign
'AddressOf directly to a member of a user-
'defined type, but you can assign it to another
'long and use that (as returned here)

FARPROC = pfn

End Function

Public Function FileDialogHook(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long

'Show File Dialog window at current cursor coordinates

Dim pt As POINTAPI
Dim hWndParent As Long
Dim rc As RECT

Select Case uMsg
Case WM_INITDIALOG
    'obtain the handle to the parent dialog
    hWndParent = GetParent(hWnd)
    
    If hWndParent = 0 Then
        FileDialogHook = 0
        Exit Function
    End If
    
    Call GetCursorPos(pt)
    Call GetWindowRect(hWndParent, rc)
    
    'Call MoveWindow(hWndParent, pt.X - 500, pt.Y - 200, rc.Right - rc.Left, rc.Bottom - rc.Top, True)
    Call MoveWindow(hWndParent, 50, 50, rc.Right - rc.Left, rc.Bottom - rc.Top, True)
    
    FileDialogHook = 1
Case Else
End Select

End Function
 
I have further been looking at this and noticed when it doesn’t work it gives the following warning. Is there a way to make sure the file name/path is readable by this code?

img_yjmni7.png
 
>I know Ken’s code is really quite old, and that’s probably the problem.

It isn't just old, it's pretty much obsolete. It was written at a time when Access/office did not provide direct access to the common file dialogs.

Here's some somewhat shorter code that does pretty much the same thing:

Code:
[blue]Private Sub Example()
  
   ' Requires reference to Microsoft Office x.0 Object Library.
 
   Dim fDialog As Office.FileDialog
   Dim varFile As Variant

   ' Set up the File Dialog.
   Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
 
   With fDialog
      .AllowMultiSelect = True
      .Title = "Hello! Open Me!"
      .InitialFileName = "C:\"
      .Filters.Clear
      .Filters.Add "Access Databases (*.mdb)", "*.MDB"
      .Filters.Add "dBASE Files (*.dbf)", "*.DBF"
      .Filters.Add "Text Files (*.txt)", "*.TXT"
      .Filters.Add "All Files (*.*)", "*.*"
  
      ' Show the dialog box. If the .Show method returns True, the
      ' user picked at least one file. If the .Show method returns
      ' False, the user clicked Cancel.
      If .Show = True Then
         For Each varFile In .SelectedItems
            MsgBox varFile
         Next
      Else
         MsgBox "You clicked Cancel in the file dialog box."
      End If
   End With
End Sub[/blue]
 
Hello strongm thank you for your reply and for providing the code.

I do use code very similar to yours, it’s just that I came across Ken’s code the version I have seems to open a small dialog window or large depending on settings used. It was the small window which intrigued me, old that it is, and so I set about trying to make it work.

I soon came to the conclusion I was attempting the impossible, but I level of experience isn’t sufficient to make that determination on my own.

So just to be clear on Ken’s code and expecting it to multiselect whatever files show up it the dialog window, is this in fact impossible, because if so I will cease my efforts in trying to make it work.
Thank you as always for taking the time to respond, it is very much appreciated.

 
>is this in fact impossible

No, it's just the code test code is poor(ish). What you have got is a buffer size error. Does that help?
 
Hello strongm

I have tried terribly to get this code to work and all the time wondering if it was actually even possible.

During my efforts to understand why it was acting the way I described in my posts I did come across something that mentioned ‘buffer’ and changeing

this (orginal lines)

Code:
strFileName = Left(FileName & String(256, 0), 256)
strFileTitle = String(256, 0)

to (what I'm using now)

Code:
strFileName = Left(FileName & String(512, 0), 512)
strFileTitle = String(512, 0)

which I did. Hoping it would solve the problem and make everything work. Interesting enough it did allow for a few more selections to be returned than before. But sadly it did not solve the problem and also it seemed to bring about the API invalid file name warning message which I had not seen before. I tried even bigger values like 1024 and 2048 but again it made it no better.

I’m not sure how these lines refer to the TestIt function or can make it less poorish, all my efforts at trying to get the code to work were aimed at other parts of the code I posted and not the TestIt function because I thought the problem must reside somewhere there.

Unfortunately I have to confess that beyond what I have done I am at a loss as how to correct what needs doing to make the code work properly because I simply don’t know what is at fault and I had been searching for an answer for days before I finally thought to post the thread and ask if someone knew if it was possible for the code to work properly today so long after it was first written and if so what was missing which prevents it from doing so. I would be grateful to you if you could show me what the problem is.
 
> the API invalid file name warning message

Given the code that you've posted here, I'm not sure how you are getting that error message at all. And I rather suspect it isn't anything directly to do with Getz's code.

Anyway, changing just this line to something bigger should result in more files being able to be retruned.

strFileName = Left(FileName & String(512, 0), 512)

eg, to

strFileName = Left(FileName & String(5120, 0), 5120)

That's the basic fix, and should work for about 250 files or so (very roughly)
 
Hello strongm

Yes, I have done this, I’ve tried even larger numbers ie 8192 and as I said it returns more files but not a folder full say about 1000 or so.

However, if your saying the best Ken’s code can achieve is returning an unknown and limited number of files then I guess that means it doesn’t work well enough for today’s requirements where thousands of files could need to be selected in a folder.

Please confirm this is the case because then I can stop trying to accomplish the impossible.

 
No, not saying that at all. The problem is that the underlying API has limitations. You have to allocate the buffer before you make the call, so it is a guess. And yes, that's partially becasue you are trying to leverage some pretty old legacy stuff dating from before Window 98. One problem with the Getz code is that it does not deal gently with the situation where you guess the size wrong.

Here's the rule of thumb I used: an average filename takes up 20 characters, plus the separator. So each filename uses 21 bytes. So, if you want to retrieve 1000 files then you need buffer of 21000 bytes (and in reality behind the scenes you are actually reserving twice this, because we are working in ANSI rather than Wide mode).

Having said that, I really wouldn't be trying to use ancient, legacy API unless there was a really, really good reason to do so (and I'd suggest the 'small window' isn't a good enough reason)
 
Hello strongm

I even tried values around 21000 hoping the buffer size would be the solution to my problems, but it gave me new problems in the form of an error saying the value was too big. That's how i arrived at what seemed to be a limit to the size the buffer could be.

I believe you to be quite an expert and experienced programmer and i think if there was a viable solution we would have seen it.

> and I'd suggest the 'small window' isn't a good enough reason

I am stubborn when trying to get things to work but not so much that I don't know when to stop. I think your right and this is the time to stop.

Please accept my thanks and gratitude for your continued help and support, it really is quite appreciated.
 
>an error saying the value was too big

I suspect that's an artifact of the way Getz tries to trim off unused space in the buffer
 
Hello strongm

Does that mean a possible fix could be applied to the Trim function?

Code:
Private Function TrimNull(ByVal strItem As String) As String
Dim intPos As Integer
intPos = InStr(strItem, vbNullChar)
If intPos > 0 Then
    TrimNull = Left(strItem, intPos - 1)
Else
    TrimNull = strItem
End If
End Function
 
No - because as the code stands that's not where the trim I'm talking about occurs.

I'm looking at

'Get rid of empty items:
Dim i As Integer
For i = Len(value) To 1 Step -1
If Mid$(value, i, 1) <> Chr$(0) Then
Exit For
End If
Next i
value = Mid(value, 1, i)


I should also point out that the Getz code is pretty inefficient at returning the selected filenames; the more you return, the slower it is. So, stick with your decision: don't use it ...
 
> So, stick with your decision: don't use it ...

Indeed, sound advice.

A really big thank you for continuing to help me.
 
Having a situation where the number of files to be selected is unknown and can be 1,000 or so (or more? Ack!), I would ditch any File Dialog method and instead look how to use the Dir() command. Allen Browne has an excellent example of how to pull a list of files (by specific name or wildcard spec), load the return list into a ListBox where the user can then multi-select option. Then after they are done, iterate the ListBox rows to determine which are Selected and process accordingly.

List Files Recursively
 
Status
Not open for further replies.

Part and Inventory Search

Sponsor

Back
Top