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

Private Typ%  '0=Ascii 1=Binary
Private FServer As FtpServer
Attribute FServer.VB_VarHelpID = -1
Private WithEvents CtrlSocket As CSocket
Attribute CtrlSocket.VB_VarHelpID = -1

'Datenkanal
Private WithEvents DataSocketServer As CSocket
Attribute DataSocketServer.VB_VarHelpID = -1
Private WithEvents DataSocket As CSocket
Attribute DataSocket.VB_VarHelpID = -1
Private FileNumber%, FileName$
Private ActivePORT As String

'Zustand des Benutzers
Private Authentified%, User$, Password$
Private RootDirectory$    'c:\, c:\daten\
Private CurrentDirectory$ '/, /projekt/

Private Sub Class_Initialize()
Set CtrlSocket = New CSocket
Set DataSocket = New CSocket
Set DataSocketServer = New CSocket
CtrlSocket.LineSeparator = vbCrLf
Typ% = 0: Authentified% = False
User$ = "": Password$ = "": RootDirectory$ = "": CurrentDirectory$ = ""
FileNumber% = 0
ActivePORT = ""
End Sub

Public Sub Accept(Ftp As FtpServer, Server As CSocket)
CtrlSocket.Accept Server
Set FServer = Ftp
SendReturnCode 220, "BasicPro Demo FTP-Server"
End Sub

Private Sub Class_Terminate()
If Authentified% Then FServer.Log User$ + "> logged out"
Set DataSocket = Nothing
Set DataSocketServer = Nothing
End Sub

Private Sub DataSocket_Closed()
If FileNumber% Then
   Close #FileNumber%
   FileNumber% = 0
   SendReturnCode 226
   FServer.Log User$ + "> upload " + FileName$
End If
End Sub

Private Sub DataSocket_DataArrival(BinData() As Byte, RemoteHostIP As String)
If FileNumber% Then
   Put #FileNumber%, , BinData
End If
End Sub

Private Sub DataSocketServer_ConnectionRequest()
DataSocket.Accept DataSocketServer
End Sub

Private Sub CtrlSocket_Closed()
Set CtrlSocket = Nothing
If Not (DataSocketServer Is Nothing) Then DataSocketServer.Disconnect: Set DataSocketServer = Nothing
If Not (DataSocket Is Nothing) Then DataSocket.Disconnect: Set DataSocket = Nothing
For n% = 1 To FServer.Clients.Count
   If FServer.Clients(n%) Is Me Then FServer.Clients.Remove n%: Exit For
Next
End Sub

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

'Telnet-Protokoll-Steuercodes (IAC...) entfernen
Do While Asc(Left$(LineData + Chr$(0), 1)) >= 128: LineData = Mid$(LineData, 2): Loop

Debug.Print "< "; LineData

cmd$ = UCase$(parse$(LineData, " ")): LineData = Trim$(LineData)
If cmd$ = "USER" Then
   CheckUser LineData
   If Authentified% Then FServer.Log User$ + "> logged in"
   SendReturnCode IIf(Authentified%, 230, 331)
ElseIf cmd$ = "PASS" Then
   If User$ = "" Then
      SendReturnCode 503
   Else
      If Authentified% = False Then
         Authentified% = Password$ <> "" And (LineData = Password$ Or Password$ = "*")
         If Authentified% Then FServer.Log User$ + "> logged in"
      End If
      SendReturnCode IIf(Authentified%, 230, 421)
   End If
ElseIf cmd$ = "QUIT" Then
   SendReturnCode 221
ElseIf Not Authentified% Then
   SendReturnCode 530

'ab hier ist der Benutzer authentifiziert
ElseIf cmd$ = "SYST" Then
   SendReturnCode 215, "Windows_NT"
ElseIf cmd$ = "PWD" Then
   SendReturnCode 257, CurrentDirectory$
ElseIf cmd$ = "CWD" Or cmd$ = "CDUP" Then
   If cmd$ = "CDUP" Then LineData = ".."
   If exist_path%(GetPath(LineData)) <> 0 And InStr(GetCurDir(LineData + "/"), "..") = 0 Then
      CurrentDirectory$ = GetCurDir(LineData + "/")
      SendReturnCode 250
   Else
      SendReturnCode 550, LineData
   End If
ElseIf cmd$ = "PASV" Then
   SendReturnCode 227, OpenDataChannelPassive$()
ElseIf cmd$ = "PORT" Then
   SendReturnCode IIf(OpenDataChannelActive(LineData), 200, 421)
ElseIf cmd$ = "TYPE" Then
   If Left$(LineData, 1) = "I" Then Typ% = 1 Else Typ% = 0
   SendReturnCode 200
ElseIf cmd$ = "RETR" Then
   file$ = GetPath(LineData)
   If exist%(file$) Then
      SendReturnCode 150
      ok% = SendFile(file$)
      SendReturnCode IIf(ok%, 226, 426)
      If ok% Then FServer.Log User$ + "> download " + file$
   Else
      SendReturnCode 450
   End If
ElseIf cmd$ = "STOR" Then
   ReceiveFile GetPath(LineData)
   SendReturnCode 150
   'SendReturnCode 226 in DataSocket_Closed
ElseIf cmd$ = "LIST" Or cmd$ = "NLST" Then
   pfd$ = GetPath(IIf(LineData = "", "", LineData + "/"))
   If exist_path%(pfd$ + ".") Then
      SendReturnCode 150
      ok% = BrowseDirectory(pfd$, cmd$ = "LIST")
      SendReturnCode IIf(ok%, 226, 426)
   Else
      SendReturnCode 450
   End If
ElseIf cmd$ = "ABOR" Then
   SendReturnCode 225
   DataSocket.Disconnect
ElseIf cmd$ = "NOOP" Then
   SendReturnCode 200
Else
   SendReturnCode 502
End If

End Sub

Private Function OpenDataChannelActive(ipport$) As Boolean

ActivePORT = ipport$
OpenDataChannelActive = True

End Function

Private Function OpenDataChannelPassive$()

DataSocketServer.Disconnect
DataSocketServer.LocalPort = 0
DataSocketServer.Listen

Port& = DataSocketServer.LocalPort: If Port& < 0 Then Port& = Port& + 2 ^ 16
ip$ = DataSocketServer.LocalIP: ersetze ip$, ".", ","

OpenDataChannelPassive$ = ip$ + "," & Int(Port& / 256) & "," & (Port& Mod 256)

End Function

Private Sub SendReturnCode(retcode%, Optional retpar$ = "")

Debug.Print "> " & retcode% & " " & ReturnCodeDescription(retcode%, retpar$)
CtrlSocket.SendData retcode% & " " & ReturnCodeDescription(retcode%, retpar$)

If (retcode% Mod 100) = 21 Then CtrlSocket.Disconnect: CtrlSocket_Closed

If retcode% = 150 And Len(ActivePORT) > 0 Then
   ip1% = Val(parse$(ActivePORT, ",")): ip2% = Val(parse$(ActivePORT, ",")): ip3% = Val(parse$(ActivePORT, ",")): ip4% = Val(parse$(ActivePORT, ",")): ip$ = ip1% & "." & ip2% & "." & ip3% & "." & ip4%
   port1% = Val(parse$(ActivePORT, ",")): port2% = Val(parse$(ActivePORT, ",")): Port& = port1% * 256& + port2%
   DataSocket.LocalPort = 20
   DataSocket.Connect ip$, Port&
   Do While DataSocket.State = sockConnecting: DoEvents: Loop
   If DataSocket.State <> sockConnected Then Debug.Print "...error..."
   ActivePORT = ""
End If

End Sub

Private Function GetPath(file$) As String
pfd$ = RootDirectory$ + GetCurDir(file$)
ersetze pfd$, "/", "\"
Do While InStr(pfd$, "\\"): pfd$ = Left$(pfd$, InStr(pfd$, "\\")) + Mid$(pfd$, InStr(pfd$, "\\") + 2): Loop
GetPath = pfd$
End Function

Private Function GetCurDir(ByVal file$) As String
ersetze file$, "\", "/"
If Left$(file$, 1) <> "/" Then pfd$ = CurrentDirectory$ Else pfd$ = ""
Do While (file$ = ".." Or Left$(file$, 3) = "../") And pfd$ <> "/"
   a1% = 1: Do: a2% = InStr(a1% + 1, pfd$, "/"): a0% = a1%: a1% = a2%: Loop Until a2% = 0 Or a2% = Len(pfd$)
   pfd$ = Left$(pfd$, a0%): file$ = Mid$(file$, 4)
Loop
pfd$ = pfd$ + file$
Do While InStr(pfd$, "//"): pfd$ = Left$(pfd$, InStr(pfd$, "//")) + Mid$(pfd$, InStr(pfd$, "//") + 2): Loop
GetCurDir = pfd$
End Function

Private Function SendFile(file$) As Boolean
SendFile = True
Const Block = 5000
Open file$ For Binary As #1
l& = LOF(1)
If l& >= Block Then ReDim b(0 To Block - 1) As Byte
Do While l& > 0
   If l& < Block Then ReDim b(0 To l& - 1) As Byte
   Get #1, , b
   If DataSocket.State <> sockConnected Then SendFile = False: Exit Do
   DataSocket.SendData b
   l& = l& - Block
   DoEvents
Loop
Close #1
DataSocket.Disconnect
End Function

Private Function BrowseDirectory(file$, details%) As Boolean
BrowseDirectory = True

'Unterverzeichnisse
a$ = Dir$(file$ + "*.*", 16)
Do While Len(a$)
   If a$ <> "." And a$ <> ".." And (GetAttr(file$ + a$) And 16) > 0 Then
      If details% Then ext$ = "drwxrwxrwx   1 owner    group               0 " + FileDate$(file$ + a$) + " " Else ext$ = ""
      If DataSocket.State <> sockConnected Then BrowseDirectory = False: Exit Function
      DataSocket.SendData ext$ + a$ + vbCrLf
   End If
   a$ = Dir$
Loop

'Dateien
a$ = Dir$(file$ + "*.*")
Do While Len(a$)
   If details% Then ext$ = "-rw-rw-rw-   1 owner    group    " + Format$(FileLen(file$ + a$), "@@@@@@@@@@@@") + " " + FileDate$(file$ + a$) + " " Else ext$ = ""
   If DataSocket.State <> sockConnected Then BrowseDirectory = False: Exit Function
   DataSocket.SendData ext$ + a$ + vbCrLf
   a$ = Dir$
Loop

DataSocket.Disconnect

End Function

Private Sub ReceiveFile(file$)
FileNumber% = FreeFile
FileName$ = file$
On Error Resume Next: Kill FileName$: On Error GoTo 0
Open FileName$ For Binary As #FileNumber%
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 Function exist%(ByVal a$)
On Error Resume Next
tmp% = Len(Dir$(a$, 6))
If Err Or tmp% = 0 Then
   exist% = 0
ElseIf GetAttr(a$) And 16 Then
   exist% = 0
Else
   exist% = 1
End If
End Function

Private Function exist_path%(a$)
On Error Resume Next
tmp% = Len(Dir$(a$, 16))
If Err Or tmp% = 0 Then
   exist_path% = 0
ElseIf GetAttr(a$) And 16 Then
   exist_path% = 1
Else
   exist_path% = 0
End If
End Function

Private Function ReturnCodeDescription(retcode%, retpar$) As String

Select Case retcode%
Case 110: ReturnCodeDescription = "Restart marker reply."     'In this case, the text is exact and not left to the particular implementation; it must read: MARK yyyy = mmmm  Where yyyy is User-process data stream marker, and mmmm Server 's equivalent marker (note the spaces between markers and "=").
Case 120: ReturnCodeDescription = "Service ready in " + retpar$ + " minutes."
Case 125: ReturnCodeDescription = "Data connection already open; transfer starting."
Case 150: ReturnCodeDescription = "File status okay; about to open data connection."
Case 200: ReturnCodeDescription = "Command okay."
Case 202: ReturnCodeDescription = "Command not implemented, superfluous at this site."
Case 211: ReturnCodeDescription = "System status, or system help reply."
Case 212: ReturnCodeDescription = "Directory status."
Case 213: ReturnCodeDescription = "File status."
Case 214: ReturnCodeDescription = "Help message."  'On how to use the server or the meaning of a particular non-standard command.  This reply is useful only to the human user.
Case 215: ReturnCodeDescription = retpar$ + " system type."
Case 220: ReturnCodeDescription = retpar$
Case 221: ReturnCodeDescription = "Service closing control connection."
Case 225: ReturnCodeDescription = "Data connection open; no transfer in progress."
Case 226: ReturnCodeDescription = "Closing data connection."
Case 227: ReturnCodeDescription = "Entering Passive Mode (" + retpar$ + ")."
Case 230: ReturnCodeDescription = "User logged in, proceed."
Case 250: ReturnCodeDescription = "Requested file action okay, completed."
Case 257: ReturnCodeDescription = """" + retpar$ + """ is current directory."
Case 331: ReturnCodeDescription = "User name okay, need password."
Case 332: ReturnCodeDescription = "Need account for login."
Case 350: ReturnCodeDescription = "Requested file action pending further information."
Case 421: ReturnCodeDescription = "Service not available, closing control connection."
Case 425: ReturnCodeDescription = "Can 't open data connection."
Case 426: ReturnCodeDescription = "Connection closed; transfer aborted."
Case 450: ReturnCodeDescription = "Requested file action not taken."     'File unavailable (e.g., file busy).
Case 451: ReturnCodeDescription = "Requested action aborted: local error in processing."
Case 452: ReturnCodeDescription = "Requested action not taken."    'Insufficient storage space in system.
Case 500: ReturnCodeDescription = "Syntax error, command unrecognized."     'This may include errors such as command line too long.
Case 501: ReturnCodeDescription = "Syntax error in parameters or arguments."
Case 502: ReturnCodeDescription = "Command not implemented."
Case 503: ReturnCodeDescription = "Bad sequence of commands."
Case 504: ReturnCodeDescription = "Command not implemented for that parameter."
Case 530: ReturnCodeDescription = "Not logged in."
Case 532: ReturnCodeDescription = "Need account for storing files."
Case 550: ReturnCodeDescription = retpar$ + ": No such file or directory"
Case 551: ReturnCodeDescription = "Requested action aborted: page type unknown."
Case 552: ReturnCodeDescription = "Requested file action aborted."     'Exceeded storage allocation (for current directory or dataset).
Case 553: ReturnCodeDescription = "Requested action not taken."     'File name not allowed.
Case Else: ReturnCodeDescription = "???"
End Select

End Function

Private Function FileDate$(f$)
'"Feb  1  1999"

a$ = FileDateTime(f$)
t% = Val(Left$(a$, 2))
m% = Val(Mid$(a$, 4, 2))
j% = Val(Mid$(a$, 7, 2)): If j% < 70 Then j% = j% + 2000 Else j% = j% + 1900
FileDate$ = Mid$("JanFebMarAprMayJunJulAugSepOctNovDec", m% * 3 - 2, 3) + " " + Format$(t%, "@@") + "  " + Format$(j%, "@@@@")

End Function

Private Sub CheckUser(usr$)

User$ = "": Password$ = "": RootDirectory$ = "": CurrentDirectory$ = ""
If FServer.Authentication.Count = 0 Then
   Authentified% = True
   RootDirectory$ = "c:\": CurrentDirectory$ = "/"
Else
   For u% = 1 To FServer.Authentication.Count
      a$ = FServer.Authentication(u%)
      If parse$(a$, ",") = usr$ Then
         User$ = usr$: Password$ = parse$(a$, ","): RootDirectory$ = parse$(a$, ","): CurrentDirectory$ = a$
         ersetze CurrentDirectory$, "\", "/"
         ersetze RootDirectory$, "/", "\"
         If Right$(CurrentDirectory$, 1) <> "/" Then CurrentDirectory$ = CurrentDirectory$ + "/"
         If Right$(RootDirectory$, 1) <> "\" Then RootDirectory$ = RootDirectory$ + "\"
         Exit For
      End If
   Next
   Authentified% = User$ <> "" And Password$ = ""
End If

End Sub