Option Compare Database
Option Explicit
Option Base 0
'*** THIS MODULE REQUIRES MICROSOFT OFFICE OBJECT LIBRARY REFERENCE TO BE ENABLED ***
'File type enumeration used in FileSelect
Public Enum FileType
ftAccess = 1
ftAll = 2
ftExcel = 3
ftPDF = 4
ftText = 5
ftWord = 6
ftImage = 7
End Enum
Public Function ValidateFileType(ByVal Data As FileType) As Boolean
'**************************************************
'* Created By: Scott L Prince
'* Created On: 10/2/13
'* Modified:
'* Purpose: Validates a submitted 'FileType' (see Enum) to ensure a valid value was submitted.
'* Parameters: Submitted FileType value.
'* Output: Boolean
'* Comments:
'**************************************************
Dim LoopCounter As Long
On Error GoTo ValidateFileType_Err
'Defaults
ValidateFileType = False
'Make sure that the number submitted for ExpectedDataType.Value is actually valid.
'ftAccess is the first value (1); ftWord is the last value (6).
For LoopCounter = FileType.ftAccess To FileType.ftImage
If LoopCounter = Data Then
ValidateFileType = True
Exit For
End If
Next
ValidateFileType_Exit:
Exit Function
ValidateFileType_Err:
MsgBox "An error has occurred in procedure 'ValidateFileType'!" & vbCrLf & vbCrLf & _
"Error:" & vbTab & vbTab & Err.Number & vbCrLf & _
"Description:" & vbTab & Err.Description, vbOKOnly + vbCritical
Resume ValidateFileType_Exit
End Function
Public Function FileSelect(Optional ByVal DefaultLocation As String, _
Optional ByVal TypeOfFile As FileType = ftAll, _
Optional ByVal AddTypeAll As Boolean = True) As String
'**************************************************
'* Created By: Scott L Prince
'* Created On: 10/2/13
'* Modified:
'* Purpose: Opens file selection box, then returns path of selected file to calling procedure.
'* Parameters: Default folder path (OPTIONAL)
'* Type of file expected (OPTIONAL)
'* Whether or not to include all files to the list (useful in saving).
'* Output: Path to selected file
'* Comments:
'**************************************************
Dim fd As FileDialog 'File Dialog box
Dim DefaultPath As String 'Actual default location to be used.
Dim WshShell as Object
On Error GoTo FileSelect_Err
'Validate the submitted FileType. If it fails, use ftAll.
If Not ValidateFileType(TypeOfFile) Then TypeOfFile = ftAll
'Determine if a default location was supplied.
If IsMissing(DefaultLocation) Or Len(DefaultLocation) = 0 Then
'No default was supplied, so use the user's 'My Documents' folder.
Set WshShell = CreateObject("WScript.Shell")
DefaultPath= WshShell.SpecialFolders("MyDocuments")
Else
'User passed a default location, so use it.
DefaultPath = DefaultLocation
End If
'Set the options for the actual file dialog box.
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiselect = False 'Only one file will be opened.
.InitialFileName = DefaultPath 'Fill in the initial folder path.
.Title = "Select file to open." 'Dialog box title.
.Filters.Clear 'Clear existing filters, if any.
'Add the appropriate filter for the file type selected.
Select Case TypeOfFile
Case ftExcel
.Filters.Add "Excel File", "*.xls; *.xlsx", 1
Case ftWord
.Filters.Add "Word Document", "*.doc; *.docx", 1
Case ftAccess
.Filters.Add "Access Database", "*.mdb; *.mdr; *.mde; *.accdb; *.accde; *.accdr"
Case ftText
.Filters.Add "Text File", "*.txt", 1
Case ftPDF
.Filters.Add "PDF File", "*.pdf", 1
Case ftImage
.Filters.Add "Image file", "*.jpg; *.jpeg; *.png; *.gif; *.bmp"
Case ftAll
.Filters.Add "All Files", "*.*", 1
Case Else
.Filters.Add "All Files", "*.*", 1
End Select
'Add an "All Files" filter if it isn't already included and AddTypeAll is TRUE.
If TypeOfFile <> ftAll And AddTypeAll = True Then .Filters.Add "All Files", "*.*", 2
'Open the dialog box and return the user's response.
If .Show = -1 Then
'User selected a file.
FileSelect = .SelectedItems.Item(1)
Else
'User did NOT select a file.
FileSelect = "CANCEL"
End If
End With
FileSelect_Exit:
On Error Resume Next
If Not fd Is Nothing Then
fd.Filters.Clear
Set fd = Nothing
End If
If Not WshShell Is Nothing Then Set WshShell = Nothing
Exit Function
FileSelect_Err:
MsgBox "An error has occurred in procedure 'FileSelect'!" & vbCrLf & vbCrLf & _
"Error:" & vbTab & vbTab & Err.Number & vbCrLf & _
"Description:" & vbTab & Err.Description, vbOKOnly + vbCritical
Resume FileSelect_Exit
End Function
so if I post a question I also post the answer if I figure it out.
