Excel VBA verimli dosya adlarını döndürme işlevi

Question

Excel 2010'da VBA kullanan uzak bir sunucudaki bir klasördeki dosya adlarının bir koleksiyonunu almam gerekiyor. İşleyen bir işlev var ve çoğu durumda bu işi yapacak, Ancak uzak sunucu sık sık ağ performans sorunları korkunç. Bu da demek oluyor ki, isimleri bir koleksiyona koymak için 300 dosya ile 10 dakika sürebilir, klasördeki dosyaların sayısı binlerce büyüyebilir, bu yüzden bu işe yaramaz, tüm dosya isimlerini almanın bir yoluna ihtiyacım var tek bir ağ isteğinde ve döngüde değil. Uzak sunucuya bağlanmanın zamanı alacağına inanıyorum ki, tek bir istek tüm dosyaları tek geçişte oldukça hızlı bir şekilde alabilmelidir.

Private Function GetFileNames(sPath As String) As Collection 
'takes a path and returns a collection of the file names in the folder 

Dim oFolder  As Object 
Dim oFile  As Object 
Dim oFSO  As Object 
Dim colList  As New Collection 

Set oFSO = CreateObject("Scripting.FileSystemObject") 
Set oFolder = oFSO.GetFolder(folderpath:=sPath) 

For Each oFile In oFolder.Files 
    colList.Add oFile.Name 
Next oFile 

Set GetFileNames = colList 

Set oFolder = Nothing 
Set oFSO = Nothing 

End Function 

Answer 1

Tamam, benim durum için çalışır ve belki diğerleri de yararlı bulacaksınız bir çözüm bulduk. Bu özüm, windows API'sini kullanır ve FSO yönteminin birkaç dakika sürdüğü dosyalarda 1 saniye veya daha kısa sürede dosya isimlerini alır. Hala bir döngü içerir, bu yüzden neden bu kadar hızlı olduğunu bilmiyorum.

Bu, "c: \ windows \" gibi bir yol alır ve bu klasördeki tüm dosyaların (ve dizinlerin) bir koleksiyonunu döndürür. Kullandığım tam parametreler Windows 7 veya daha yeni bir sürümü gerektirir, açıklamalarda yer alan yorumlara bakınız.

'for windows API call to FindFirstFileEx 
Private Const INVALID_HANDLE_VALUE = -1 
Private Const MAX_PATH = 260 

Private Type FILETIME 
    dwLowDateTime As Long 
    dwHighDateTime As Long 
End Type 

Private Type WIN32_FIND_DATA 
    dwFileAttributes As Long 
    ftCreationTime  As FILETIME 
    ftLastAccessTime As FILETIME 
    ftLastWriteTime  As FILETIME 
    nFileSizeHigh  As Long 
    nFileSizeLow  As Long 
    dwReserved0   As Long 
    dwReserved1   As Long 
    cFileName   As String * MAX_PATH 
    cAlternate   As String * 14 
End Type 

Private Const FIND_FIRST_EX_CASE_SENSITIVE As Long = 1 
'MSDN: "This value is not supported until Windows Server 2008 R2 and Windows 7." 
Private Const FIND_FIRST_EX_LARGE_FETCH  As Long = 2 

Private Enum FINDEX_SEARCH_OPS 
    FindExSearchNameMatch 
    FindExSearchLimitToDirectories 
    FindExSearchLimitToDevices 
End Enum 

Private Enum FINDEX_INFO_LEVELS 
    FindExInfoStandard 
    FindExInfoBasic 'MSDN: "This value is not supported until Windows Server 2008 R2 and Windows 7." 
    FindExInfoMaxInfoLevel 
End Enum 

Private Declare Function FindFirstFileEx Lib "kernel32" Alias "FindFirstFileExA" (_ 
ByVal lpFileName As String, ByVal fInfoLevelId As Long, lpFindFileData As WIN32_FIND_DATA, _ 
    ByVal fSearchOp As Long, ByVal lpSearchFilter As Long, ByVal dwAdditionalFlags As Long) As Long 
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (_ 
    ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long 
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long 


Private Function GetFiles(ByVal sPath As String) As Collection 

    Dim fileInfo As WIN32_FIND_DATA 'buffer for file info 
    Dim hFile  As Long    'file handle 
    Dim colFiles As New Collection 

    sPath = sPath & "*.*" 

    hFile = FindFirstFileEx(sPath & vbNullChar, FindExInfoBasic, fileInfo, FindExSearchNameMatch, 0&, FIND_FIRST_EX_LARGE_FETCH) 

    If hFile <> INVALID_HANDLE_VALUE Then 
     Do While FindNextFile(hFile, fileInfo) 
      colFiles.Add Left(fileInfo.cFileName, InStr(fileInfo.cFileName, vbNullChar) - 1) 
     Loop 

     FindClose hFile 
    End If 

    Set GetFiles = colFiles 

End Function 

Answer 2

Ben olmadan döngü bana bir dizindeki dosya adları alabilir ama bulamadım bir API var olacağını düşündüm:

Bu

Şu anda yürürlükte sahip fonksiyonudur. Bildiğim tüm kod, fso veya dir kullanarak döngü içerir.

Dosya isimlerini döngü olmadan almak mümkün. Sanırım evet ... Burada DOS istemi, tüm dosya yapısında aşağıdaki komutu yazdığınızda

Doing bir metin dosyasına

Dir C:\Temp\*.* > C:\Temp\MyFile.Txt 

gönderilir Aklıma tek yol ... yukarıdaki VBA'DA

Örneğin

Sub Sample() 
    Dim sPath As String 

    sPath = "C:\Temp\" 

    '~~> DIR C:\Temp\*.* > C:\Temp\MyFile.txt 
    retval = Shell("cmd.exe /c Dir " & sPath & "*.* > " & sPath & "MyFile.Txt") 
End Sub 

tüm y Şimdi

Volume in drive C is XXXXXXX 
Volume Serial Number is XXXXXXXXX 

Directory of C:\Temp 

10/08/2014 11:28 PM <DIR>   . 
10/08/2014 11:28 PM <DIR>   .. 
10/08/2014 11:27 PM    832 aaa.txt 
10/08/2014 11:28 PM     0 bbb.txt 
10/08/2014 11:26 PM     0 New Bitmap Image.bmp 
10/08/2014 11:26 PM     0 New Bitmap Image_2.bmp 
10/08/2014 11:26 PM     0 New Bitmap Image_2_2.bmp 
10/08/2014 11:26 PM     0 New Bitmap Image_3.bmp 
10/08/2014 11:26 PM     0 New Bitmap Image_3_2.bmp 
10/08/2014 11:26 PM     0 New Bitmap Image_4.bmp 
10/08/2014 11:26 PM     0 New Bitmap Image_4_2.bmp 
10/08/2014 11:26 PM     0 New Bitmap Image_5.bmp 
      10 File(s)   832 bytes 
      2 Dir(s) 424,786,952,192 bytes free 

(Bu myfile.txt saklanır budur) Yapmanız gereken metin dosyasını uzak klasörden klasörünüze kopyalamak ve sadece dosya isimlerini almak için onu ayrıştırmak. Bu işlevi çağırır

Sub filesTest() 
    Dim x() As String 
    x = Function_FileList("YOUR_PATH_AND_FOLDER_NAME") 
    Debug.Print Join(x, vbCrLf) 
    End Sub 

:

Answer 3

Bu, hızlı bir yıldırım olduğunu

Function Function_FileList(FolderLocation As String) 
    Function_FileList = Filter(Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & FolderLocation & """ /b /a-d").stdout.readall, vbCrLf), ".") 
End Function