Difference between revisions of "Microsoft Access modFso"

From database24
Jump to navigation Jump to search
 
(3 intermediate revisions by the same user not shown)
Line 1: Line 1:
 +
[[Category:Microsoft Access]]
 +
[[Category:VBA]]
 
=== assertPath ===
 
=== assertPath ===
 
<syntaxhighlight lang="vb">
 
<syntaxhighlight lang="vb">
Line 19: Line 21:
 
     If Err.Number = 76 And blnFirst Then
 
     If Err.Number = 76 And blnFirst Then
 
         Debug.Print strPath & " not found - trying to create parent ..."
 
         Debug.Print strPath & " not found - trying to create parent ..."
         assurePath fso.GetParentFolderName(strPath)
+
         assertPath fso.GetParentFolderName(strPath)
 
         blnFirst = False
 
         blnFirst = False
 
         Resume
 
         Resume
Line 26: Line 28:
 
     End If
 
     End If
 
End Sub
 
End Sub
 +
</syntaxhighlight>
 +
 +
=== selectFile ===
 +
<syntaxhighlight lang="vb">
 +
Public Function selectFile(strFileType As String, strFileTypeExtension As String, Optional strFileDefault As String = "")
 +
    Dim strResult As String
 +
 +
    Dim dlg As FileDialog
 +
    Dim strFile As String
 +
    Dim fso As FileSystemObject
 +
   
 +
    Set fso = New FileSystemObject
 +
    Set dlg = Application.FileDialog(msoFileDialogFilePicker)
 +
    With dlg
 +
        .Title = "File Selection"
 +
        .AllowMultiSelect = False
 +
        With .Filters
 +
            .Clear
 +
            .Add strFileType, strFileTypeExtension
 +
        End With
 +
        .InitialView = msoFileDialogViewDetails
 +
       
 +
        strFile = strFileDefault
 +
        If fso.FileExists(strFile) Then
 +
            .InitialFileName = fso.GetParentFolderName(strFile) & "\"
 +
        Else
 +
            .InitialFileName = ""
 +
        End If
 +
       
 +
        If .Show = -1 Then
 +
            strFile = LCase(.SelectedItems(1))
 +
            If fso.FileExists(strFile) Then
 +
                strResult = strFile
 +
            End If
 +
        End If
 +
    End With
 +
   
 +
    selectFile = strResult
 +
End Function
 +
</syntaxhighlight>
 +
 +
==== selectDatabase ====
 +
<syntaxhighlight lang="vb">
 +
Public Function selectDatabase(Optional strFilePathDefault As String = "") As String
 +
    Dim strResult As String
 +
   
 +
    strResult = selectFile("Microsoft Access", "*.mdb", strFilePathDefault)
 +
 +
    selectDatabase = strResult
 +
End Function
 +
</syntaxhighlight>
 +
 +
==== selectSpreadsheet ====
 +
<syntaxhighlight lang="vb">
 +
Public Function selectSpreadsheet(Optional strFilePathDefault As String = "") As String
 +
    Dim strResult As String
 +
   
 +
    strResult = selectFile("Microsoft Excel", "*.xls", strFilePathDefault)
 +
 +
    selectSpreadsheet = strResult
 +
End Function
 +
</syntaxhighlight>
 +
 +
=== selectFolder ===
 +
<syntaxhighlight lang="vb">
 +
Public Function selectFolder(Optional strFolderDefault As String = "")
 +
    Dim strResult As String
 +
 +
    Dim dlg As FileDialog
 +
    Dim strFolder As String
 +
    Dim fso As FileSystemObject
 +
   
 +
    Set fso = New FileSystemObject
 +
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
 +
    With dlg
 +
        .Title = "Folder Selection"
 +
        .AllowMultiSelect = False
 +
        .InitialView = msoFileDialogViewDetails
 +
       
 +
        strFolder = strFolderDefault
 +
        If fso.FolderExists(strFolder) Then
 +
            .InitialFileName = strFolder
 +
        Else
 +
            .InitialFileName = ""
 +
        End If
 +
       
 +
        If .Show = -1 Then
 +
            strFolder = LCase(.SelectedItems(1))
 +
            If fso.FolderExists(strFolder) Then
 +
                strResult = strFolder
 +
            End If
 +
        End If
 +
    End With
 +
   
 +
    selectFolder = strResult
 +
End Function
 
</syntaxhighlight>
 
</syntaxhighlight>

Latest revision as of 02:56, 4 December 2010

assertPath

Public Sub assertPath(strPath)
    Dim fso As FileSystemObject
    Dim blnFirst As Boolean
    
    blnFirst = True
    Set fso = New FileSystemObject
    With fso
        If Not .FolderExists(strPath) Then
            On Error GoTo handleCreateFolderError
            .CreateFolder strPath
            On Error GoTo 0
        End If
    End With
    Exit Sub
    
handleCreateFolderError:
    If Err.Number = 76 And blnFirst Then
        Debug.Print strPath & " not found - trying to create parent ..."
        assertPath fso.GetParentFolderName(strPath)
        blnFirst = False
        Resume
    Else
        MsgBox "The path '" & strPath & "' could not be found, nor created.", vbExclamation + vbOKOnly
    End If
End Sub

selectFile

Public Function selectFile(strFileType As String, strFileTypeExtension As String, Optional strFileDefault As String = "")
    Dim strResult As String

    Dim dlg As FileDialog
    Dim strFile As String
    Dim fso As FileSystemObject
    
    Set fso = New FileSystemObject
    Set dlg = Application.FileDialog(msoFileDialogFilePicker)
    With dlg
        .Title = "File Selection"
        .AllowMultiSelect = False
        With .Filters
            .Clear
            .Add strFileType, strFileTypeExtension
        End With
        .InitialView = msoFileDialogViewDetails
        
        strFile = strFileDefault
        If fso.FileExists(strFile) Then
            .InitialFileName = fso.GetParentFolderName(strFile) & "\"
        Else
            .InitialFileName = ""
        End If
        
        If .Show = -1 Then
            strFile = LCase(.SelectedItems(1))
            If fso.FileExists(strFile) Then
                strResult = strFile
            End If
        End If
    End With
    
    selectFile = strResult
End Function

selectDatabase

Public Function selectDatabase(Optional strFilePathDefault As String = "") As String
    Dim strResult As String
    
    strResult = selectFile("Microsoft Access", "*.mdb", strFilePathDefault)

    selectDatabase = strResult
End Function

selectSpreadsheet

Public Function selectSpreadsheet(Optional strFilePathDefault As String = "") As String
    Dim strResult As String
    
    strResult = selectFile("Microsoft Excel", "*.xls", strFilePathDefault)

    selectSpreadsheet = strResult
End Function

selectFolder

Public Function selectFolder(Optional strFolderDefault As String = "")
    Dim strResult As String

    Dim dlg As FileDialog
    Dim strFolder As String
    Dim fso As FileSystemObject
    
    Set fso = New FileSystemObject
    Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
    With dlg
        .Title = "Folder Selection"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        
        strFolder = strFolderDefault
        If fso.FolderExists(strFolder) Then
            .InitialFileName = strFolder
        Else
            .InitialFileName = ""
        End If
        
        If .Show = -1 Then
            strFolder = LCase(.SelectedItems(1))
            If fso.FolderExists(strFolder) Then
                strResult = strFolder
            End If
        End If
    End With
    
    selectFolder = strResult
End Function