Option Explicit
Enum PathType
VbFilePath = 0
VbFolderPath = 1
End Enum
Function BrowseFile() As String
BrowseFile = ConvertToUNC(getFilePath(“Select Database(Only MDB)”, “mdb”))
End Function
Function BrowseFolder() As String
BrowseFolder = ConvertToUNC(getFilePath(“Select Output Folder Path”, , , False))
End Function
Function getFilePath(ByVal strTitle As String, _
Optional strFilter As String, _
Optional blnMultiSelect As Boolean = False, _
Optional blnSetDefaultFolder As Boolean = False, _
Optional blnFileBrowser As Boolean = True) As String
Dim Fname As Variant
Dim strDefAppPath As String
Dim strFilePath As String
Dim strSavedPath As String
Dim intLoop As Integer
Select Case strFilter
Case “mdb”
strFilter = “Access Database Files (*.mdb*),*.mdb*”
Case “xls”
strFilter = “Excel Files (*.xls*),*.xls*”
Case “csv”
strFilter = “Excel Files (*.csv),*.csv”
End Select
If blnFileBrowser Then
Fname = Application.GetOpenFilename(FileFilter:=strFilter, Title:=strTitle, MultiSelect:=blnMultiSelect)
If IsArray(Fname) Then
For intLoop = LBound(Fname) To UBound(Fname)
If intLoop = LBound(Fname) Then
getFilePath = Fname(intLoop)
Else
getFilePath = getFilePath & “;” & Fname(intLoop)
End If
Next intLoop
Else
If Fname = False Then
getFilePath = “”
Exit Function
End If
If Fname <> False Then
getFilePath = Fname
End If
End If
Else
With CreateObject(“Shell.Application”)
‘Fname = .BrowseForFolder(hWnd:=0, sTitle:=strTitle, iOptions:=512, vRootFolder:=””)
On Error Resume Next
If blnSetDefaultFolder Then
getFilePath = .BrowseForFolder(0, strTitle, 512, ActiveWorkbook.Path).self.Path
Else
getFilePath = .BrowseForFolder(0, strTitle, 512).self.Path
End If
On Error GoTo 0: Err.Clear
End With
End If
End Function
Function FileOrDirExists(ByVal PathName As String, Optional Path_Type As PathType = VbFilePath) As Boolean
‘Macro Purpose: Function returns TRUE if the specified file
‘ or folder exists, false if not.
‘PathName : Supports Windows mapped drives or UNC
‘ : Supports Macintosh paths
‘File usage : Provide full file path and extension
‘Folder usage : Provide full folder path
‘ Accepts with/without trailing “\” (Windows)
‘ Accepts with/without trailing “:” (Macintosh)
Dim FSO As Object
Set FSO = CreateObject(“scripting.filesystemobject”)
‘Ignore errors to allow for error evaluation
With FSO
On Error GoTo CheckExist
If Path_Type = VbFolderPath Then
.GetFolder (PathName)
ElseIf Path_Type = VbFilePath Then
.getfile (PathName)
End If
End With
‘Check if error exists and set response appropriately
CheckExist:
Select Case Err.Number
Case Is = 0
FileOrDirExists = True
Case Else
FileOrDirExists = False
End Select
‘Resume error checking
On Error GoTo 0: Err.Clear
End Function
Function ListFiles( _
ByVal strSourcePath As String, _
Optional bolGetFullName As Boolean = False, _
Optional bolIncludeSubfolders As Boolean = False _
) As String
Dim objFiles As Object
Dim objSubFolder As Object
Dim strFiles As String
Const strDelima As String = “|”
‘Set MyObject = New Scripting.FileSystemObject
‘Set mySource = MyObject.GetFolder(mySourcePath)
On Error Resume Next
With CreateObject(“scripting.filesystemobject”).GetFolder(strSourcePath)
strFiles = “”
For Each objFiles In .files
‘strFiles = strFiles & IIf(strFiles = “”, “‘” & objFiles.Name & “‘”, “,'” & objFiles.Name & “‘”)
If bolGetFullName Then
strFiles = strFiles & IIf(strFiles = “”, objFiles, strDelima & objFiles)
Else
strFiles = strFiles & IIf(strFiles = “”, objFiles.Name, strDelima & objFiles.Name)
End If
Next objFiles
If bolIncludeSubfolders Then
For Each objSubFolder In .SubFolders
Call ListFiles(objSubFolder.Path, True)
Next objSubFolder
End If
End With
On Error GoTo 0: Err.Clear
ListFiles = strFiles
Set objFiles = Nothing
Set objSubFolder = Nothing
strFiles = vbNullString
End Function
You may develop an Excel application that needs to adjust itself depending on the video resolution of the user. For
Power Desk 