how to total list of file in ftp folders

i want total list of file from ftp folders including subfolders files

right now i am using this code to get total files including sub folders

but when i am getting file list some time code stops in middle it doesnt show any errors

can some body suggest me any other method to get file name from ftp including sub folders.



[vba]
Dim RecievingSize As Boolean
Dim stopcrawl As Long

Private Function ITCReady(ShowMessage As Boolean)
'Check the state of itc, if it is not executing return true
If ITC.StillExecuting Then
ITCReady = False
If ShowMessage Then
'MsgBox "Please wait. FTP is still executing", vbInformation + vbOKOnly, "Busy"
End If
Else
ITCReady = True
End If
End Function



Private Sub cmdLogOff_Click()
On Error Resume Next
'Clear the list of remote files and log off
lstRemoteFile.Clear
ITC.Cancel

Do Until ITCReady(False)
DoEvents: DoEvents: DoEvents: DoEvents
'If (stopcrawl = 0) Then
' DoEvents: DoEvents: DoEvents: DoEvents
' Else
' GoTo exitcrawl
' End If
Loop
lblStatus = "Closing Connection"

If ITCReady(False) Then
ITC.Execute , "CLOSE"
Else
ITC.Cancel
End If
lblStatus = "Not Connected"
'cmdLogOn.Enabled = False
'cmdNewFolder.Enabled = False
'cmdDelete.Enabled = False
'cmdRename.Enabled = False
'cmdSize.Enabled = False
'cmdUpFolder.Enabled = False
'imgSendFile.Enabled = False
'imgReceiveFile.Enabled = False
'lstRemoteFile.Enabled = False
cmdLogOff.Enabled = False
cmdLogOn.Enabled = True

exitcrawl:
If (stopcrawl = 1) Then
ccrpAnimation1.Visible = False
ITC.Cancel
Exit Sub
End If

End Sub

Private Sub cmdLogOn_Click()
On Error Resume Next
Dim i As Integer, b As Boolean
'If no server or password is specified exit the sub
If txtServer = "" Or txtPassword = "" Then
MsgBox "You must specify a server and password.", vbInformation + vbOKOnly, "LogOn Failure"
Exit Sub
End If

'Set status label
lblStatus = "Connecting"

'Set protocol and server
ITC.Protocol = icFTP
ITC.URL = txtServer

'If no username is entered default to anonymous
If txtUserName = "" Then
ITC.UserName = "anonymous"
Else
ITC.UserName = txtUserName
End If


ITC.Cancel
cmdLogOn.Enabled = False
Close #2
Open App.path & "\login.dll" For Output As #2
Print #2, txtUserName.Text & ":" & txtPassword.Text & ":" & txtServer.Text
Close #2

'Set the password and connect
ITC.Password = txtPassword
ITC.RequestTimeout = 40000000
ITC.Execute , "DIR"
Do While ITC.StillExecuting
DoEvents: DoEvents: DoEvents
Loop
b = False
For i = 0 To lstRemoteFile.ListCount - 1
If (lstRemoteFile.List(i) = "../") Then
b = True
Exit For
End If
Next
If (b = False) Then lstRemoteFile.AddItem "../", 0

'Set status label, disable the log on button, and enable the log off button
lblStatus = "Connected"
cmdLogOn.Enabled = False
'cmdNewFolder.Enabled = True
'cmdDelete.Enabled = True
'cmdRename.Enabled = True
'cmdSize.Enabled = True
'cmdUpFolder.Enabled = True
'imgSendFile.Enabled = True
'imgReceiveFile.Enabled = True
'lstRemoteFile.Enabled = True
cmdLogOff.Enabled = True
'Command1_Click

'LogOnError:
''If logon fails alert the user
'MsgBox "Logon attempt failed", vbOKOnly + vbInformation, "LogOn Failure"
'ITC.Cancel
'lblStatus = "Not Connected"
'cmdLogOn.Enabled = True
''cmdNewFolder.Enabled = False
''cmdDelete.Enabled = False
''cmdRename.Enabled = False
''cmdSize.Enabled = False
''cmdUpFolder.Enabled = False
''imgSendFile.Enabled = False
''imgReceiveFile.Enabled = False
''lstRemoteFile.Enabled = False
'cmdLogOff.Enabled = False
'Exit Sub

End Sub


Private Sub cmdUpFolder_Click()
On Error Resume Next
Dim path() As String
Dim i As Integer, b As Boolean
'If the itc is ready then move up one directory and refresh the remote files list
If ITCReady(True) Then
ITC.Execute , "CDUP"

Do Until ITCReady(False)
DoEvents: DoEvents: DoEvents: DoEvents
' If (stopcrawl = 0) Then
' DoEvents: DoEvents: DoEvents: DoEvents
' Else
' GoTo exitcrawl
' End If
Loop
lstRemoteFile.Clear
ITC.Execute , "DIR"
b = False
For i = 0 To lstRemoteFile.ListCount - 1
If (lstRemoteFile.List(i) = "../") Then
b = True
Exit For
End If
Next
If (b = False) Then lstRemoteFile.AddItem "../", 0
lblStatus = "Connected"
path1 = Split(Label3.Caption, "/")
Label3.Caption = "/"
For z = 1 To UBound(path1) - 2
Label3.Caption = Label3.Caption & path1(z) & "/"
Next
End If
exitcrawl:
If (stopcrawl = 1) Then
ccrpAnimation1.Visible = False
ITC.Cancel
Exit Sub
End If
End Sub

Private Sub Command1_Click()
On Error Resume Next
Dim pth As String
'lstRemoteFile.Clear
Command1.Enabled = False
Command8.Enabled = True
ListView2.ListItems.Clear
pth = Label3.Caption
stopcrawl = 0
grid1.Rows = 10
Dim rc As Integer, lc As Integer, i As Integer, j As Integer
Dim b As Boolean
Do Until ITCReady(False)
Exit Sub
'DoEvents: DoEvents: DoEvents: DoEvents
Loop
ccrpAnimation1.Visible = True
ccrpAnimation1.OpenStandardAVIResource (aniresFindFolder)
If (lstRemoteFile.ListIndex <> -1) Then
lstRemoteFile_DblClick
Else
lstRemoteFile.ListIndex = lstRemoteFile.ListCount - 1
End If
Command2_Click
remfillist

lc = ListView1.ListItems.count
rc = remfile.ListCount
With grid1
.Row = 1

'Dim ioo As Integer

For i = 0 To lc - 1

'ioo = ioo + 1

.Col = 0
.Text = ListView1.ListItems.Item(i + 1).Text
.CellForeColor = &HFF&
.Col = 1
.Text = ListView1.ListItems.Item(i + 1).SubItems(1)
.CellForeColor = &HFF&
.Col = 2
.CellForeColor = &HFF&
.Text = "Not Found"
.Col = 3
.CellForeColor = &HFF&
.Text = "Not Found"

b = False
For j = 0 To rc - 1
remfile.ListIndex = j
rempath.ListIndex = j
If (stopcrawl = 0) Then
If (ListView1.ListItems.Item(i + 1).Text = remfile.Text) Then
b = True
.Col = 0
.CellForeColor = &HFF0000
.Col = 1
.CellForeColor = &HFF0000
.Col = 2
.Text = rempath.Text
.CellForeColor = &HFF0000
.Col = 3
.CellForeColor = &HFF0000
.Text = "Found"
End If
Else
GoTo exitcrawl
End If
Next

If b = False Then
'lstsfiles.AddItem ListView1.ListItems.Item(i + 1).Text
ListView2.ListItems.Add , , ListView1.ListItems.Item(i + 1).Text
ListView2.ListItems.Item(ListView2.ListItems.count).SubItems(1) = ListView1.ListItems.Item(i + 1).SubItems(1)
'ListView2.ListItems.Item(ListView2.ListItems.count).SubItems(2) = rempath.Text
End If
.Rows = .Rows + 1
.Row = .Row + 1
Next
'ccrpAnimation1.Visible = False

End With
ccrpAnimation1.Visible = False
Label3.Caption = pth
MsgBox ("Synchronizing Completed")

exitcrawl:
If (stopcrawl = 1) Then
ccrpAnimation1.Visible = False
stopcrawl = 0
Command8.Enabled = False
cmdLogOff_Click
remfile.Clear
rempath.Clear
ListView1.ListItems.Clear
Label3.Caption = "/"
Command8.Enabled = False
Command1.Enabled = True
Exit Sub
End If

remfile.Clear
rempath.Clear
ListView1.ListItems.Clear
Command8.Enabled = False
Command1.Enabled = True

'ITC.Cancel
'Do Until ITCReady(False)
' DoEvents: DoEvents: DoEvents: DoEvents
'Loop
'ITC.Execute , "CD " & Chr(34) & pth & Chr(34)
'Do Until ITCReady(False)
' DoEvents: DoEvents: DoEvents: DoEvents
'Loop
'lstRemoteFile.Clear
' ITC.Execute , "DIR"
' Do Until ITCReady(False)
' DoEvents: DoEvents: DoEvents: DoEvents
' Loop
' lblStatus = "Connected"


End Sub

Private Sub Command2_Click()
On Error Resume Next
Dim fs As FileSystemObject
Set fs = New FileSystemObject
Dim foldeer As folder
Dim Filnavn() As String
ListView1.ListItems.Clear
Set foldeer = fs.GetFolder(dirLocalDir.path)

For Each File In foldeer.Files
If (stopcrawl = 0) Then
Filnavn() = Split(File, "\")
'locfile.AddItem Filnavn(UBound(Filnavn()))
ListView1.ListItems.Add , , Filnavn(UBound(Filnavn()))
ListView1.ListItems.Item(ListView1.ListItems.count).SubItems(1) = foldeer.path
Else
Exit Sub
End If
Next
fillist foldeer
End Sub

Private Function remfillist()
On Error GoTo exitcrawl
Dim i As Integer, j As Integer, k As Integer, count As Integer, z As Integer
Dim fil(5000) As String, path1() As String
Dim b As Boolean
For k = 0 To lstRemoteFile.ListCount - 1
lstRemoteFile.ListIndex = k
fil(k) = lstRemoteFile.Text
Next
count = k
'j = -1
For i = k - 1 To 0 Step -1
If (stopcrawl = 1) Then GoTo exitcrawl
'If i <= lstRemoteFile.ListCount - 1 Then
'lstRemoteFile.ListIndex = i
If ITCReady(True) Then
' If Right(fil(i), 1) = "/" And fil(i) <> "../" Then
' If i = count - 1 Then
' ITC.Execute , "CD " & Chr(34) & fil(i) & Chr(34)
' Else
' ITC.Execute , "CD " & Chr(34) & "../" & fil(i) & Chr(34)
' End If
' End If
If Right(fil(i), 1) = "/" Then
If (fil(i) = "../") Then
path1 = Split(Label3.Caption, "/")
Label3.Caption = "/"
For z = 1 To UBound(path1) - 2
Label3.Caption = Label3.Caption & path1(z) & "/"
Next
Else
Label3.Caption = Label3.Caption & fil(i)
End If
ITC.Execute , "CD " & Chr(34) & fil(i) & Chr(34)
End If

Do Until ITCReady(False)
DoEvents: DoEvents: DoEvents: DoEvents
' If (stopcrawl = 0) Then
' DoEvents: DoEvents: DoEvents: DoEvents
' Else
' GoTo exitcrawl
' End If
Loop

lstRemoteFile.Clear

ITC.Execute , "DIR"


Do Until ITCReady(False)
DoEvents: DoEvents: DoEvents: DoEvents
' If (stopcrawl = 0) Then
' DoEvents: DoEvents: DoEvents: DoEvents
' Else
' GoTo exitcrawl
' End If
Loop
b = False
For j = 0 To lstRemoteFile.ListCount
If (lstRemoteFile.List(j) = "../") Then
b = True
Exit For
End If
Next j
If (b = False) Then lstRemoteFile.AddItem "../", 0
lblStatus = "Connected"
End If
'lstRemoteFile.ListIndex = lstRemoteFile.ListIndex - 1
If fil(i) <> "../" Then
remfillist
Else
Exit Function
End If
' End If
' Else
' Exit Function
' End If
Next i

exitcrawl:
If (stopcrawl = 1 Or Err) Then
If Err Then
MsgBox Err.Description
cmdLogOn.Enabled = True
cmdLogOff.Enabled = False
Err.Clear
ccrpAnimation1.Visible = False
Exit Function
Else
ccrpAnimation1.Visible = False
ITC.Cancel
Exit Function
End If
End If

End Function

Private Sub Command3_Click()
remfillist
End Sub

Private Sub Command4_Click()
'Set objWord = CreateObject("Word.Application")
'objWord.Caption = "Test Caption"
'objWord.Visible = True
'
'Set objDoc = objWord.Documents.Open(App.Path & "\login.docx")
'
'Set objRange = objDoc.Bookmarks("NameBookmark").Range
'objRange.Text = "Bob"
'
'Set objRange = objDoc.Bookmarks("AddressBookmark").Range
'objRange.Text = "999"
'
'
'
'
'Set objWord = CreateObject("Word.Application")
'Set objDoc = objWord.Documents.Open("c:\scripts\word\bookmarkdoc.doc")
'Set objRange = objDoc.Bookmarks("NameBookmark").Range
'
'Wscript.Echo objRange.Text
'
'Set objRange = objDoc.Bookmarks("AddressBookmark").Range
'Wscript.Echo objRange.Text
'
'objWord.Quit
End Sub

Private Sub Command5_Click()
On Error Resume Next
Dim i As Integer, j As Integer
fraLoginInfo.Visible = False
fraLocalFiles.Visible = False
fraRemoteFiles.Visible = False
Frame1.Visible = False
Command6.Visible = True
Command7.Visible = True
With grid1
.Top = 700
.Width = 11800
.Cols = 4
.Row = 0
.Col = 0
.ColWidth(0) = 3000
.Text = "File Name"
.Col = 1
.ColWidth(1) = 3500
.Text = "Local Path"
.Col = 2
.ColWidth(2) = 4000
.Text = "Ftp Path"
.Col = 3
.ColWidth(3) = 990
.Text = "Report"
.ColAlignment(0) = 0
.ColAlignment(1) = 0
.ColAlignment(2) = 0

'For i = 1 To ListView1.ListItems.count
'rempath.ListIndex = i - 1
'.Row = i
'.Col = 0
'.Text = ListView1.ListItems.Item(i).Text
'.Col = 1
'.Text = ListView1.ListItems.Item(i).SubItems(1)
'
'.Rows = .Rows + 1
'Next
.Height = .Rows * 150
If (.Height > 6000) Then .Height = 6000

'For j = 0 To .Rows - 1
' .Row = j
' .Col = 3
' .CellBackColor = &H8000000D
' For i = 1 To ListView2.ListItems.count
' If (.Text = ListView2.ListItems.Item(i).Text) Then
' .CellBackColor = &H80000018
' Else
' .Col = 2
' .Text = remfile.Text
' Next
'Next
.Visible = True
End With
End Sub

Private Sub Command6_Click()
fraLoginInfo.Visible = True
fraLocalFiles.Visible = True
fraRemoteFiles.Visible = True
Frame1.Visible = True
Command6.Visible = False
Command7.Visible = False
grid1.Visible = False
End Sub

Private Sub Command7_Click()
On Error GoTo exitcrawl
Dim mydoc As Excel.Application
Close #2
Set mydoc = New Excel.Application 'create new instance of words
With mydoc
.Visible = True

.Workbooks.Add

For a = 0 To grid1.Rows - 1
grid1.Row = a
grid1.Col = 0
.Cells(a + 1, 1) = grid1.Text
grid1.Col = 1
.Cells(a + 1, 2) = grid1.Text
grid1.Col = 2
.Cells(a + 1, 3) = grid1.Text
grid1.Col = 3
.Cells(a + 1, 4) = grid1.Text
Next a
End With
Set mydoc = Nothing
exitcrawl:
Exit Sub
End Sub

Private Sub Command8_Click()
stopcrawl = 1

End Sub

Private Sub Command9_Click()
On Error Resume Next
Dim str As String, str1() As String
str = dirLocalDir.path
str1 = Split(str, "\")
str = ""
For i = 0 To UBound(str1) - 1
str = str + str1(i) + "\"
Next
dirLocalDir.path = str
dirLocalDir.Refresh
End Sub

Private Sub dirLocalDir_Change()
'filLocalFile.Path = dirLocalDir.Path
End Sub
Private Function fillist(foldeer1 As folder)
On Error Resume Next
Dim Filnavn() As String
Dim folder As folder, folder1 As folder

For Each folder In foldeer1.SubFolders
If (stopcrawl = 0) Then
fillist folder
For Each File In folder.Files
If (stopcrawl = 0) Then
Filnavn() = Split(File, "\")
ListView1.ListItems.Add , , Filnavn(UBound(Filnavn()))
ListView1.ListItems.Item(ListView1.ListItems.count).SubItems(1) = folder.path
'locfile.AddItem Filnavn(UBound(Filnavn()))
Else
GoTo exitcrawl
End If
Next
Else
GoTo exitcrawl
End If
Next

exitcrawl:
If (stopcrawl = 1) Then
ccrpAnimation1.Visible = False
ITC.Cancel
Exit Function
End If
End Function

Private Sub dirLocalDir_Click()
'dirLocalDir.Path = dirLocalDir.Path & "\" & dirLocalDir.List(dirLocalDir.TopIndex)
End Sub

Private Sub drvLocalDrive_Change()
On Error GoTo DriveError
dirLocalDir.path = drvLocalDrive.Drive
Exit Sub

DriveError:
MsgBox "Error accessing selected drive.", vbCritical + vbOKOnly, "Error"
Resume Next
End Sub

Private Sub filLocalFile_Click()

End Sub

Private Sub Form_Load()
On Error Resume Next
Dim sfiletext As String
Dim str() As String
Open App.path & "\login.dll" For Input As #1
Do While Not EOF(1)
Input #1, sfiletext 'show the text
Loop
Close #1
str = Split(sfiletext, ":")
If (UBound(str) = 2) Then
txtUserName.Text = str(0)
txtPassword.Text = str(1)
txtServer.Text = str(2)
End If
'Set RecievingSize to false because it must logon first
RecievingSize = False
Command8.Enabled = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
'Cancel any tasks that the itc is doing
If ITC.StillExecuting Then ITC.Cancel
'Loop
End Sub

Private Sub ITC_StateChanged(ByVal State As Integer)
On Error Resume Next
'Check the state of the itc, and change the status accordingly
Dim Data1, RemoteFiles
Dim RemoteFileName As String

Select Case State
Case icResolvingHost
lblStatus = "Finding Host IP Address"
Case icHostResolved
lblStatus = "IP Address Found"
Case icConnecting
lblStatus = "Connecting To Host"
Case icConnected
lblStatus = "Connected"
Case icRequesting
lblStatus = "Sending Request"
Case icRequestSent
lblStatus = "Request Sent"
Case icReceivingResponse
lblStatus = "Receiving Response"
Case icResponseReceived
lblStatus = "Response Received"
Case icDisconnecting
lblStatus = "Disconnecting"
Case icDisconnected
lblStatus = "Not Connected"
cmdLogOff.Enabled = False
cmdLogOn.Enabled = True
Case icError
If ITC.ResponseCode = 12030 Then
lblStatus = "Not Connected"
cmdLogOn.Enabled = False
cmdNewFolder.Enabled = False
cmdDelete.Enabled = False
cmdRename.Enabled = False
cmdSize.Enabled = False
cmdUpFolder.Enabled = False
imgSendFile.Enabled = False
imgReceiveFile.Enabled = False
lstRemoteFile.Enabled = False
cmdLogOff.Enabled = False
cmdLogOn.Enabled = True
ITC.Cancel
End If
If ITC.ResponseCode <> 87 Then
MsgBox ITC.ResponseCode & " " & ITC.ResponseInfo, vbOKOnly + vbCritical, "Error"
End If
Case icResponseCompleted
'loop until you get all data
Do While True
Data1 = ITC.GetChunk(4096, icString)
If Len(Data1) = 0 Then Exit Do
DoEvents
RemoteFiles = RemoteFiles & Data1

Loop

Beep

'If it is recieving size data tell the user the size and then exit the sub
If RecievingSize Then
MsgBox "The size of file " & lstRemoteFile.Text & " is " & RemoteFiles & " bytes", vbInformation + vbOKOnly, "Size"
Exit Sub
End If

'Loop through, check for carriage returns to get each file name and add to listbox
For i = 1 To Len(RemoteFiles)
If Mid(RemoteFiles, i, 1) = Chr(13) Then
If Trim(RemoteFileName) <> "" Then
If Right(RemoteFileName, 1) = "/" Then
lstRemoteFile.AddItem RemoteFileName

Else
remfile.AddItem RemoteFileName
rempath.AddItem Label3.Caption
End If
RemoteFileName = ""
End If
Else
If Mid(RemoteFiles, i, 1) <> Chr(10) Then
RemoteFileName = RemoteFileName & Mid(RemoteFiles, i, 1)
End If
End If
Next i
'lstRemoteFile.ListIndex = lstRemoteFile.ListCount - 1
End Select

End Sub

Private Sub lstRemoteFile_DblClick()
On Error Resume Next
Dim b As Boolean
Dim path1() As String
Do Until ITCReady(False)
DoEvents: DoEvents: DoEvents: DoEvents
' If (stopcrawl = 0) Then
' DoEvents: DoEvents: DoEvents: DoEvents
' Else
' GoTo exitcrawl
' End If
Loop
'If the itc is ready, check that the selected is a folder and change the directory
'If ITCReady(True) Then
If (Right(lstRemoteFile.Text, 1) = "/" And stopcrawl = 0) Then
If (lstRemoteFile.Text = "../") Then
path1 = Split(Label3.Caption, "/")
Label3.Caption = "/"
For z = 1 To UBound(path1) - 2
Label3.Caption = Label3.Caption & path1(z) & "/"
Next
Else
Label3.Caption = Label3.Caption & lstRemoteFile.Text
End If

ITC.Execute , "CD " & Chr(34) & lstRemoteFile.Text & Chr(34)
Do Until ITCReady(False)
DoEvents: DoEvents: DoEvents: DoEvents
' If (stopcrawl = 0) Then
' DoEvents: DoEvents: DoEvents: DoEvents
' Else
' GoTo exitcrawl
' End If
Loop
' Else
' 'Call imgReceiveFile_Click
' Exit Sub
' End If

lstRemoteFile.Clear
ITC.Execute , "DIR"
Do Until ITCReady(False)
DoEvents: DoEvents: DoEvents: DoEvents
' If (stopcrawl = 0) Then
' DoEvents: DoEvents: DoEvents: DoEvents
' Else
' GoTo exitcrawl
' End If
Loop
b = False
For i = 0 To lstRemoteFile.ListCount - 1
If (lstRemoteFile.List(i) = "../") Then
b = True
Exit For
End If
Next
If (b = False) Then lstRemoteFile.AddItem "../", 0
lblStatus = "Connected"
End If
exitcrawl:
If (stopcrawl = 1) Then
ccrpAnimation1.Visible = False
ITC.Cancel
Exit Sub
End If
End Sub
[/vba]

Hi shamsam1,

I don't have a way to test this, but I would comment out all the "on error resume next" until you get the error.

If you post the project with all of the files zipped up, give me the url you are using to ftp to I will test it out tonight and see what happens.

hey thomas i h ave sent u email. u can test it today..in ftp i have loaded only some data.

OK I will test tonight and post back.

while i am running the program it get stuck in middle this is one of the problem i face...

hello Tommy

did u get a chance to test my program...

Hey Sham,

I just sent you an e-mail. Yes I am working on it. Right now I can't get a list of files but I don't think it is processing the commands. I will continue to look at it over the weekend and get back with you when I have some results.

Hey Sham, :hi:

I have this, I found why some of the files were showing up and why not.

I was working on it and got it pretty far along but for some reason the pass word changed on your end.

[VBA]Dim RecievingSize As Boolean
Dim stopcrawl As Long
Private Function ITCReady(ShowMessage As Boolean)
'Check the state of itc, if it is not executing return true
If ITC.StillExecuting Then
ITCReady = False
If ShowMessage Then
lblStatus = "*** BUSY ***"
'MsgBox "Please wait. FTP is still executing", vbInformation + vbOKOnly, "Busy"
End If
Else
ITCReady = True
End If
End Function
Private Sub cmdLogOff_Click()
'On Error Resume Next
'Clear the list of remote files and log off
lstRemoteFile.Clear
ITC.Cancel
Do Until ITCReady(False)
DoEvents: DoEvents: DoEvents: DoEvents
'If (stopcrawl = 0) Then
' DoEvents: DoEvents: DoEvents: DoEvents
' Else
' GoTo exitcrawl
' End If
Loop
lblStatus = "Closing Connection"
If ITCReady(False) Then
ITC.Execute , "CLOSE"
Else
ITC.Cancel
End If
lblStatus = "Not Connected"
cmdLogOff.Enabled = False
cmdLogOn.Enabled = True
exitcrawl:
If (stopcrawl = 1) Then
ccrpAnimation1.Visible = False
ITC.Cancel
Exit Sub
End If
End Sub
Private Sub cmdLogOn_Click()
'On Error Resume Next
Dim i As Integer, b As Boolean
'If no server or password is specified exit the sub
If txtServer = "" Or txtPassword = "" Then
MsgBox "You must specify a server and password.", vbInformation + vbOKOnly, "LogOn Failure"
Exit Sub
End If
'Set status label
lblStatus = "Connecting"
'Set protocol and server
ITC.Protocol = InetCtlsObjects.ProtocolConstants.icFTP
ITC.URL = txtServer
'If no username is entered default to anonymous
If txtUserName = "" Then
ITC.UserName = "anonymous"
Else
ITC.UserName = txtUserName
End If
ITC.Cancel
cmdLogOn.Enabled = False
Close #2
Open App.path & "\login.dll" For Output As #2
Print #2, txtUserName.Text & ":" & txtPassword.Text & ":" & txtServer.Text
Close #2
'Set the password and connect
ITC.Password = txtPassword
' **** START CHANGE - Tommy - 14-Mar-2009 13:50 ****
'changed the timeout size
ITC.RequestTimeout = 20 '40000000
' **** END CHANGE - Tommy - 14-Mar-2009 13:50 ****
ITC.Execute , "DIR"
Do While ITC.StillExecuting
DoEvents ': DoEvents: DoEvents
Loop
' **** START CHANGE - Tommy - 14-Mar-2009 13:49 ****
'added this subroutine to fille the remote listbox
SetListFiles
' **** END CHANGE - Tommy - 14-Mar-2009 13:49 ****
'Set status label, disable the log on button, and enable the log off button
lblStatus = "Connected"
cmdLogOn.Enabled = False
cmdLogOff.Enabled = True
End Sub
' **** START CHANGE - U - 14-Mar-2009 13:56 ****
'This is the subroutine I added
Sub SetListFiles()
Dim mData() As String, mTemp As String, mBrk As String, mI As Long
Dim b As Boolean, i As Long
mBrk = vbCrLf
Do Until ITCReady(False)
DoEvents: DoEvents: DoEvents: DoEvents
Loop
mTemp = GetChunk
mData = Split(mTemp, mBrk)
For mI = 0 To UBound(mData, 1)
If mData(mI) <> "" Then lstRemoteFile.AddItem mData(mI)
Next
b = False
For i = 0 To lstRemoteFile.ListCount - 1
If (lstRemoteFile.List(i) = "../") Then
b = True
Exit For
End If
Next
If (b = False) Then lstRemoteFile.AddItem "../", 0
End Sub
' **** END CHANGE - U - 14-Mar-2009 13:56 ****
Private Sub cmdUpFolder_Click()
'On Error Resume Next
Dim path() As String
Dim i As Integer, b As Boolean
'If the itc is ready then move up one directory and refresh the remote files list
If ITCReady(True) Then
ITC.Execute , "CDUP"
Do Until ITCReady(False)
DoEvents: DoEvents: DoEvents: DoEvents
' If (stopcrawl = 0) Then
' DoEvents: DoEvents: DoEvents: DoEvents
' Else
' GoTo exitcrawl
' End If
Loop
lstRemoteFile.Clear
ITC.Execute , "DIR"
' **** START CHANGE - Tommy - 14-Mar-2009 13:52 ****
'added this suboutine
SetListFiles
' **** END CHANGE - Tommy - 14-Mar-2009 13:52 ****
lblStatus = "Connected"
path1 = Split(Label3.Caption, "/")
Label3.Caption = "/"
For z = 1 To UBound(path1) - 2
Label3.Caption = Label3.Caption & path1(z) & "/"
Next
End If
exitcrawl:
If (stopcrawl = 1) Then
ccrpAnimation1.Visible = False
ITC.Cancel
Exit Sub
End If
End Sub
Private Sub Command1_Click()
'On Error Resume Next
Dim pth As String
'lstRemoteFile.Clear
Command1.Enabled = False
Command8.Enabled = True
ListView2.ListItems.Clear
pth = Label3.Caption
stopcrawl = 0
grid1.Rows = 10
Dim rc As Integer, lc As Integer, i As Integer, j As Integer
Dim b As Boolean
Do Until ITCReady(False)
Exit Sub
'DoEvents: DoEvents: DoEvents: DoEvents
Loop
ccrpAnimation1.Visible = True
ccrpAnimation1.OpenStandardAVIResource (aniresFindFolder)
If (lstRemoteFile.ListIndex <> -1) Then
lstRemoteFile_DblClick
Else
lstRemoteFile.ListIndex = lstRemoteFile.ListCount - 1
End If
Command2_Click
remfillist
lc = ListView1.ListItems.count
rc = remfile.ListCount
With grid1
.Row = 1
'Dim ioo As Integer
For i = 0 To lc - 1
'ioo = ioo + 1
.Col = 0
.Text = ListView1.ListItems.Item(i + 1).Text
.CellForeColor = &HFF&
.Col = 1
.Text = ListView1.ListItems.Item(i + 1).SubItems(1)
.CellForeColor = &HFF&
.Col = 2
.CellForeColor = &HFF&
.Text = "Not Found"
.Col = 3
.CellForeColor = &HFF&
.Text = "Not Found"
b = False
For j = 0 To rc - 1
remfile.ListIndex = j
rempath.ListIndex = j
If (stopcrawl = 0) Then
If (ListView1.ListItems.Item(i + 1).Text = remfile.Text) Then
b = True
.Col = 0
.CellForeColor = &HFF0000
.Col = 1
.CellForeColor = &HFF0000
.Col = 2
.Text = rempath.Text
.CellForeColor = &HFF0000
.Col = 3
.CellForeColor = &HFF0000
.Text = "Found"
End If
Else
GoTo exitcrawl
End If
Next
If b = False Then
'lstsfiles.AddItem ListView1.ListItems.Item(i + 1).Text
ListView2.ListItems.Add , , ListView1.ListItems.Item(i + 1).Text
ListView2.ListItems.Item(ListView2.ListItems.count).SubItems(1) = ListView1.ListItems.Item(i + 1).SubItems(1)
'ListView2.ListItems.Item(ListView2.ListItems.count).SubItems(2) = rempath.Text
End If
.Rows = .Rows + 1
.Row = .Row + 1
Next
'ccrpAnimation1.Visible = False
End With
ccrpAnimation1.Visible = False
Label3.Caption = pth
MsgBox ("Synchronizing Completed")
exitcrawl:
If (stopcrawl = 1) Then
ccrpAnimation1.Visible = False
stopcrawl = 0
Command8.Enabled = False
cmdLogOff_Click
remfile.Clear
rempath.Clear
ListView1.ListItems.Clear
Label3.Caption = "/"
Command8.Enabled = False
Command1.Enabled = True
Exit Sub
End If
remfile.Clear
rempath.Clear
ListView1.ListItems.Clear
Command8.Enabled = False
Command1.Enabled = True
End Sub
Private Sub Command2_Click()
'On Error Resume Next
Dim fs As FileSystemObject
Set fs = New FileSystemObject
Dim foldeer As folder
Dim Filnavn() As String
ListView1.ListItems.Clear
Set foldeer = fs.GetFolder(dirLocalDir.path)
For Each File In foldeer.Files
If (stopcrawl = 0) Then
Filnavn() = Split(File, "\")
'locfile.AddItem Filnavn(UBound(Filnavn()))
ListView1.ListItems.Add , , Filnavn(UBound(Filnavn()))
ListView1.ListItems.Item(ListView1.ListItems.count).SubItems(1) = foldeer.path
Else
Exit Sub
End If
Next
fillist foldeer
End Sub
Private Function remfillist()
On Error GoTo exitcrawl
Dim i As Integer, j As Integer, k As Integer, count As Integer, z As Integer
Dim fil(5000) As String, path1() As String
Dim b As Boolean
For k = 0 To lstRemoteFile.ListCount - 1
lstRemoteFile.ListIndex = k
fil(k) = lstRemoteFile.Text
Next
count = k
'j = -1
For i = k - 1 To 0 Step -1
If (stopcrawl = 1) Then GoTo exitcrawl
If ITCReady(True) Then
If Right(fil(i), 1) = "/" Then
If (fil(i) = "../") Then
path1 = Split(Label3.Caption, "/")
Label3.Caption = "/"
For z = 1 To UBound(path1) - 2
Label3.Caption = Label3.Caption & path1(z) & "/"
Next
Else
Label3.Caption = Label3.Caption & fil(i)
End If
ITC.Execute , "CD " & Chr(34) & fil(i) & Chr(34)
End If
Do Until ITCReady(False)
DoEvents: DoEvents: DoEvents: DoEvents
Loop
lstRemoteFile.Clear
ITC.Execute , "DIR"
Do Until ITCReady(False)
DoEvents: DoEvents: DoEvents: DoEvents
Loop
' **** START CHANGE - Tommy - 14-Mar-2009 13:53 ****
'added this subroutine
SetListFiles
' **** END CHANGE - Tommy - 14-Mar-2009 13:53 ****
lblStatus = "Connected"
End If
'lstRemoteFile.ListIndex = lstRemoteFile.ListIndex - 1
If fil(i) <> "../" Then
remfillist
Else
Exit Function
End If
Next i
exitcrawl:
If (stopcrawl = 1 Or Err) Then
If Err Then
MsgBox Err.Description
cmdLogOn.Enabled = True
cmdLogOff.Enabled = False
Err.Clear
ccrpAnimation1.Visible = False
Exit Function
Else
ccrpAnimation1.Visible = False
ITC.Cancel
Exit Function
End If
End If
End Function
Private Sub Command3_Click()
remfillist
End Sub
Private Sub Command5_Click()
'On Error Resume Next
Dim i As Integer, j As Integer
fraLoginInfo.Visible = False
fraLocalFiles.Visible = False
fraRemoteFiles.Visible = False
Frame1.Visible = False
Command6.Visible = True
Command7.Visible = True
With grid1
.Top = 700
.Width = 11800
.Cols = 4
.Row = 0
.Col = 0
.ColWidth(0) = 3000
.Text = "File Name"
.Col = 1
.ColWidth(1) = 3500
.Text = "Local Path"
.Col = 2
.ColWidth(2) = 4000
.Text = "Ftp Path"
.Col = 3
.ColWidth(3) = 990
.Text = "Report"
.ColAlignment(0) = 0
.ColAlignment(1) = 0
.ColAlignment(2) = 0
.Height = .Rows * 150
If (.Height > 6000) Then .Height = 6000
.Visible = True
End With
End Sub
Private Sub Command6_Click()
fraLoginInfo.Visible = True
fraLocalFiles.Visible = True
fraRemoteFiles.Visible = True
Frame1.Visible = True
Command6.Visible = False
Command7.Visible = False
grid1.Visible = False
End Sub
Private Sub Command7_Click()
On Error GoTo exitcrawl
Dim mydoc As Excel.Application
Close #2
Set mydoc = New Excel.Application 'create new instance of words
With mydoc
.Visible = True
.Workbooks.Add
For a = 0 To grid1.Rows - 1
grid1.Row = a
grid1.Col = 0
.Cells(a + 1, 1) = grid1.Text
grid1.Col = 1
.Cells(a + 1, 2) = grid1.Text
grid1.Col = 2
.Cells(a + 1, 3) = grid1.Text
grid1.Col = 3
.Cells(a + 1, 4) = grid1.Text
Next a
End With
Set mydoc = Nothing
exitcrawl:
Exit Sub
End Sub
Private Sub Command8_Click()
stopcrawl = 1
End Sub
Private Sub Command9_Click()
'On Error Resume Next
Dim str As String, str1() As String
str = dirLocalDir.path
str1 = Split(str, "\")
str = ""
For i = 0 To UBound(str1) - 1
str = str + str1(i) + "\"
Next
dirLocalDir.path = str
dirLocalDir.Refresh
End Sub
Private Sub dirLocalDir_Change()
'filLocalFile.Path = dirLocalDir.Path
End Sub
Private Function fillist(foldeer1 As folder)
'On Error Resume Next
Dim Filnavn() As String
Dim folder As folder, folder1 As folder
For Each folder In foldeer1.SubFolders
If (stopcrawl = 0) Then
fillist folder
For Each File In folder.Files
If (stopcrawl = 0) Then
Filnavn() = Split(File, "\")
ListView1.ListItems.Add , , Filnavn(UBound(Filnavn()))
ListView1.ListItems.Item(ListView1.ListItems.count).SubItems(1) = folder.path
'locfile.AddItem Filnavn(UBound(Filnavn()))
Else
GoTo exitcrawl
End If
Next
Else
GoTo exitcrawl
End If
Next
exitcrawl:
If (stopcrawl = 1) Then
ccrpAnimation1.Visible = False
ITC.Cancel
Exit Function
End If
End Function
Private Sub dirLocalDir_Click()
'dirLocalDir.Path = dirLocalDir.Path & "\" & dirLocalDir.List(dirLocalDir.TopIndex)
End Sub
Private Sub drvLocalDrive_Change()
On Error GoTo DriveError
dirLocalDir.path = drvLocalDrive.Drive
Exit Sub
DriveError:
MsgBox "Error accessing selected drive.", vbCritical + vbOKOnly, "Error"
Resume Next
End Sub
Private Sub filLocalFile_Click()
End Sub
Private Sub Form_Load()
'On Error Resume Next
Dim sfiletext As String
Dim str() As String
Open App.path & "\login.dll" For Input As #1
Do While Not EOF(1)
Input #1, sfiletext 'show the text
Loop
Close #1
str = Split(sfiletext, ":")
If (UBound(str) = 2) Then
txtUserName.Text = str(0)
txtPassword.Text = str(1)
txtServer.Text = str(2)
End If
'Set RecievingSize to false because it must logon first
RecievingSize = False
Command8.Enabled = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
'On Error Resume Next
'Cancel any tasks that the itc is doing
If ITC.StillExecuting Then ITC.Cancel
'Loop
End Sub
Private Sub ITC_StateChanged(ByVal State As Integer)
Dim b As Boolean
'On Error Resume Next
'Check the state of the itc, and change the status accordingly
Dim Data1, RemoteFiles
Dim RemoteFileName As String
Select Case State
Case icResolvingHost
lblStatus = "Finding Host IP Address"
Case icHostResolved
lblStatus = "IP Address Found"
Case icConnecting
lblStatus = "Connecting To Host"
Case icConnected
lblStatus = "Connected"
Case icRequesting
lblStatus = "Sending Request"
Timer1 = True
Case icRequestSent
lblStatus = "Request Sent"
Case icReceivingResponse
lblStatus = "Receiving Response"
Case icResponseReceived
lblStatus = "Response Received"
Case icDisconnecting
lblStatus = "Disconnecting"
Case icDisconnected
lblStatus = "Not Connected"
cmdLogOff.Enabled = False
cmdLogOn.Enabled = True
Case icError
If ITC.ResponseCode = 12030 Then
lblStatus = "Not Connected"
cmdLogOn.Enabled = False
cmdNewFolder.Enabled = False
cmdDelete.Enabled = False
cmdRename.Enabled = False
cmdSize.Enabled = False
cmdUpFolder.Enabled = False
imgSendFile.Enabled = False
imgReceiveFile.Enabled = False
lstRemoteFile.Enabled = False
cmdLogOff.Enabled = False
cmdLogOn.Enabled = True
ITC.Cancel
End If
If ITC.ResponseCode <> 87 Then
MsgBox ITC.ResponseCode & " " & ITC.ResponseInfo, vbOKOnly + vbCritical, "Error"
End If
Case icResponseCompleted
'loop until you get all data
RemoteFiles = GetChunk
Beep
'If it is recieving size data tell the user the size and then exit the sub
If RecievingSize Then
MsgBox "The size of file " & lstRemoteFile.Text & " is " & RemoteFiles & " bytes", vbInformation + vbOKOnly, "Size"
Exit Sub
End If
'Loop through, check for carriage returns to get each file name and add to listbox
For i = 1 To Len(RemoteFiles)
If Mid(RemoteFiles, i, 1) = Chr(13) Then
If Trim(RemoteFileName) <> "" Then
If Right(RemoteFileName, 1) = "/" Then
lstRemoteFile.AddItem RemoteFileName
Else
remfile.AddItem RemoteFileName
rempath.AddItem Label3.Caption
End If
RemoteFileName = ""
End If
Else
If Mid(RemoteFiles, i, 1) <> Chr(10) Then
RemoteFileName = RemoteFileName & Mid(RemoteFiles, i, 1)
End If
End If
Next i
b = False
For i = 0 To lstRemoteFile.ListCount - 1
If (lstRemoteFile.List(i) = "../") Then
b = True
Exit For
End If
Next
If (b = False) Then lstRemoteFile.AddItem "../", 0
'lstRemoteFile.ListIndex = lstRemoteFile.ListCount - 1
End Select
End Sub
Private Sub lstRemoteFile_DblClick()
'On Error Resume Next
Dim b As Boolean
Dim path1() As String
Do Until ITCReady(False)
DoEvents: DoEvents: DoEvents: DoEvents
' If (stopcrawl = 0) Then
' DoEvents: DoEvents: DoEvents: DoEvents
' Else
' GoTo exitcrawl
' End If
Loop
'If the itc is ready, check that the selected is a folder and change the directory
'If ITCReady(True) Then
If (Right(lstRemoteFile.Text, 1) = "/" And stopcrawl = 0) Then
If (lstRemoteFile.Text = "../") Then
path1 = Split(Label3.Caption, "/")
Label3.Caption = "/"
For z = 1 To UBound(path1) - 2
Label3.Caption = Label3.Caption & path1(z) & "/"
Next
Else
Label3.Caption = Label3.Caption & lstRemoteFile.Text
End If
ITC.Execute , "CD " & Chr(34) & lstRemoteFile.Text & Chr(34)
Do Until ITCReady(False)
DoEvents: DoEvents: DoEvents: DoEvents
' If (stopcrawl = 0) Then
' DoEvents: DoEvents: DoEvents: DoEvents
' Else
' GoTo exitcrawl
' End If
Loop
' Else
' 'Call imgReceiveFile_Click
' Exit Sub
' End If
lstRemoteFile.Clear
ITC.Execute , "DIR"
' **** START CHANGE - U - 14-Mar-2009 13:55 ****
'added this subroutine
SetListFiles
' **** END CHANGE - U - 14-Mar-2009 13:55 ****
lblStatus = "Connected"
End If
exitcrawl:
If (stopcrawl = 1) Then
ccrpAnimation1.Visible = False
ITC.Cancel
Exit Sub
End If
End Sub
' **** START CHANGE - Tommy - 14-Mar-2009 13:55 ****
'I got this subroutine off of the internet somewhere it was part of ftpvb
Function GetChunk() As String

Dim strChunk As String
Dim strText As String

strText = ""
strChunk = ""

Do
DoEvents
strChunk = ITC.GetChunk(1024, icString)
If Len(strChunk) = 0 Then Exit Do
strText = strText & strChunk
Loop

GetChunk = strText

End Function[/VBA]

I also noticed that sometimes the ftp connection seemed to hang for around 30 seconds sometimes, I was working on this when the password changed.

ya there was problem with ftp .as we have reached ftp limit..

the password remains the same.

can u guide us how to avoid errors..

I may have left a lot of connections open also while I was testing and debugging the problems.:(

What type of errors are you getting?
What OS is the ftp running on?

we not getting any error as i told u it just hangs in middle .
os used is windows server.