帖子: 33
主題: 10
精華: 0
積分: 74
點名: 0
作業系統: win7
軟體版本: 2007
閱讀權限: 20
性別: 男
註冊時間: 2011-6-9
最後登錄: 2024-7-8

1^# 跳轉到 » 正序看帖

字體大小: tT

發表於 2020-11-2 09:58 | 只看該作者

[發問] vba 讀取 ftp 裡面的檔案清單

我需要常常到公司的ftp抓取資料回來處理，
所以想要利用vba去看看有哪些檔案是更新過的，
在抓回來處理，就不用每一個資料夾都進去看。

但ftp有帳號密碼，無法使用一般dir的方式去尋找，
網路上找不到相關的資料(也可能是我找錯方向)，
是否有前輩可以提點一下我該如何做到，或是從哪個方向下手呢?

樓主熱帖

ML089

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2025
主題: 13
精華: 0
積分: 2053
點名: 0
作業系統: WIN7
軟體版本: Office2007
閱讀權限: 100
性別: 男
來自: 台北市
註冊時間: 2011-3-2
最後登錄: 2024-3-14

論壇榮譽勳章論壇贊助勳章熱烈參與勳章 2014馬年全勤獎章 2015羊年全勤獎章 2016猴年全勤獎章

12^#

發表於 2020-11-12 00:34 | 只看該作者

回復 11# Joforn

感謝，中文檔名可以正常顯示

{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

Joforn

　暱稱: 南宮飄雪

中學生 Rank: 2

帖子: 109
主題: 2
精華: 0
積分: 114
點名: 0
作業系統: Win7 Win10
軟體版本: Office 2019 WPS
閱讀權限: 20
性別: 男
來自: 深圳
註冊時間: 2013-2-2
最後登錄: 2024-11-6

11^#

發表於 2020-11-12 00:07 | 只看該作者

回復 Joforn

這VBA執行OK，可是中文檔案名稱回傳變成亂碼，請問這要如何修正，感恩

第一個VBA執行 ...
ML089 發表於 2020-11-11 14:17

.Path返回的并不是亂碼，而是將文字進行了Url編碼，可以通過Url解碼得到原字符串，也可以用下面的方式直接返回文字格式。

Public Property Get FTPSearch(ByVal FTPUrl As String, _
Optional ByVal UserName As String, _
Optional ByVal PassWord As String, _
Optional ByVal Port As Integer) As Collection
Dim objShell As Object, objFolder As Object
On Error Resume Next
If Len(FTPUrl) Then
If Len(UserName) Then FTPUrl = UserName & ":" & PassWord & "@" & FTPUrl
If Port > 0 Then FTPUrl = FTPUrl & ":" & Port
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace("FTP://" & FTPUrl)
End If
Set FTPSearch = New Collection
If objFolder Is Nothing Then Exit Function
With objFolder
If .ParentFolder.Self.IsFolder Then
If .ParentFolder.ParseName(.Self.Name) Is Nothing Then
Debug.Print "Error:Invalid Path!"
ElseIf objFolder.Self.IsBrowsable Then
Debug.Print "Error:Invalid Parameter!"
ElseIf objFolder.Self.IsFolder Then
Debug.Print "Start search files in path..."
With objFolder
FTPSearchWithShell FTPSearch, .ParentFolder.ParseName(.Self.Name).GetFolder
End With
Debug.Print "Files search completed."
End If
ElseIf objFolder.Self.IsFolder Then
Debug.Print "Start search files in path..."
With objFolder
FTPSearchWithShell FTPSearch, objFolder
End With
Debug.Print "Files search completed."
End If
End With
End Property
Private Sub FTPSearchWithShell(ByVal Searched As Collection, ByVal Folder As Object, Optional ByVal strPath As String)
Dim FolderItem As Object
Dim objFolder As Object
Dim subSearch As New Collection
On Error Resume Next
If Len(strPath) = 0 Then
Set objFolder = Folder
Do While (objFolder.ParentFolder.Self.IsFolder)
strPath = objFolder.Self.Name & "/" & strPath
Set objFolder = objFolder.ParentFolder
Loop
strPath = objFolder.Self.Path & strPath
End If
If Folder.Items.Count > 0 Then
Set subSearch = New Collection
For Each FolderItem In Folder.Items
With FolderItem
If .IsFolder Then
Set Folder = .GetFolder
If Folder.Items.Count Then subSearch.Add Folder
ElseIf .IsBrowsable Then
Searched.Add strPath & .Name
End If
End With
Next FolderItem
For Each Folder In subSearch
FTPSearchWithShell Searched, Folder
DoEvents
Next Folder
End If
End Sub
Sub Test()
Dim Files As Collection
Dim I As Long
Set Files = FTPSearch("118.163.50.55/firmware_software_version_files/", "xxxxx", "xxxx")
For I = 1 To Files.Count
Debug.Print Files.Item(I)
Next I
End Sub

複製代碼

世界那麼大，可我想去哪？

TOP

warhead

中學生 Rank: 2

帖子: 33
主題: 10
精華: 0
積分: 74
點名: 0
作業系統: win7
軟體版本: 2007
閱讀權限: 20
性別: 男
註冊時間: 2011-6-9
最後登錄: 2024-7-8

10^#

發表於 2020-11-11 15:33 | 只看該作者

回復 8# Joforn

程式可執行，但超出我功力太多，需要時間慢慢消化，謝謝。

TOP

ML089

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2025
主題: 13
精華: 0
積分: 2053
點名: 0
作業系統: WIN7
軟體版本: Office2007
閱讀權限: 100
性別: 男
來自: 台北市
註冊時間: 2011-3-2
最後登錄: 2024-3-14

論壇榮譽勳章論壇贊助勳章熱烈參與勳章 2014馬年全勤獎章 2015羊年全勤獎章 2016猴年全勤獎章

9^#

發表於 2020-11-11 14:17 | 只看該作者

回復 8# Joforn

這VBA執行OK，可是中文檔案名稱回傳變成亂碼，請問這要如何修正，感恩

第一個VBA執行中文檔案名稱回傳正常

{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

Joforn

　暱稱: 南宮飄雪

中學生 Rank: 2

帖子: 109
主題: 2
精華: 0
積分: 114
點名: 0
作業系統: Win7 Win10
軟體版本: Office 2019 WPS
閱讀權限: 20
性別: 男
來自: 深圳
註冊時間: 2013-2-2
最後登錄: 2024-11-6

8^#

發表於 2020-11-11 00:25 | 只看該作者

回復 7# warhead
用的是Shell32就不要去混用FSO了，直接用Shell32查找吧。

Option Explicit
Public Property Get FTPSearch(ByVal FTPUrl As String, _
Optional ByVal UserName As String, _
Optional ByVal PassWord As String, _
Optional ByVal Port As Integer) As Collection
Dim objShell As Object, objFolder As Object
On Error Resume Next
If Len(FTPUrl) Then
If Len(UserName) Then FTPUrl = UserName & ":" & PassWord & "@" & FTPUrl
If Port > 0 Then FTPUrl = FTPUrl & ":" & Port
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace("FTP://" & FTPUrl)
End If
FTPSearchWithShell FTPSearch, objFolder
End Property
Private Sub FTPSearchWithShell(ByRef Searched As Collection, ByVal Folder As Object)
Dim FolderItem As FolderItem
Dim subSearch As New Collection
On Error GoTo ErrorLOOP
If Searched Is Nothing Then Set Searched = New Collection
If Folder.Items.Count > 0 Then
Set subSearch = New Collection
For Each FolderItem In Folder.Items
With FolderItem
If .IsFolder Then
Set Folder = .GetFolder
If Folder.Items.Count Then subSearch.Add Folder
ElseIf .IsBrowsable Then
Searched.Add .Path
End If
End With
Next FolderItem
For Each Folder In subSearch
FTPSearchWithShell Searched, Folder
DoEvents
Next Folder
End If
EXITFunction:
On Error Resume Next
Exit Sub
ErrorLOOP:
Err.Clear
Resume EXITFunction
End Sub
Sub Test()
Dim Files As Collection
Dim I As Long
Set Files = FTPSearch("118.163.50.55/firmware_software_version_files/", "xxxxx", "xxxx")
For I = 1 To Files.Count
Debug.Print Files.Item(I)
Next I
End Sub

複製代碼

世界那麼大，可我想去哪？

TOP

warhead

中學生 Rank: 2

帖子: 33
主題: 10
精華: 0
積分: 74
點名: 0
作業系統: win7
軟體版本: 2007
閱讀權限: 20
性別: 男
註冊時間: 2011-6-9
最後登錄: 2024-7-8

7^#

發表於 2020-11-10 10:18 | 只看該作者

回復 6# Joforn

Private Function FTPFolder(ByVal Url As String, _
Optional ByVal UserName As String, _
Optional ByVal PassWord As String, _
Optional ByVal Port As Integer) As Object
Dim objShell As Object
If Len(Url) Then
If Len(UserName) Then Url = UserName & ":" & PassWord & "@" & Url
If Port > 0 Then Url = Url & ":" & Port
Set objShell = CreateObject("Shell.Application")
Set FTPFolder = objShell.Namespace("FTP://" & Url)
End If
End Function
Sub test()
Dim objFolder As Object
Dim objItem As Object
Dim selectFolder
Set objFolder = FTPFolder("118.163.50.55/firmware_software_version_files/", "xxxxx", "xxxx")
If Not (objFolder Is Nothing) Then
selectFolder = objFolder
Call 列出檔案清單(selectFolder)
End If
End Sub
Sub 列出檔案清單(ByVal theDir As String)
Dim pt As Range
Set pt = Sheet1.Range("a2")
Call 設定標題(1)
If Len(Dir(theDir, vbDirectory)) > 0 Then
If (GetAttr(theDir) And vbDirectory) = vbDirectory Then
Call FileIOUtility.RetrivalFileList(theDir, pt, 0)
End If
End If
pt.Worksheet.Columns("A:B").AutoFit
End Su
Function RetrivalFileList(ByVal strDir As String, ByRef myRange As Range, ByRef depth As Integer)
Dim thePath As String
Dim strSdir As String
Dim theDirs As Scripting.Folders
Dim theDir As Scripting.Folder
Dim theFile As Scripting.File
Dim myFso As Scripting.FileSystemObject
Dim subFolderCount As Integer
Set myFso = New Scripting.FileSystemObject
If Right(strDir, 1) <> "" Then strDir = strDir & ""
thePath = thePath & strDir
'列出第一層根目錄的檔案
If depth = 0 Then
For Each theFile In myFso.GetFolder(strDir).Files
myRange = theFile.Path
myRange.Next = theFile.Size
myRange.Next.Next = theFile.DateLastModified
Set myRange = myRange.Offset(1, 0)
Next
depth = 1
End If
'尋找所有子目錄的檔案
Set theDirs = myFso.GetFolder(strDir).SubFolders
For Each theDir In theDirs
For Each theFile In theDir.Files
myRange = theFile.Path
myRange.Next = theFile.Size
myRange.Next.Next = theFile.DateLastModified
Set myRange = myRange.Offset(1, 0)
Next
RetrivalFileList strDir:=theDir.Path, myRange:=myRange, depth:=depth
Next
Set myFso = Nothing
End Function