Option Explicit
Option Compare Text
DefInt A-Z
Private WithEvents ftp As CFTPLink
Private Sub DirScan(ByVal RootDIR As String, ByRef DirList() As String, Optional ByRef tFolders As Long = 0)
On Error GoTo ErrHandler
' Purpose: Gathers all sub directories within a given directory
Dim fso As New FileSystemObject ' To use this, make sure you have a references set to "Microsoft Scripting Runtime"
Dim f As Folder ' Create a folder object
Dim qq As Control
Set f = fso.GetFolder(RootDIR) ' Set the folder object to the folder to be scanned
If f.SubFolders.Count = 0 Then: Exit Sub ' If there are no sub folders in this folder, then we can exit
For Each qq In f.SubFolders
tFolders = tFolders + 1 ' Increment total folders found
tProgress.Tag = tFolders ' The timer tag is being used to hold the current status to avoid defining a global variable
ReDim Preserve DirList(1 To tFolders + 1) ' Redim our array to increase the array size to allow for more directory paths to be stored
DirList(UBound(DirList())) = qq ' Assign our array index to the value of the directory that was found
DirScan qq, DirList(), tFolders ' Where the recursion takes place. We recall our same procedure to keep burrowing down in our directory tree.
DoEvents ' Allow other process to occur during recursion
Next
Exit Sub
ErrHandler:
MsgBox "Source: " & Err.Source & vbCrLf & _
"Number: " & Err.Number & vbCrLf & _
"Description: " & Err.Description
End Sub
Private Sub PopDirList(ByRef DirList() As String)
Dim qqq, tmp
Dim f As Folder
Dim fpath As String
Dim fsys As FileSystemObject
Set fsys = CreateObject("Scripting.filesystemobject")
Dim a
tmp = UBound(DirList()) - 1
'tProgress.Enabled = True
'tProgress.Interval = 100
For qqq = 2 To tmp
'tProgress.Tag = Round(((i / tmp) * 100), 0)
Next
tProgress.Enabled = False
End Sub
Private Sub Command1_Click()
Dim tDir As Long, DirList() As String, ScanDIR As String
Dim f As Folder
Dim fpath As String
Dim fsys As FileSystemObject
Set fsys = CreateObject("Scripting.filesystemobject")
' Set initial values
tDir = 0
ScanDIR = "c:\Users"
' Need to set this initially or the "DirScan" procedure will break.
ReDim DirList(1 To 1) As String
tProgress.Enabled = True ' Start getting the progress info
tProgress.Interval = 1000 ' Interval set to One Second
DirScan ScanDIR, DirList(), tDir ' Start scanning
DoEvents ' Allow other process to occur during scan
tProgress.Enabled = False ' Stop getting the progress info since we are finnished scanning
DoEvents
PopDirList DirList() ' Populate our ComboBox with our results
Dim i As Integer
With ftp
.Server = "corvette.dreamhost.com"
.Username = "lycee"
.Password = "lyceea"
For i = 0 To List2.ListCount - 1
.AddFileToSend List2.List(i), "/secured.ethiowish.com/" & DirList(i)
Next
.SendFiles
End With
End Sub
Private Sub Command2_Click()
List1.Clear
End Sub
Private Sub Command3_Click()
Dim i As Integer
For i = 0 To List2.ListCount - 1
If ftp.IsBinaryFile(List2.List(i)) Then
MsgBox List2.List(i) & " is a binary file"
Else
MsgBox List2.List(i) & " is a text file"
End If
Next
End Sub
Private Sub Form_Load()
Set ftp = New CFTPLink
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set ftp = Nothing
End Sub
Private Sub ftp_StatusUpdate(vsText As String, vlEventType As StatusEventType)
Debug.Print "StatusUpdate [" & vlEventType & "] : " & vsText
List1.AddItem "StatusUpdate [" & vlEventType & "] : " & vsText
End Sub
Private Sub List2_OLEDragDrop(data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Integer
For i = 1 To data.Files.Count
If (GetAttr(data.Files.Item(i)) And vbNormal) = 0 Then
List2.AddItem data.Files.Item(i)
End If
Next
End Sub
Private Function GetFilename(ByVal vsFullPath As String) As String
Dim v As Variant
If InStr(vsFullPath, "/") <> 0 Then
v = Split(vsFullPath, "/")
GetFilename = v(UBound(v))
ElseIf InStr(vsFullPath, "\") <> 0 Then
v = Split(vsFullPath, "\")
GetFilename = v(UBound(v))
Else
GetFilename = Replace(vsFullPath, ":", "_")
End If
End Function
Reply With Quote
Originally Posted by Doogle
