MyTetra Share
Делитесь знаниями!
File
16.03.2019
23:43
Раздел: !Закладки - VBA - VBA / Excel / Access / Word - File Path

1.

Does the specified file exist?

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



2.

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


3.

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


4.

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


5.

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


6.

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



7.

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



8.

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


9.

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
 
MyTetra Share v.0.52
Яндекс индекс цитирования