Code:Public sub GetFTP() On Error GoTo ImportErr Dim host_name As String Dim fso As New FileSystemObject iTotal = 0 iSent = 0 grdFiles.RemoveAll Screen.ActiveForm.Enabled = False Screen.MousePointer = vbHourglass txtResults.Text = "" host_name = gstIP If LCase$(Left$(host_name, 6)) <> "ftp://" Then host_name = "ftp://" & host_name inetFTP.URL = host_name With inetFTP .Execute , "CD " & sFTPFolder & "/Export" Call pWaitForResponse .Execute , "Dir" Call pWaitForResponse vChunk = .GetChunk(1024, icString) Call pWaitForResponse Do Until bDone sDirectory = sDirectory & vChunk vChunk = .GetChunk(1024) If Len(vChunk) = 0 Then bDone = True Loop End With Dim i As Integer Dim sFTPFile As String Dim sMatchStr As String sMatchStr = UCase$(".exp") Do Until Len(sDirectory) = 0 i = InStr(1, sDirectory, Chr$(13)) If i > 0 Then If Len(sDirectory) <= 2 Then sDirectory = "" Exit Do End If sFTPFile = UCase$(Left$(sDirectory, i - 1)) If InStr(1, sFTPFile, sMatchStr) > 0 Then grdFiles.AddItem "0" & vbTab & sFTPFile End If sDirectory = Mid$(sDirectory, i + 2) End If Loop iSent = 1 iTotal = grdFiles.Rows If grdFiles.Rows > 0 Then prgStatus.Visible = True prgStatus.Value = iSent prgStatus.Max = iTotal lblStatus.Caption = "Still Executing, Please wait!.. Recieving " & iSent & " of " & iTotal & " files.." DoEvents Do Until iSent - 1 > iTotal stFile = grdFiles.Columns("filename").Value If Not CBool(grdFiles.Columns("check").Value) Then If inetFTP.StillExecuting Then inetFTP.Cancel pWaitForResponse End If If fso.FileExists(gstImport & "\" & stFile) Then Call fso.DeleteFile(gstImport & "\" & stFile, True) AddMessage "Importing " & stFile inetFTP.Execute , "Get " & _ "/Export/" & stFile & " " & gstImport & "\" & stFile pWaitForResponse End If If boSent Then 'Return true if Succesufully Sent Dim lFile As String Dim rFile As String lFile = GetFTPFileSize("/Export/" & stFile) rFile = FileLen(gstImport & "\" & stFile) If lFile = rFile Then AddMessage "Deleting " & stftpfile inetFTP.Execute , "Delete " & "/Export/" & stFile Call pWaitForResponse DoEvents iSent = iSent + 1 grdFiles.Columns("check").Value = True grdFiles.MoveNext prgStatus.Value = iSent lblStatus.Caption = "Still Executing, Please wait!.. Recieving " & iSent & " of " & iTotal & " files.." End If End If Loop End If If iSent = iTotal Then lblStatus.Caption = "Transfer successfully done.." prgStatus.Value = 0 MsgBox iSent & " out of " & iTotal & " succesfully received!...", vbInformation Else lblStatus.Caption = "Transfer partially done.. Please try again.." prgStatus.Value = 0 MsgBox iSent & " out of " & iTotal & " succesfully received!.. Please try again..", vbInformation End If Screen.ActiveForm.Enabled = True Screen.MousePointer = vbDefault Exit Sub ImportErr: MsgBox Err.Description & vbCrLf & "Please try again..", vbCritical inetFTP.Cancel Screen.ActiveForm.Enabled = True Screen.MousePointer = vbDefault End Sub Private Sub pWaitForResponse() Dim i As Integer ' ' This loop waits until an FTP action completes. ' Do Until Not inetFTP.StillExecuting DoEvents Sleep (100) If inetFTP.ResponseInfo = "Timeout" Then AddMessage inetFTP.ResponseInfo boSent = False Exit Do End If Loop




Reply With Quote