Option Compare Database
Option Explicit
' msoFileDialogFilePicker, requires reference to Microsoft Office [Versienummer] Object Library
Public Enum FileType
Access = 0 ' mdb, accdb
Excel = 1 ' xls, xlsx
Foto = 2 ' plaatje wmf, gif, jpg of bmp
Word = 3 ' Word (doc, docx)
Acrobat = 4 'Acrobat, pdf document
End Enum
Public Function SelectSingleFile(strCurDir As String, strDialogTitle As String, intFilter As FileType) As String
' met behulp van de built-in Application.FileDialog.
On Error GoTo Err_SelectSingleFile
Dim fd As Variant 'Application.FileDialog
Dim varSelectedItem As Variant
Dim strFile As String
Dim i As Integer
'Create a FileDialog object as a Folder Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFilePicker)
strFile = ""
i = 1
With fd
.Title = strDialogTitle
.ButtonName = "&Select"
.InitialView = msoFileDialogViewDetails
'Add a filter that includes MDB or XLS files and make it the first item in the list.
.Filters.Clear
Select Case intFilter
Case FileType.Acrobat
.Filters.Add "Adobe Acrobat bestand", "*.pdf", i: i = i + 1
.Filters.Add "Alle bestanden", "*.*", i
Case FileType.Access
.Filters.Add "Access databases", "*.mdb, *.accdb", i: i = i + 1
.Filters.Add "Alle bestanden", "*.*", i
Case FileType.Excel
.Filters.Add "Excel spreadsheet", "*.xls, *.xlsx, *.xlsm", i: i = i + 1
.Filters.Add "Alle bestanden", "*.*", i
Case FileType.Foto
.Filters.Add "Picture", "*.wmf, *.gif, *.jpg, *.bmp", i: i = i + 1
.Filters.Add "Alle bestanden", "*.*", i
Case FileType.Word
.Filters.Add "Word document", "*.doc, *.docx", i: i = i + 1
.Filters.Add "Alle bestanden", "*.*", i
Case Else 'All filters
.Filters.Add "Alle bestanden", "*.*", i: i = i + 1
.Filters.Add "Access databases", "*.mdb, *.accdb", i: i = i + 1
.Filters.Add "Excel spreadsheet", "*.xls, *.xlsx", i: i = i + 1
.Filters.Add "Picture", "*.wmf, *.gif, *.jpg, *.bmp", i: i = i + 1
.Filters.Add "Word document", "*.doc, *.docx", i
.Filters.Add "Adobe Acrobat document", "*.pdf", i
End Select
'Sets the initial file filter to number 1.
.FilterIndex = 1
If .Show = -1 Then
For Each varSelectedItem In .SelectedItems
If Len(strFile) > 0 Then
strFile = strFile & ", " & varSelectedItem
Else
strFile = varSelectedItem
End If
Next varSelectedItem
Else
strFile = ""
End If
End With
SelectSingleFile = strFile
Set fd = Nothing
Exit_SelectSingleFile:
Set fd = Nothing
Exit Function
Err_SelectSingleFile:
ErrorProc Err, Error$, "SelectSingleFile", "basFileDialog"
Resume Exit_SelectSingleFile
End Function
Public Function StripPath(strFilename As String) As String
' Geeft het pad terug zonder filenaam
Dim intX As Integer
Dim indmax As Integer
Dim strResult As String
indmax = GetParts(strFilename, "\")
strResult = ""
For intX = 1 To indmax - 1
strResult = strResult & GetPart(strFilename, "\", intX) & "\"
Next intX
StripPath = strResult
End Function
Public Function SelectDirectory(strCurDir As String, strDialogTitle As String) As String
On Error GoTo Err_SelectDirectory
Dim fd As Variant 'Application.FileDialog
Dim varSelectedItem As Variant
Dim strDir As String
Dim i As Integer
'Create a FileDialog object as a Folder Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
strDir = ""
i = 1
With fd
.Title = strDialogTitle
.ButtonName = "&Select"
.InitialView = msoFileDialogFolderPicker
If .Show = -1 Then
For Each varSelectedItem In .SelectedItems
strDir = varSelectedItem
Exit For
Next varSelectedItem
Else
strDir = ""
End If
End With
SelectDirectory = strDir
Set fd = Nothing
Exit_SelectDirectory:
Set fd = Nothing
Exit Function
Err_SelectDirectory:
ErrorProc Err, Error$, "SelectDirectory", "basFileDialog"
Resume Exit_SelectDirectory
End Function
