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

Check file existance

   <source lang="vb">

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

</source>
   
  

Common File Operations Simplified

   <source lang="vb">

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

</source>
   
  

Does the specified file exist?

   <source lang="vb">

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

</source>
   
  

Gets the file name from the path.

   <source lang="vb">

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

</source>
   
  

List all files under application path

   <source lang="vb">

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

</source>
   
  

processes multiple stored files

   <source lang="vb">

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

</source>
   
  

Select a folder

   <source lang="vb">

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

</source>
   
  

Select a location containing the files you want to list

   <source lang="vb">

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

</source>
   
  

Use array to store a list of files

   <source lang="vb">

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

</source>