-
Hey Sham, 
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]
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules