麻辣家族討論版版 - Powered by Discuz! Board

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

複製代碼

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

複製代碼

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

複製代碼

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

複製代碼