VBA/Excel/Access/Word/File Path/File

Check file existance

 
Sub ReadPersistedRecordset()
    Dim strFileName As String
    strFileName = "c:\test.txt"
    If Len(Dir(strFileName)) = 0 Then
        msgBox "File Not Found"
        Exit Sub
    End If

End Sub

Common File Operations Simplified

 
Sub TestGetFile() 
    Dim nIndex As Integer 
    Dim sFile As String 
    sFile = GetExcelFile("Testing GetExcelFile Function") 
    If sFile = "False" Then 
        Debug.Print "No file selected." 
        Exit Sub 
    End If 
    Debug.Print sFile 
End Sub 
Function GetExcelFile(sTitle As String) As String 
    Dim sFilter As String 
    Dim bMultiSelect As Boolean 
    sFilter = "Workbooks (*.xls), *.xls" 
    bMultiSelect = False 
    GetExcelFile = Application.GetOpenFilename(FileFilter:=sFilter, _ 
        Title:=sTitle, MultiSelect:=bMultiSelect) 
End Function

Does the specified file exist?

 
Function FileExists(stFile As String) As Boolean
   If Dir(stFile) <> "" Then FileExists = True
End Function
Sub TestForFile()
   Dim myFileName As String
   myFileName = "c:\SalesData1.xls"
   If FileExists(myFileName) Then
      MsgBox myFileName & " exists"
   Else
      MsgBox myFileName & " does not exist"
   End If
End Sub

Gets the file name from the path.

 
Sub GetFileName()
   Dim stPathSep As String
   Dim fileLength As Integer
   Dim i As Integer
   Dim stFullName As String
  
   stFullName = "C:\asdf.xls"
  
   stPathSep = Application.PathSeparator
   fileLength = Len(stFullName)
   For i = fileLength To 1 Step -1
      If Mid(stFullName, i, 1) = stPathSep Then Exit For
         Debug.Print Right(stFullName, fileLength - i + 1)
   Next i
End Sub

List all files under application path

 
Sub FileList()
  Dim File As Variant
  With Application.FileSearch
    .LookIn = "C:\"
    .FileType = msoFileTypeAllFiles
    .Execute
    For Each File In .FoundFiles
      MsgBox File
    Next File
  End With
End Sub

processes multiple stored files

 
Sub BatchProcess()
    Dim Files() As String
    Dim FileSpec As String
    FileSpec = "c:\text.txt"
    NewPath = ExtractPath(FileSpec)
    FoundFile = Dir(FileSpec)
    If FoundFile = "" Then
        MsgBox "Cannot find file:" & FileSpec
        Exit Sub
    End If
    FileCount = 1
    ReDim Preserve Files(FileCount)
    Files(FileCount) = FoundFile
    Do While FoundFile <> ""
        FoundFile = Dir()
        If FoundFile <> "" Then
            FileCount = FileCount + 1
            ReDim Preserve Files(FileCount)
            Files(FileCount) = FoundFile
        End If
    Loop
    For I = 1 To FileCount
        Application.StatusBar = "Processing " & Files(I)
        Call ProcessFiles(Files(I))
    Next I
    Application.StatusBar = False
End Sub
Sub ProcessFiles(FileName As String)
    Workbooks.OpenText FileName:=FileName, Origin:=xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(3, 1), Array(12, 1))
End Sub
Function ExtractPath(Spec As String) As String
    SpecLen = Len(Spec)
    For I = SpecLen To 1 Step -1
        If Mid(Spec, I, 1) = "\" Then
            ExtractPath = Left(Spec, I - 1)
            Exit Function
        End If
    Next I
    ExtractPath = ""
End Function

Select a folder

 
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
Function GetDirectory() As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer
 
    bInfo.pidlRoot = 0&
    bInfo.lpszTitle = "Select a folder."
    bInfo.ulFlags = &H1
    x = SHBrowseForFolder(bInfo)
    
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function
Sub GetAFolder()
    Debug.Print GetDirectory()
End Sub

Select a location containing the files you want to list

 
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type

Sub ListFiles()
    Msg = "Select a location containing the files you want to list."
    Directory = GetDirectory(Msg)
    If Directory = "" Then Exit Sub
    If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
    
    On Error Resume Next
    With Application.FileSearch
        .NewSearch
        .LookIn = Directory
        .Filename = "*.*"
        .SearchSubFolders = False
        .Execute
        For i = 1 To .FoundFiles.Count
            Debug.Print .FoundFiles(i)
            Debug.Print FileLen(.FoundFiles(i))
            Debug.Print FileDateTime(.FoundFiles(i))
        Next i
    End With
End Sub
Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer
    bInfo.pidlRoot = 0&
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
  End If
    bInfo.ulFlags = &H1
    x = SHBrowseForFolder(bInfo)
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
  End If
End Function

Use array to store a list of files

 
Sub XLFiles()
    Dim FName As String
    Dim arNames() As String
    Dim myCount As Integer
    
    FName = Dir("C:\*.xls*")
    Do Until FName = ""
        myCount = myCount + 1
        ReDim Preserve arNames(1 To myCount)
        arNames(myCount) = FName
        FName = Dir
    Loop
End Sub