Multiple File Selection Dialog - lbjoseph

' Multiple file selection dialog by Joseph Essin.
' I got tired of the performance of the API one,
' as it was always crashing.
' So I just made my own.
 
 
' For the MultiOpen$() function:
Global Drives
Dim Drives$(0)
Dim Places$(0)
Dim PlacesList$(0)
Dim Folders$(0)
Dim Files$(0)
Dim FileInfo$(0,0)
Dim Ext$(0)
'-----------------------------------'
 
'NoMainWin
 
files$ = MultiOpen$("Open File(s)", DefaultDir$, "*.*;*.bas")
 
nfiles = Words(files$, "|")
 
For i = 1 To nfiles
    Print Word$(files$, i, "|")
Next i
 
 
' Returns a | delimited list of filenames selected.
' Or nothing (""), if no files were selected.
'
' ext$ is the list of extensions you want people
'   to be able to select, seperated by a semicolon.
' initpath$ is the initial path it opens to.
' title$ is what it says in the window title.
Function MultiOpen$(title$, initPath$, ext$)
 
    Drives = Words(Drives$, " ")
    ReDim PlacesList$(Drives+5)
    ReDim Places$(Drives+5)
 
    Places$(1) = GetSpecialFolder$(40)  ' User's folder
    Places$(2) = GetSpecialFolder$(0)   ' User's desktop
    Places$(3) = GetSpecialFolder$(5)   ' User's documents
    Places$(4)  = GetSpecialFolder$(39) ' User's pictures
    Places$(5) = GetSpecialFolder$(13)  ' User's music
 
    For i = 1 To 5 : PlacesList$(i) = File.ShortName$(Places$(i)) : Next i
 
    For i = 6 To 5+Drives
        Places$(i) = Upper$(Word$(Drives$, i-5));"\"
        PlacesList$(i) = Places$(i)
    Next
 
    extensions = Words(ext$,";")
    ReDim Ext$(extensions)
    For i = 1 To extensions
        Ext$(i) = Word$(ext$,i,";")
    Next i
 
    WindowWidth = 640
    WindowHeight = 450
    UpperLeftX = Int((DisplayWidth-WindowWidth)/2)
    UpperLeftY = Int((DisplayHeight-WindowHeight)/2)
 
    Stylebits #sel.whitespace, 0, _WS_BORDER, 0, 0
    Stylebits #sel.files, _LBS_EXTENDEDSEL, 0, 0, 0
    Stylebits #sel.address, _ES_READONLY, 0, 0, 0
    Stylebits #sel.filename,_ES_READONLY, 0, 0, 0
 
    ' I would love to use this, but it makes the combobox stop sending change notifications:
    'Stylebits #sel.ext, _CBS_DROPDOWNLIST, 0, 0, 0
 
    Graphicbox #sel.whitespace, -4, -4, 660, 44
 
    Button #sel.up, "Back", [FolderUp], UL, 2, 2, 46, 34
    Textbox #sel.address, 54, 08, 570, 20
    Listbox #sel.places, PlacesList$(), [SelectPlace], 2, 42, 150, 300
    Listbox #sel.folders, Folders$(), [SelectFolder], 154, 42, 476, 120
    Listbox #sel.files, Files$(), [SelectFile], 154, 164, 476, 178
    Textbox #sel.filename, 6, 348, 516, 20
    Combobox #sel.ext, Ext$(), [SelectExt], 530, 346, 94, 20
    Button #sel.default, "Open", [Go], UL, 460, 380, 80, 30
    Button #sel.cancel, "Cancel", [Cancel], UL, 545, 380, 80, 30
 
    Stylebits #sel, _DS_CENTER, 0, 0, 0
    Open title$ For Dialog_Modal As #sel
 
    lbx = Hwnd(#sel.files)
 
    #sel "TrapClose [Quit]"
    #sel "Font Arial 9"
    #sel.places "SingleClickSelect"
    #sel.files, "SingleClickSelect"
    #sel.places "SetFocus"
    #sel.ext, "SelectIndex 1"
 
    ext$ = Ext$(1)
    folder$ = initPath$
    GoSub [StartAt]
 
    Wait
 
    [SelectPlace]
        #sel.places, "SelectionIndex? n"
        If n = 0 Then Wait
        folder$ = Places$(n)
        GoSub [StartAt]
    Wait
 
    [SelectFolder]
        #sel.folders, "Selection? n$"
        If n$ = "" Then Wait
        folder$ = folder$;"\";n$
        GoSub [StartAt]
    Wait
 
    [SelectFile]
        items$ = ""
        paths$ = ""
        For i = 1 To nfiles
            isSel = SendMessageA(lbx, _LB_GETSEL, i - 1, 0)
            If isSel Then
                items$ = items$; Files$(i); "|"
                paths$ = paths$; folder$; "\"; Files$(i); "|"
            End If
        Next i
        #sel.filename, items$
    Wait
 
    [FolderUp]
        For i = Len(folder$) To 1 Step -1
            If Mid$(folder$, i, 1) = "\" Then
                folder$ = Mid$(folder$, 1, i-1)
                GoSub [StartAt]
                Exit For
            End If
        Next i
        #sel.folders, "SetFocus"
    Wait
 
    [SelectExt]
        #sel.ext, "SelectionIndex? n"
        If n = 0 Then Wait
        ext$ = Ext$(n)
        GoSub [StartAt]
    Wait
 
    [StartAt]
        ' Remove any trailing slash.
        If right$(folder$,1) = "\" Then folder$ = Mid$(folder$,1,Len(folder$)-1)
        ' Find the files and folders within:
        Files folder$;"\", ext$, FileInfo$()
        nfolders = Val(FileInfo$(0,1))
        nfiles = Val(FileInfo$(0,0))
        items$ = ""
        paths$ = ""
        ReDim Folders$(nfolders)
        ReDim Files$(nfiles)
        For i = 1 To nfolders
            Folders$(i) = FileInfo$(nfiles+i,1);"\"
        Next i
        #sel.folders "Reload"
        For i = 1 To nfiles
            Files$(i) = FileInfo$(i,0)
        Next i
        #sel.files "Reload"
        #sel.address folder$;"\"
        ' Select one of the places if this folder is identical to it.
        #sel.places, "SelectIndex 0"
        For i = 1 To Drives+5
            compare$ = Lower$(folder$)
            If Right$(compare$,1) = ":" Then compare$ = compare$; "\"
            If compare$ = Lower$(Places$(i)) Then
                #sel.places "SelectIndex ";i
                Exit For
            End If
        Next i
        #sel.filename, items$
    Wait
 
    [Go]
        MultiOpen$ = paths$
 
    [Cancel]
 
    [Quit]
        Close #sel
 
End Function
 
Function GetSpecialFolder$(CSIDL)
    struct IDL, _
        cb   As uLong,abID As short
    calldll #shell32, "SHGetSpecialFolderLocation",_
        0     as ulong,CSIDL as ulong,IDL as struct,ret as ulong
    if ret=0 then
        Path$ = Space$(_MAX_PATH)
        id = IDL.cb.struct
        calldll #shell32, "SHGetPathFromIDListA",_
            id    as ulong,Path$ as ptr,ret   as ulong
        GetSpecialFolder$ = trim$(Path$)
    end if
    if GetSpecialFolder$ = "" then GetSpecialFolder$ = "Not Applicable"
End Function
 
Function SendMessageA(hW, msg, par1, par2)
    CallDLL #user32, "SendMessageA",_
        hW as Ulong, _ 'Handle of the control (listbox)
        msg as Long, _ 'Stylebits (Windows Constant)
        par1 as Long, _ 'Parameter 1 (sometimes irrelevant)
        par2 as Long, _ 'Parameter 2 (sometimes irrelevant)
        SendMessageA as long 'Return Value, 1 = success
End Function
 
Function Words(str$, del$)
    index = 1
    While Word$(str$, index, del$) <> ""
        index = index + 1
    WEnd
    Words = index - 1
End Function
 
' Returns the short filename of a path.
Function File.ShortName$(filepath$)
    File.ShortName$ = filepath$
    For i = (Len(filepath$) - 1) To 0 Step -1
        If Mid$(filepath$,i,1) = "\" Then
            File.ShortName$ = Mid$(filepath$,i+1)
            Exit Function
        End If
    Next i
End Function