VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form FTP 
   Caption         =   "WINSOCK-FTP-DEMO"
   ClientHeight    =   8412
   ClientLeft      =   3912
   ClientTop       =   1704
   ClientWidth     =   13716
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form2"
   ScaleHeight     =   701
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   1143
   Begin MSComctlLib.ProgressBar ProgressBar2 
      Height          =   132
      Left            =   2520
      TabIndex        =   31
      Top             =   5040
      Width           =   2412
      _ExtentX        =   4255
      _ExtentY        =   233
      _Version        =   393216
      Appearance      =   1
   End
   Begin MSComctlLib.ProgressBar ProgressBar1 
      Height          =   132
      Left            =   120
      TabIndex        =   30
      Top             =   5040
      Width           =   2292
      _ExtentX        =   4043
      _ExtentY        =   233
      _Version        =   393216
      Appearance      =   1
   End
   Begin VB.CommandButton Command3 
      Caption         =   "ò"
      BeginProperty Font 
         Name            =   "Wingdings"
         Size            =   12.6
         Charset         =   2
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   285
      Left            =   135
      TabIndex        =   25
      Top             =   4710
      Width           =   375
   End
   Begin VB.CommandButton Command4 
      Caption         =   "ñ"
      BeginProperty Font 
         Name            =   "Wingdings"
         Size            =   12.6
         Charset         =   2
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   285
      Left            =   4500
      TabIndex        =   21
      Top             =   4710
      Width           =   405
   End
   Begin VB.Frame Frame4 
      Caption         =   "Server"
      Height          =   2925
      Left            =   60
      TabIndex        =   20
      Top             =   1770
      Width           =   4935
      Begin MSComctlLib.TreeView TreeView1 
         Height          =   2532
         Left            =   2400
         TabIndex        =   29
         Top             =   240
         Width           =   2412
         _ExtentX        =   4255
         _ExtentY        =   4466
         _Version        =   393217
         Style           =   7
         Appearance      =   1
      End
      Begin VB.ListBox List1 
         Height          =   2544
         Left            =   90
         TabIndex        =   24
         Top             =   210
         Width           =   2265
      End
   End
   Begin VB.Frame Frame3 
      Caption         =   "Local"
      Height          =   3165
      Left            =   60
      TabIndex        =   16
      Top             =   5160
      Width           =   4935
      Begin VB.TextBox Text8 
         Height          =   315
         Left            =   90
         TabIndex        =   27
         Top             =   255
         Visible         =   0   'False
         Width           =   1880
      End
      Begin VB.CheckBox Check4 
         Caption         =   "Net"
         Height          =   315
         Left            =   1970
         Style           =   1  'Graphical
         TabIndex        =   26
         Top             =   255
         Width           =   400
      End
      Begin VB.DriveListBox Drive1 
         Height          =   315
         Left            =   90
         TabIndex        =   19
         Top             =   260
         Width           =   1880
      End
      Begin VB.FileListBox File1 
         Height          =   2760
         Left            =   2400
         TabIndex        =   18
         Top             =   240
         Width           =   2475
      End
      Begin VB.DirListBox Dir1 
         Height          =   2340
         Left            =   90
         TabIndex        =   17
         Top             =   660
         Width           =   2265
      End
   End
   Begin VB.Frame Frame2 
      Caption         =   "Login"
      Height          =   1635
      Left            =   60
      TabIndex        =   11
      Top             =   60
      Width           =   4935
      Begin VB.CommandButton Command1 
         Caption         =   "Connect to:"
         Height          =   330
         Left            =   90
         TabIndex        =   15
         Top             =   240
         Width           =   990
      End
      Begin VB.TextBox Text4 
         Height          =   330
         Left            =   1110
         TabIndex        =   1
         Text            =   "ftp.cuzze.net"
         Top             =   240
         Width           =   3750
      End
      Begin VB.TextBox Text5 
         Height          =   285
         Left            =   1140
         TabIndex        =   2
         Text            =   "Lens@cuzze.net"
         Top             =   600
         Width           =   3750
      End
      Begin VB.TextBox Text6 
         Height          =   285
         IMEMode         =   3  'DISABLE
         Left            =   1110
         PasswordChar    =   "*"
         TabIndex        =   3
         Text            =   "Lens99!!"
         Top             =   915
         Width           =   3750
      End
      Begin VB.CheckBox Check1 
         Caption         =   "User"
         Height          =   240
         Left            =   300
         TabIndex        =   14
         Top             =   645
         Value           =   1  'Checked
         Width           =   645
      End
      Begin VB.CheckBox Check2 
         Caption         =   "Pass"
         Height          =   240
         Left            =   300
         TabIndex        =   13
         Top             =   960
         Value           =   1  'Checked
         Width           =   735
      End
      Begin VB.CheckBox Check3 
         Caption         =   "Acct"
         Height          =   240
         Left            =   300
         TabIndex        =   12
         Top             =   1275
         Width           =   690
      End
      Begin VB.TextBox Text7 
         Height          =   285
         Left            =   1110
         TabIndex        =   4
         Top             =   1230
         Width           =   3750
      End
   End
   Begin VB.Frame Frame1 
      Caption         =   "Commands"
      Height          =   8265
      Left            =   5160
      TabIndex        =   0
      Top             =   60
      Width           =   8475
      Begin VB.TextBox Text1 
         BackColor       =   &H00000000&
         ForeColor       =   &H00FFFFFF&
         Height          =   3645
         Left            =   90
         MultiLine       =   -1  'True
         ScrollBars      =   2  'Vertical
         TabIndex        =   8
         Top             =   900
         Width           =   8280
      End
      Begin VB.CommandButton Command2 
         Caption         =   "FTP-Command"
         Default         =   -1  'True
         Height          =   330
         Left            =   90
         TabIndex        =   7
         Top             =   240
         Width           =   1275
      End
      Begin VB.TextBox Text2 
         BackColor       =   &H00000000&
         ForeColor       =   &H00FFFFFF&
         Height          =   330
         Left            =   1380
         TabIndex        =   5
         Text            =   "HELP"
         Top             =   240
         Width           =   7005
      End
      Begin VB.TextBox Text3 
         BackColor       =   &H00000000&
         ForeColor       =   &H00FFFFFF&
         Height          =   3255
         Left            =   90
         MultiLine       =   -1  'True
         ScrollBars      =   2  'Vertical
         TabIndex        =   6
         Top             =   4905
         Width           =   8280
      End
      Begin VB.Label Label1 
         Caption         =   "Command-Connection"
         Height          =   195
         Left            =   90
         TabIndex        =   10
         Top             =   690
         Width           =   2130
      End
      Begin VB.Label Label2 
         Caption         =   "Data-Connection"
         Height          =   195
         Left            =   90
         TabIndex        =   9
         Top             =   4680
         Width           =   2130
      End
   End
   Begin MSWinsockLib.Winsock Winsock1 
      Left            =   7560
      Top             =   -60
      _ExtentX        =   593
      _ExtentY        =   593
      _Version        =   393216
      RemotePort      =   21
   End
   Begin MSWinsockLib.Winsock Winsock3 
      Left            =   8400
      Top             =   -60
      _ExtentX        =   593
      _ExtentY        =   593
      _Version        =   393216
      RemotePort      =   21
   End
   Begin MSWinsockLib.Winsock Winsock2 
      Left            =   7980
      Top             =   -60
      _ExtentX        =   593
      _ExtentY        =   593
      _Version        =   393216
      RemotePort      =   21
   End
   Begin VB.PictureBox Icons 
      BackColor       =   &H80000005&
      Height          =   384
      Left            =   0
      ScaleHeight     =   336
      ScaleWidth      =   912
      TabIndex        =   28
      Top             =   0
      Width           =   960
   End
   Begin VB.Label Label5 
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      Caption         =   "Upload"
      Height          =   195
      Left            =   3900
      TabIndex        =   23
      Top             =   4740
      Width           =   510
   End
   Begin VB.Label Label4 
      AutoSize        =   -1  'True
      Caption         =   "Download"
      Height          =   195
      Left            =   540
      TabIndex        =   22
      Top             =   4740
      Width           =   720
   End
End
Attribute VB_Name = "FTP"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'This simple Example has all you need, to communicate with FTP-Servers
'in Passive-Mode (which is the more Firewall-friendly one)...
'
'This is a (slightly) revised version of the original one from Aug. 2000...
'(changes include an adaption to the full "current User-Directory",
' retrieved per PWD directly after Login - a little less stressing usage
' of the DoEvents-looping - and better <DIR> detection for IIS-driven FTP-Servers)
'
'Have fun!
'Olaf Schmidt (Dec. 2015)

Private Declare Sub RtlMoveMemory Lib "kernel32" (Dst As Any, Src As Any, ByVal Bytes&)
Private Declare Sub Sleep Lib "kernel32" (ByVal msec&)
Private Declare Function timeBeginPeriod& Lib "winmm" (ByVal uPeriod&)
Private Declare Function timeEndPeriod& Lib "winmm" (ByVal uPeriod&)

Private Declare Function SendMessageA& Lib "user32" (ByVal hwnd&, ByVal wMsg&, ByVal wParam&, ByVal lParam&)
Private Declare Function ShellExecuteA& Lib "shell32" (ByVal hwnd&, ByVal lpOp$, ByVal lpFile$, ByVal lpPar$, ByVal lpDir$, ByVal nCmd&)

Dim RetrBytes&, RetrFName$, SendBytes&, SendFName$, UserRootDirectory$
Dim LastFileCommand$, RetrBuf() As Byte, SendBuf() As Byte

Private Sub Check4_Click()
  Text8.Visible = Check4
  If Check4 Then Text8.SetFocus: Text8_Change Else Dir1.Visible = True: Dir1.Path = Drive1.Drive
End Sub

Private Sub Command1_Click()
  On Error Resume Next
  TreeView1.Nodes.Clear
  UserRootDirectory = ""
  Winsock1.Close: Winsock1.LocalPort = 0
  Winsock1.Connect Text4: DoEvents
End Sub

Private Sub Command2_Click()
  On Error Resume Next
  LastFileCommand = ""
  Select Case Left(UCase(Text2), 4)
    Case "STOR", "RETR", "LIST", "NLST": Winsock1.SendData "PASV" & vbCrLf: DoEvents
  End Select
  Winsock1.SendData Text2 & vbCrLf: DoEvents
End Sub

Private Sub Command3_Click()
  Frame3.Enabled = False: Frame4.Enabled = False: Screen.MousePointer = 11
  RetrFName = List1.Text: RetrFileData RetrFName
End Sub

Private Sub Command4_Click()
Dim FPath$
  Frame3.Enabled = False: Frame4.Enabled = False: Screen.MousePointer = 11
  FPath = File1.Path: If Right$(FPath, 1) <> "\" Then FPath = FPath & "\"
  LoadSendBuf FPath & SendFName
  SendFileData SendFName
End Sub

Private Sub Dir1_Change()
  File1.Path = Dir1.Path
End Sub

Private Sub Dir1_Click()
  SendMessageA Dir1.hwnd, &H203, 1, 0
End Sub

Private Sub Drive1_Change()
On Error Resume Next
  File1.Path = Drive1.Drive: Dir1.Path = Drive1.Drive
End Sub

Private Sub File1_Click()
Dim FPath$
  On Error Resume Next
  FPath = File1.Path: If Right$(FPath, 1) <> "\" Then FPath = FPath & "\"
  SendFName = File1.FileName
  SendBytes = FileLen(FPath & SendFName)
  Label5 = "Upload (" & Left(SendBytes / 1024, 5) & "K)"
End Sub

Private Sub File1_DblClick()
Dim FPath$
  FPath = File1.Path: If Right$(FPath, 1) <> "\" Then FPath = FPath & "\"
  ShellExecuteA hwnd, vbNullString, FPath & File1.FileName, vbNullString, FPath, 1
End Sub

Private Sub File1_KeyUp(KeyCode As Integer, Shift As Integer)
Dim FPath$
  If KeyCode <> 46 Then Exit Sub
  FPath = File1.Path: If Right$(FPath, 1) <> "\" Then FPath = FPath & "\"
  If MsgBox("Delete " & File1.FileName & " ?", vbYesNo) = vbYes Then
    Kill FPath & File1.FileName
    File1.Refresh
  End If
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
  On Error Resume Next
  If KeyAscii = 27 Then
    Beep
    Winsock2.Close: Winsock3.Close
    Winsock1.SendData "ABOR" & vbCrLf: DoEvents
    Frame3.Enabled = True: Frame4.Enabled = True: Screen.MousePointer = 0
    ProgressBar1.Value = 0: ProgressBar2.Value = 0
  End If
End Sub

Private Sub Form_Load()
  timeBeginPeriod 1
End Sub

Private Sub Form_Unload(Cancel As Integer)
  timeEndPeriod 1
End Sub

Private Sub List1_Click()
  Label4 = "Download (" & CLng(GetFileBytesFromList / 1024) & "K)"
End Sub

Private Function GetFileBytesFromList() As Double
Dim FBytes As Long
  FBytes = List1.ItemData(List1.ListIndex)
  GetFileBytesFromList = IIf(FBytes < 0, -FBytes, FBytes * 1024#)
End Function

Private Sub List1_DblClick()
Dim B$
  Screen.MousePointer = 11
  B = Text2:  Text2 = "RETR " & List1.Text: Command2_Click: Text2 = B
End Sub

Private Sub List1_KeyUp(KeyCode As Integer, Shift As Integer)
Dim B$
  If KeyCode <> 46 Then Exit Sub
  If MsgBox("Delete " & List1.Text & " ?", vbYesNo) = vbYes Then
    B = Text2:  Text2 = "DELE " & List1.Text: Command2_Click: Text2 = B
    TreeView1_NodeClick TreeView1.SelectedItem
  End If
End Sub

Private Sub Text4_Change()

End Sub

Private Sub Text8_Change()
  On Error Resume Next
  If InStrRev(Text8, "\") < 4 Then Dir1.Visible = False: Exit Sub
  Dir1.Path = Text8.Text
  Dir1.Visible = Err = 0
End Sub

Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
Dim i&, NodX As Node, NP$, NotReady As Boolean
  On Error Resume Next
  Node.Image = "Opened": Node.Expanded = True
  NP = Node.Parent.FullPath: If NP = "" Then NP = UserRootDirectory
  Do
    NotReady = False
    For Each NodX In TreeView1.Nodes
      If Len(NodX.FullPath) > Len(NP) And Node.Key <> NodX.Key Then
        TreeView1.Nodes.Remove NodX.Key: NotReady = True: Exit For
      End If
    Next NodX
  Loop While NotReady
  Winsock1.SendData "CWD " & Replace(Node.FullPath, "//", "/") & vbCrLf
  ReadCurDir Len(Text1)
End Sub

Private Sub Winsock1_Connect()
On Error Resume Next
  List1.Clear
  If Check1.Value Then Winsock1.SendData "User " & Text5 & vbCrLf: WaitForResponse
  If Check2.Value Then Winsock1.SendData "Pass " & Text6 & vbCrLf: WaitForResponse
  If Check3.Value Then Winsock1.SendData "Acct " & Text7 & vbCrLf: WaitForResponse
  Winsock1.SendData "SITE DIRSTYLE" & vbCrLf: WaitForResponse
  Winsock1.SendData "Type L 8" & vbCrLf: WaitForResponse
  
  Winsock1.SendData "PWD" & vbCrLf: WaitForResponse
  If Len(UserRootDirectory) = 0 Then Winsock1.SendData "PWD" & vbCrLf: WaitForResponse 'try one more time
  If Len(UserRootDirectory) = 0 Then UserRootDirectory = "/" 'Ok, we no longer try and just the a hard-root
  TreeView1.Nodes.Add , , UserRootDirectory, UserRootDirectory, "Opened"
  TreeView1.Nodes(UserRootDirectory).Selected = True
  TreeView1_NodeClick TreeView1.Nodes(UserRootDirectory)
End Sub

Private Sub WaitForResponse()
Dim i&, LenCC&
  LenCC = Len(Text1)
  Do: Sleep 1: DoEvents: i = i + 1: Loop Until Len(Text1) > LenCC Or i > 5000
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
  Dim S As String, B1, B2, i&, WS As Winsock
  Winsock1.GetData S, vbString
  If InStr(1, S, "Passive Mode", 1) Then
    i = Len(S)
    Do: i = i - 1: Loop Until Mid(S, i, 1) = ",": B1 = Val(Mid(S, i + 1))
    Do: i = i - 1: Loop Until Mid(S, i, 1) = ",": B2 = Val(Mid(S, i + 1))
    Set WS = IIf(Left(LastFileCommand, 4) = "STOR", Winsock3, Winsock2)
    WS.Close: WS.Connect Winsock1.RemoteHostIP, B1 + 256 * B2
  ElseIf Len(UserRootDirectory) = 0 And InStr(S, "257") > 0 Then
    UserRootDirectory = Split(S, """")(1)
  End If
  Text1 = Text1 & S: Text1.SelStart = Len(Text1) - 1
End Sub

Private Sub Winsock2_Connect()
  If Winsock2.State <> sckClosed Then RetrBytes = 0
  If LastFileCommand <> "" Then Winsock1.SendData LastFileCommand & vbCrLf: DoEvents
End Sub

Private Sub Winsock2_DataArrival(ByVal bytesTotal As Long)
Dim Buf() As Byte, i&
  On Error Resume Next
  If bytesTotal = 0 Then DoEvents: Exit Sub
  Winsock2.GetData Buf, vbArray + vbByte, bytesTotal
  ReDim Preserve RetrBuf(1 To RetrBytes + bytesTotal)
  RtlMoveMemory RetrBuf(RetrBytes + 1), Buf(0), bytesTotal
  RetrBytes = RetrBytes + bytesTotal
  ProgressBar1.Value = RetrBytes / GetFileBytesFromList: DoEvents
  If RetrBytes < 10000 Then Text3 = StrConv(RetrBuf, vbUnicode)
  'for Unix-Servers : Text3 = Replace(StrConv(RetrBuf, vbUnicode), vbLf, vbCrLf)
End Sub

Private Sub Winsock2_Close()
Dim i&, j&, LastPos&, Bytes&, StrBuf$, DirCapt$, DirPath$, ByteArr() As Byte
Dim NodX  As Node
  Screen.MousePointer = 0: ProgressBar1.Value = 0
  On Error Resume Next
  Text1 = Text1 & RetrBytes & " Bytes received." & vbCrLf: Text1.SelStart = Len(Text1) - 1
  If Right$(Dir1.Path, 1) <> "\" Then RetrFName = "\" & RetrFName
  Winsock2.Close: Winsock2.LocalPort = 0
  Select Case Left$(LastFileCommand, 4)
    Case "RETR"
      If RetrBytes = 0 Then Exit Sub
      SaveRetrBuf Dir1.Path & RetrFName
      Frame3.Enabled = True: Frame4.Enabled = True: Screen.MousePointer = 0
      File1.Refresh: RetrBytes = 0
    Case "LIST"
      List1.Clear
      If RetrBytes = 0 Then Exit Sub
      ByteArr = StrConv(RetrBuf, vbUnicode)
      LastPos = -2
      For i = 0 To UBound(ByteArr) Step 2
        If ByteArr(i) = 13 Or ByteArr(i) = 10 Then
          Bytes = i - LastPos - 2
          If Bytes >= 2 Then
            StrBuf = Space(Bytes \ 2)
            RtlMoveMemory ByVal StrPtr(StrBuf), ByteArr(i - Bytes), Bytes
            j = Len(StrBuf)
            Do
              If j < 30 Then Exit Do
              j = j - 1
            Loop Until Mid$(StrBuf, j, 1) = " " And InStr(1, "1234567890", Mid$(StrBuf, j - 1, 1), 1) > 0
            If LCase$(Left$(StrBuf, 1)) = "d" Or LCase$(Left$(StrBuf, 1)) = "l" Or InStr(1, StrBuf, "<DIR>", 1) > 0 Then
              StrBuf = Mid$(StrBuf, j + 1)
              If StrBuf <> "." And StrBuf <> ".." And StrBuf <> "" Then
                DirCapt = Trim$(StrBuf)
                DirPath = "/" & Trim$(StrBuf)
                If InStr(StrBuf, "->") Then DirCapt = Trim$(Split(StrBuf, "->")(0)) 'we have a sym-link
                Set NodX = TreeView1.Nodes.Add(TreeView1.SelectedItem, tvwChild, TreeView1.SelectedItem.FullPath & DirPath, DirCapt, "Closed")
              End If
            Else
              If Mid$(StrBuf, j + 1) <> "" Then
                List1.AddItem Trim(Mid$(StrBuf, j + 1))
                Dim FLen#: FLen = Val(Mid$(StrBuf, j - 26, 15))
                List1.ItemData(List1.NewIndex) = IIf(FLen < 1024, -FLen, FLen / 1024)
              End If
            End If
          End If
          LastPos = i
        End If
      Next i
  End Select
End Sub

Private Sub Winsock3_Connect()
Dim i&, LenCC&
  Winsock1.SendData LastFileCommand & vbCrLf
  LenCC = Len(Text1)
  Do: Sleep 1: DoEvents: i = i + 1: Loop Until Len(Text1) > LenCC Or i > 5000
  Winsock3.SendData SendBuf: DoEvents
End Sub

Private Sub Winsock3_SendComplete()
  Winsock3.Close
  Frame3.Enabled = True: Frame4.Enabled = True: Screen.MousePointer = 0
  ProgressBar2.Value = 0: LastFileCommand = ""
  TreeView1_NodeClick TreeView1.SelectedItem: DoEvents
End Sub

Private Sub Winsock3_SendProgress(ByVal bytesSent As Long, ByVal bytesRemaining As Long)
  ProgressBar2.Value = (SendBytes - bytesRemaining) / SendBytes: DoEvents
End Sub

Private Sub SaveRetrBuf(FName$)
  On Error Resume Next: Kill FName
  Open FName For Binary Access Write As #1
  Put #1, , RetrBuf: Close #1
End Sub

Private Sub LoadSendBuf(FName$)
  ReDim SendBuf(0 To 0)
  If FileLen(FName) = 0 Then Exit Sub
  ReDim SendBuf(1 To FileLen(FName))
  Open FName For Binary Access Read As #1
  Get #1, , SendBuf: Close #1
End Sub

Private Sub SendFileData(FName$)
  On Error Resume Next
  If UBound(SendBuf) = 0 Then Exit Sub
  LastFileCommand = "STOR " & FName
  Winsock1.SendData "PASV" & vbCrLf
End Sub

Private Sub RetrFileData(FName$)
  On Error Resume Next
  LastFileCommand = "RETR " & FName
  Winsock1.SendData "PASV" & vbCrLf: DoEvents
End Sub

Private Sub ReadCurDir(ByVal LenCC&)
Dim i&
  Screen.MousePointer = 11: Erase RetrBuf
  Do: Sleep 1: DoEvents: i = i + 1: Loop Until Len(Text1) > LenCC Or i > 5000
  'LastFileCommand = "LIST -a"
  LastFileCommand = "LIST ."
  'LastFileCommand = "NLST"
  Winsock1.SendData "PASV" & vbCrLf: DoEvents
End Sub