Ftp In Visual Basic 6.0

Option Explicit
Dim CData   As String ' We'll use this to store incoming FTP data
Dim CResp   As String ' We'll use this to store response from FTP server
Dim DataOK  As Boolean ' Is the data sent?
Dim CmdOK   As Boolean ' Is the command sent?
Dim ATS     As Single ' Approximate transfer speed
Dim ATT     As Single ' Approximate transfer time
Dim Data    As String ' We take chunks of data we receive from the server, and merge them in this variable

Dim p_Log   As Boolean ' Should we log FTP activity?

Private Const C_TIMEOUT As Single = 1 ' Default timeout value of 1 second
Dim ConnLog As New Collection

Private Function CSend(ByVal Command As String) As Boolean
If CmdOK Then
  CmdOK = False
  CSend = False
  wskFTPC.SendData Command & vbCrLf
  ConnLog.Add "-> " & Command
  If p_Log Then
    Text1.Text = Text1.Text & ("-> " & Command & vbCrLf)
  End If
  CSend = WaitCOK
End If
End Function

Private Function DSend(ByVal Data As String) As Boolean
If DataOK Then
  DataOK = False
  wskFTPD.SendData Data
  DSend = WaitOK
End If
End Function

Public Sub Wait(ByVal ms As Single)
Dim t1 As Single, t2 As Single
t1 = Timer
While t2 < t1 + ms
  DoEvents
  t2 = Timer
Wend
End Sub

Public Function GetCode(Optional ByVal Timeout As Single = C_TIMEOUT) As String
Dim t1 As Single, t2 As Single

CResp = ""
GetCode = ""
t1 = Timer
While CResp = ""
  t2 = Timer
  If t2 > t1 + Timeout Then Exit Function
  DoEvents
Wend
GetCode = CResp
End Function

Public Function WaitCode(ByVal Code As String, Optional ByVal Timeout As Single = C_TIMEOUT) As Boolean
Dim t1 As Single, t2 As Single
t1 = Timer
WaitCode = False
While CResp <> Code
  t2 = Timer
  If t2 > t1 + Timeout Then Exit Function
  DoEvents
Wend
WaitCode = True
End Function

Public Function WaitOK(Optional ByVal Timeout As Single = C_TIMEOUT) As Boolean
Dim t1 As Single, t2 As Single
t1 = Timer
WaitOK = False
While DataOK = False
  t2 = Timer
  If t2 > t1 + Timeout Then Exit Function
  DoEvents
Wend
WaitOK = True
End Function

Public Function WaitCOK(Optional ByVal Timeout As Single = C_TIMEOUT) As Boolean
Dim t1 As Single, t2 As Single
t1 = Timer
WaitCOK = False
While CmdOK = False
  t2 = Timer
  If t2 > t1 + Timeout Then Exit Function
  DoEvents
Wend
WaitCOK = True
End Function

Public Function WaitConn(Optional ByVal Timeout As Single = C_TIMEOUT) As Boolean
Dim t1 As Single, t2 As Single
t1 = Timer
WaitConn = False
While wskFTPD.State <> sckConnected
  t2 = Timer
  If t2 > t1 + Timeout Then Exit Function
  If wskFTPD.State = sckConnecting Then t1 = Timer
  DoEvents
Wend
WaitConn = True
End Function

Private Function SendPORT() As Boolean
Dim pIP   As String
Dim pPort As String
Dim pH    As Long
Dim pL    As Long
Dim lPort As Long


Randomize Timer
lPort = Int(12000 * Rnd + 6000)

SendPORT = False

pH = lPort \ 256
pL = lPort - (pH * 256)
pPort = Trim(CStr(pH)) & "," & Trim(CStr(pL))

With wskFTPD
  .LocalPort = pH * 256 + pL
  pIP = .LocalIP
  .Listen
End With

pIP = Replace(pIP, ".", ",")
CSend ("PORT " & pIP & "," & pPort)

If Not WaitCode("200") Then Exit Function
SendPORT = True
End Function

Private Function SendLIST(Optional ByVal FilePath As String = "") As Boolean
Data = ""
CSend ("LIST" & IIf((FilePath = ""), "", " " & FilePath))
If Not WaitCode("150") Then Exit Function

While wskFTPD.State = sckConnected
  DoEvents
  Label3.Caption = CResp
Wend

Open "c:\incoming" For Binary As #120
Put #120, 1, Data
Close #120
Data = ""

SendLIST = True
End Function

Private Function SendFile(ByVal FileName As String, Optional ByVal BuffSize As Long = 2048) As Boolean
Dim hFile As Integer
Dim fBuff As String
Dim lBuff As Long
Dim t1    As Single
Dim t2    As Single

Dim s As Long, i As Long, r As Long

hFile = FreeFile
lBuff = BuffSize

t1 = Timer
Open FileName For Binary As #hFile
  If LOF(hFile) >= lBuff Then
    s = LOF(hFile) \ lBuff
    Picture1.ScaleWidth = s
    Label1.Width = 0
    fBuff = Space(lBuff)
    For i = 1 To s
      Get #hFile, , fBuff
      DSend fBuff
      Label1.Width = i
      DoEvents
    Next i
    r = LOF(hFile)
    r = r - (lBuff * s)
    If r > 0 Then
      fBuff = Space(r)
      Get #hFile, , fBuff
      DSend fBuff
    End If
    Label1.Width = LOF(hFile)
  Else
    Picture1.ScaleWidth = LOF(hFile)
    fBuff = Space(LOF(hFile))
    Get #hFile, , fBuff
    DSend fBuff
    Label1.Width = LOF(hFile)
  End If
  DoEvents
  t2 = Timer
  ATS = LOF(hFile) / ((t2 - t1) + 1)
  ATT = t2 - t1
Close #hFile
wskFTPD.Close
SendFile = True
End Function

Private Sub Timer1_Timer()
Label2.Caption = wskFTPD.State
If wskFTPD.State = sckClosing Then wskFTPD.Close
End Sub

Private Sub wskFTPC_SendComplete()
CmdOK = True
DoEvents
End Sub

Private Sub Form_Unload(Cancel As Integer)
If wskFTPC.State = 7 Then
  Text1.Text = Text1.Text & CSend("QUIT")
  wskFTPC.Close
Else
  wskFTPC.Close
End If
End Sub

Private Sub wskFTPD_ConnectionRequest(ByVal requestID As Long)
wskFTPD.Close
wskFTPD.Accept requestID
Text1.Text = Text1.Text & "*** Data connection established" & vbCrLf
End Sub

Private Sub wskFTPD_DataArrival(ByVal bytesTotal As Long)
Dim s As String
wskFTPD.GetData s
Data = Data & s
End Sub

Private Sub wskFTPD_SendComplete()
DataOK = True
DoEvents
End Sub

Private Sub Command1_Click()
CmdOK = True
DataOK = True

p_Log = True


wskFTPC.RemoteHost = "ftphost.com"
wskFTPC.RemotePort = 21
wskFTPC.Connect

If Not WaitCode("220") Then Exit Sub

CSend ("USER username")
If Not WaitCode("331") Then Exit Sub

CSend ("PASS password")
If Not WaitCode("230") Then Exit Sub

CSend ("TYPE I")
If Not WaitCode("200") Then Exit Sub

CSend ("CWD sautpro.com/proba")
If Not WaitCode("250") Then Exit Sub

If Not SendPORT Then Exit Sub
CSend ("STOR somefile")
If Not WaitCode("200") Then Exit Sub
If Not WaitConn Then Exit Sub
If Not SendFile("c:\.somefile") Then Exit Sub
If Not WaitCode("226", 10) Then
  CSend "NOOP"
  If Not WaitCode("226", 20) Then Exit Sub
End If

Text1.Text = Text1.Text & "*** File transfer complete. (Approx. upload speed " & Format(ATS / 1024, "###,##0.00") & "kb/s, Approx. upload time " & Format(ATT, "#,##0.00") & " seconds)" & vbCrLf
Text1.Text = Text1.Text & "*** Closing data connection." & vbCrLf

CSend ("TYPE A")
If Not WaitCode("200") Then Exit Sub
If Not SendPORT Then Exit Sub
SendLIST
If Not WaitCode("226", 5) Then
  CSend "NOOP"
  If Not WaitCode("226", 10) Then Exit Sub
End If

Text1.Text = Text1.Text & "*** Directory LISTing received." & vbCrLf
End Sub