VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "FtpClient"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

Public Server$
Public Port&
Public User$
Public Password$
Public LastError$

Public Transfer As transferType
Public Enum transferType
   transferBinary = 0
   transferAscii = 1
End Enum

Event Closed()

Private WithEvents CtrlSocket As CSocket
Attribute CtrlSocket.VB_VarHelpID = -1
Private WithEvents DataSocket As CSocket
Attribute DataSocket.VB_VarHelpID = -1
Private WithEvents DataSocketServer As CSocket
Attribute DataSocketServer.VB_VarHelpID = -1
Private SaveData$, SaveFile%
Private currentTransfer As transferType
Private answercodes As New Collection
Private answercode_waitfor% 'bei "xxx-*" auf "xxx *" warten
Private datachannelset As Boolean

Private Sub Class_Initialize()
Set CtrlSocket = New CSocket
Set DataSocket = New CSocket
Set DataSocketServer = New CSocket
CtrlSocket.LineSeparator = vbCrLf
Server$ = ""
Port& = 21
User$ = ""
Password$ = ""
Transfer = transferBinary
datachannelset = False
End Sub

Private Sub Class_Terminate()
Set CtrlSocket = Nothing
Set DataSocket = Nothing
Set DataSocketServer = Nothing
Set answercodes = Nothing
End Sub

Public Function Connect() As Boolean

'aufräumen
CtrlSocket.Disconnect
DataSocket.Disconnect
DataSocketServer.Disconnect
answercode_waitfor% = 0
Do While answercodes.Count: answercodes.Remove 1: Loop

'Verbindung herstellen
CtrlSocket.Connect server$, Port&
Do While CtrlSocket.State = sockConnecting: DoEvents: Loop
If CtrlSocket.State <> sockConnected Then Connect = False: Exit Function

'ggf. fehlgeschlagen
If getanswer%() <> 2 Then Connect = False: Exit Function

'Benutzer anmelden
cmd% = ftpcommand%("USER " + User$)
If cmd% = 3 Then
   cmd% = ftpcommand%("PASS " + Password$)
   If cmd% = 4 Then Connect = False: Exit Function
End If

'Verbindung erfolgreich aufgebaut und Benutzer authentifiziert
Connect = True
Transfer = transferAscii
currentTransfer = transferAscii

End Function

Public Sub Disconnect()

ftpcommand "QUIT"
CtrlSocket.Disconnect
DataSocket.Disconnect
DataSocketServer.Disconnect

End Sub

Public Property Get CurDir() As String

cmd% = ftpcommand%("PWD")
If cmd% <> 2 Then CurDir = "": Exit Property
a$ = parse$(Mid$(LastError$, 2), """ "): ersetze a$, """""", """": CurDir = a$
LastError$ = ""

End Property

Public Property Let CurDir(D$)

ftpcommand "CWD " + D$

End Property

Public Function MkDir(D$) As Boolean

MkDir = ftpcommand%("MKD " + D$) < 4

End Function

Public Function RmDir(D$) As Boolean

RmDir = ftpcommand%("RMD " + D$) < 4

End Function

Public Function Rename(f1$, f2$) As Boolean

If ftpcommand%("RNFR " + f1$) > 3 Then Rename = False: Exit Function
If ftpcommand%("RNTO " + f2$) > 3 Then Rename = False: Exit Function
Rename = True

End Function

Public Function Delete(file$) As Boolean

Delete = ftpcommand%("DELE " + file$) < 4

End Function

Public Function ChMod(file$, rights%) As Boolean

ChMod = ftpcommand%("SITE CHMOD " & rights% & " " + file$) < 4

End Function

Public Function Dir() As String

SetTransferType transferAscii

If Not OpenDataChannel() Then Dir = "": Exit Function

SaveData$ = "": SaveFile% = 0
cmd% = ftpcommand%("LIST")
If cmd% <> 1 Then Dir = "": Exit Function

Do While DataSocket.State = sockConnected: DoEvents: Loop
getanswer '226

Dir = SaveData$

End Function

Public Function GetString(file$) As String

If Not OpenDataChannel() Then GetString "": Exit Function

SetTransferType Transfer

SaveData$ = "": SaveFile% = 0
cmd% = ftpcommand%("RETR " + file$)
If cmd% = 1 Then
   Do While DataSocket.State = sockConnected: DoEvents: Loop
   getanswer '226
End If
GetString = SaveData$

End Function

Public Function GetFile(file$, localfile$) As Boolean

SetTransferType Transfer

If Not OpenDataChannel() Then GetFile = False: Exit Function

On Error Resume Next
If Len(localfile$) Then Kill localfile$
On Error GoTo 0

SaveFile% = FreeFile
If Len(localfile$) Then Open localfile$ For Binary As #SaveFile%
cmd% = ftpcommand%("RETR " + file$)
If cmd% = 1 Then
   Do While DataSocket.State = sockConnected: DoEvents: Loop
   GetFile = getanswer%() = 2
Else
   GetFile = False
End If
If Len(localfile$) Then Close #SaveFile%
SaveFile% = 0

End Function

Public Function ReGetFile(file$, localfile$) As Boolean

SetTransferType Transfer

If Not OpenDataChannel() Then ReGetFile = False: Exit Function

SaveFile% = FreeFile
Open localfile$ For Binary As #SaveFile%

If LOF(SaveFile%) > 0 Then
   If ftpcommand%("REST" + Str$(LOF(SaveFile%))) < 5 Then
      Seek #SaveFile%, LOF(SaveFile%) + 1
   Else
      'ReGet nicht möglich!
      Close #SaveFile%
      Kill localfile$
      Open localfile$ For Binary As #SaveFile%
   End If
End If

cmd% = ftpcommand%("RETR " + file$)
If cmd% = 1 Then
   Do While DataSocket.State = sockConnected: DoEvents: Loop
   ReGetFile = getanswer%() = 2
Else
   ReGetFile = False
End If
Close #SaveFile%
SaveFile% = 0

End Function

Public Function PutFile(localfile$, file$) As Boolean

If file$ = "" Then PutFile = getanswer%() = 2: Exit Function

SetTransferType Transfer

If Not OpenDataChannel() Then PutFile = False: Exit Function

cmd% = ftpcommand%("STOR " + file$)
If cmd% = 1 Then
   If Len(localfile$) Then
      SendFile localfile$
      DataSocket.Disconnect
      PutFile = getanswer%() = 2
   Else
      PutFile = True
   End If
Else
   PutFile = False
End If

End Function

Public Property Get DataChannel() As String

cmd% = ftpcommand%("PASV")
If cmd% = 2 Then
   a$ = parse$(LastError$, "(")
   DataChannel = parse$(LastError$, ")")
Else
   DataChannel = ""
End If
datachannelset = True

End Property

Public Property Let DataChannel(D$)

ftpcommand "PORT " & D$
datachannelset = True

End Property

Private Function ftpcommand%(cmd$)

DebugPrint "< " + cmd$
CtrlSocket.SendData cmd$
ftpcommand% = getanswer%()

End Function

Private Function getanswer%()

Do While answercodes.Count = 0: DoEvents: Loop
getanswer% = Int(Val(answercodes(1)) / 100)
answercodes.Remove 1

End Function

Private Function OpenDataChannel() As Boolean

OpenDataChannel = True
If datachannelset Then datachannelset = False: Exit Function
If DataSocket.State = sockConnected Then Exit Function

If OpenDataChannelPassive() Then Exit Function
If OpenDataChannelActive() Then Exit Function
OpenDataChannel = False

End Function

Private Function OpenDataChannelPassive() As Boolean

OpenDataChannelPassive = False
cmd% = ftpcommand%("PASV")
If cmd% = 2 Then
   a$ = parse$(LastError$, "(")
   ip1% = Val(parse$(LastError$, ",")): ip2% = Val(parse$(LastError$, ",")): ip3% = Val(parse$(LastError$, ",")): ip4% = Val(parse$(LastError$, ",")): ip$ = ip1% & "." & ip2% & "." & ip3% & "." & ip4%
   port1% = Val(parse$(LastError$, ",")): port2% = Val(parse$(LastError$, ",")): Prt& = port1% * 256& + port2%
   DataSocket.LocalPort = 20
   DataSocket.Connect ip$, Prt&
   Do While DataSocket.State = sockConnecting: DoEvents: Loop
   If DataSocket.State = sockConnected Then
      DebugPrint "# data socket opened (passiv mode)"
      OpenDataChannelPassive = True
   End If
End If

End Function

Private Function OpenDataChannelActive() As Boolean

OpenDataChannelActive = False
DataSocket.Disconnect
DataSocketServer.Disconnect
DataSocketServer.LocalPort = 0
DataSocketServer.Listen
Prt& = DataSocketServer.LocalPort: If Prt& < 0 Then Prt& = Prt& + 2 ^ 16
ip$ = DataSocketServer.LocalIP: ersetze ip$, ".", ","
cmd% = ftpcommand%("PORT " & ip$ & "," & Int(Prt& / 256) & "," & (Prt& Mod 256))
If cmd% = 2 Then
   DebugPrint "# data socket opened (activ mode)"
   OpenDataChannelActive = True
End If

End Function

Private Sub SendFile(file$)

Const Block = 1000
Dim b() As Byte
fnr% = FreeFile
Open file$ For Binary As #fnr%
l& = LOF(fnr%)
If l& >= Block Then ReDim b(0 To Block - 1)
Do While l& > 0
   If l& < Block Then ReDim b(0 To l& - 1)
   Get #fnr%, , b
   DataSocket.SendData b
   'DebugPrint "send data" + Str$((UBound(b) - LBound(b) + 1))
   l& = l& - Block
Loop
Close #fnr%

End Sub

Private Sub SetTransferType(t As transferType)

If currentTransfer = t Then Exit Sub
currentTransfer = t

If t = transferAscii Then ftpcommand "TYPE A" Else ftpcommand "TYPE I"

End Sub

Private Function parse$(a$, ch$)
ai% = InStr(a$, ch$)
If ai% = 0 Then
  parse$ = a$: a$ = ""
Else
  parse$ = Left$(a$, ai% - 1): a$ = Mid$(a$, ai% + Len(ch$))
End If
End Function

Private Sub ersetze(a$, b$, c$)
If b$ = c$ Then Exit Sub
f% = 1
Do While InStr(f%, a$, b$)
   f% = InStr(f%, a$, b$)
   a$ = Left$(a$, f% - 1) + c$ + Mid$(a$, f% + Len(b$))
   f% = f% + Len(c$)
Loop
End Sub

Private Sub CtrlSocket_Closed()

RaiseEvent Closed
DataSocket.Disconnect
DataSocketServer.Disconnect

End Sub

Private Sub CtrlSocket_Error(Error As Long, Description As String)
   
LastError$ = Description

End Sub

Private Sub CtrlSocket_LineDataArrival(LineData As String, RemoteHostIP As String)

DebugPrint "> " + LineData

If answercode_waitfor% Then
   If Left$(LineData, 4) = answercode_waitfor% & " " And Val(Left$(LineData, 3)) >= 100 Then
      answercode_waitfor% = 0
      answercodes.Add Left$(LineData, 3)
      LastError$ = Mid$(LineData, 5)
   End If
ElseIf Mid$(LineData, 4, 1) = "-" Then
   answercode_waitfor% = Val(Left$(LineData, 3))
ElseIf (Mid$(LineData, 4, 1) = " " Or Len(LineData) = 3) And Val(Left$(LineData, 3)) >= 100 Then
   answercodes.Add Left$(LineData, 3)
   LastError$ = Mid$(LineData, 5)
End If

End Sub

Private Sub DataSocket_Closed()
DebugPrint "# data socket closed"
If DataSocketServer.State = sockListening Then DataSocketServer.Disconnect
End Sub

Private Sub DataSocket_DataArrival(BinData() As Byte, RemoteHostIP As String)
'DebugPrint "# data socket" & (UBound(BinData) - LBound(BinData) + 1) & " Bytes received from " & DataSocket.RemoteHost & ":" & DataSocket.RemotePort
If SaveFile% Then
   Put #SaveFile%, , BinData
Else
   SaveData$ = SaveData$ + StrConv(BinData, vbUnicode)
End If
End Sub

Private Sub DataSocketServer_ConnectionRequest()
'DebugPrint "# data socket accepted"
DataSocket.Accept DataSocketServer
End Sub

Private Sub DebugPrint(a$)
'Debug.Print a$
End Sub