帖子: 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的方式去尋找，
網路上找不到相關的資料(也可能是我找錯方向)，
是否有前輩可以提點一下我該如何做到，或是從哪個方向下手呢?

樓主熱帖

cody

中學生 Rank: 2

帖子: 16
主題: 2
精華: 0
積分: 55
點名: 0
作業系統: macOS / Windows
軟體版本: Office 2010/2019
閱讀權限: 20
性別: 男
註冊時間: 2020-7-9
最後登錄: 2021-8-7

2^#

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

本帖最後由 cody 於 2020-11-4 16:27 編輯

回復 1# warhead

用 windows 內建 ftp.exe 讀取 Script 的方式
一般是將 ftp comment 做成文字檔, 再用 ftp.exe 去讀取執行
將結果存成文字檔後, 再讀入excel

TOP

Joforn

　暱稱: 南宮飄雪

中學生 Rank: 2

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

3^#

發表於 2020-11-5 23:32 | 只看該作者

本帖最後由 Joforn 於 2020-11-5 23:33 編輯

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
Set objFolder = FTPFolder("0.0.0.0", "username", "password")
If Not (objFolder Is Nothing) Then
For Each objItem In objFolder.Items
Debug.Print "Name=""" & objItem.Name & """ Size=" & objFolder.GetDetailsOf(objItem, 1) & " ModifyDate=" & objFolder.GetDetailsOf(objItem, 3)
Next
End If
End Sub

複製代碼

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

TOP

warhead

中學生 Rank: 2

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

4^#

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

回復 2# cody

好的，我在找時間研究看看ftp的comment，謝謝

TOP

warhead

中學生 Rank: 2

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

5^#

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

回復 3# Joforn

這方法可行，感激不盡....

另外在提問一個問題，如果裡面還有資料夾，我是將全部資料夾抓出來，
在一個一個資料夾進去檢查是否有新的檔案嗎?
或是有其他方式可行?

TOP

Joforn

　暱稱: 南宮飄雪

中學生 Rank: 2

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

6^#

發表於 2020-11-9 19:50 | 只看該作者

回復 5# warhead
遞歸查找和對比所有文件。

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

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

複製代碼

我將檔案路徑丟給selectFolder，會出問題

但如果我給selectFolder 的路徑是電腦本機的卻可以執行，

給selectFolder 完整的FTP路徑也會出錯，

是因為FTP查詢的方式跟本機的不一樣嗎??

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