home *** CD-ROM | disk | FTP | other *** search
/ Chip 1998 April / ChipCD_498.iso / software / ftp / quickftp / quickft1.bas < prev    next >
BASIC Source File  |  1996-01-30  |  21KB  |  738 lines
  1. '
  2. ' SocketWrench Visual Basic Module
  3. '
  4. ' This module contains the constants used with the SocketWrench
  5. ' Windows Sockets custom control.
  6. '
  7.  
  8. ' global reply buffer
  9.  
  10. Global ctldata As String
  11.  
  12.  
  13.  
  14. '
  15. ' Socket actions
  16. '
  17. Global Const SOCKET_OPEN = 1
  18. Global Const SOCKET_CONNECT = 2
  19. Global Const SOCKET_LISTEN = 3
  20. Global Const SOCKET_ACCEPT = 4
  21. Global Const SOCKET_CANCEL = 5
  22. Global Const SOCKET_FLUSH = 6
  23. Global Const SOCKET_CLOSE = 7
  24. Global Const SOCKET_ABORT = 8
  25.  
  26. '
  27. ' Socket states
  28. '
  29. Global Const SOCKET_NONE = 0
  30. Global Const SOCKET_IDLE = 1
  31. Global Const SOCKET_LISTENING = 2
  32. Global Const SOCKET_CONNECTING = 3
  33. Global Const SOCKET_ACCEPTING = 4
  34. Global Const SOCKET_RECEIVING = 5
  35. Global Const SOCKET_SENDING = 6
  36. Global Const SOCKET_CLOSING = 7
  37.  
  38. '
  39. ' Address families
  40. '
  41. Global Const AF_UNSPEC = 0
  42. Global Const AF_UNIX = 1
  43. Global Const AF_INET = 2
  44.  
  45. '
  46. ' Socket types
  47. '
  48. Global Const SOCK_STREAM = 1
  49. Global Const SOCK_DGRAM = 2
  50. Global Const SOCK_RAW = 3
  51. Global Const SOCK_RDM = 4
  52. Global Const SOCK_SEQPACKET = 5
  53.  
  54. '
  55. ' Protocol types
  56. '
  57. Global Const IPPROTO_IP = 0
  58. Global Const IPPROTO_ICMP = 1
  59. Global Const IPPROTO_GGP = 2
  60. Global Const IPPROTO_TCP = 6
  61. Global Const IPPROTO_PUP = 12
  62. Global Const IPPROTO_UDP = 17
  63. Global Const IPPROTO_IDP = 22
  64. Global Const IPPROTO_ND = 77
  65. Global Const IPPROTO_RAW = 255
  66. Global Const IPPROTO_MAX = 256
  67.  
  68. '
  69. ' Common ports
  70. '
  71. Global Const IPPORT_ANY = 0
  72. Global Const IPPORT_ECHO = 7
  73. Global Const IPPORT_DISCARD = 9
  74. Global Const IPPORT_SYSTAT = 11
  75. Global Const IPPORT_DAYTIME = 13
  76. Global Const IPPORT_NETSTAT = 15
  77. Global Const IPPORT_FTP = 21
  78. Global Const IPPORT_TELNET = 23
  79. Global Const IPPORT_SMTP = 25
  80. Global Const IPPORT_TIMESERVER = 37
  81. Global Const IPPORT_NameSERVER = 42
  82. Global Const IPPORT_WHOIS = 43
  83. Global Const IPPORT_MTP = 57
  84. Global Const IPPORT_FINGER = 79
  85. Global Const IPPORT_TFTP = 69
  86. Global Const IPPORT_RESERVED = 1024
  87. Global Const IPPORT_USERRESERVED = 5000
  88.  
  89. '
  90. ' Network addresses
  91. '
  92. Global Const INADDR_ANY = "0.0.0.0"
  93. Global Const INADDR_LOOPBACK = "127.0.0.1"
  94. Global Const INADDR_NONE = "255.255.255.255"
  95.  
  96. '
  97. ' Shutdown values
  98. '
  99. Global Const SOCKET_READ = 0
  100. Global Const SOCKET_WRITE = 1
  101. Global Const SOCKET_READWRITE = 2
  102.  
  103. '
  104. ' Error response values
  105. '
  106. Global Const SOCKET_ERRIGNORE = 0
  107. Global Const SOCKET_ERRDISPLAY = 1
  108.  
  109. '
  110. ' Socket errors
  111. '
  112. Global Const WSABASEERR = 24000
  113. Global Const WSAEINTR = 24004
  114. Global Const WSAEBADF = 24009
  115. Global Const WSAEACCES = 24013
  116. Global Const WSAEFAULT = 24014
  117. Global Const WSAEINVAL = 24022
  118. Global Const WSAEMFILE = 24024
  119. Global Const WSAEWOULDBLOCK = 24035
  120. Global Const WSAEINPROGRESS = 24036
  121. Global Const WSAEALREADY = 24037
  122. Global Const WSAENOTSOCK = 24038
  123. Global Const WSAEDESTADDRREQ = 24039
  124. Global Const WSAEMSGSIZE = 24040
  125. Global Const WSAEPROTOTYPE = 24041
  126. Global Const WSAENOPROTOOPT = 24042
  127. Global Const WSAEPROTONOSUPPORT = 24043
  128. Global Const WSAESOCKTNOSUPPORT = 24044
  129. Global Const WSAEOPNOTSUPP = 24045
  130. Global Const WSAEPFNOSUPPORT = 24046
  131. Global Const WSAEAFNOSUPPORT = 24047
  132. Global Const WSAEADDRINUSE = 24048
  133. Global Const WSAEADDRNOTAVAIL = 24049
  134. Global Const WSAENETDOWN = 24050
  135. Global Const WSAENETUNREACH = 24051
  136. Global Const WSAENETRESET = 24052
  137. Global Const WSAECONNABORTED = 24053
  138. Global Const WSAECONNRESET = 24054
  139. Global Const WSAENOBUFS = 24055
  140. Global Const WSAEISCONN = 24056
  141. Global Const WSAENOTCONN = 24057
  142. Global Const WSAESHUTDOWN = 24058
  143. Global Const WSAETOOMANYREFS = 24059
  144. Global Const WSAETIMEDOUT = 24060
  145. Global Const WSAECONNREFUSED = 24061
  146. Global Const WSAELOOP = 24062
  147. Global Const WSAENAMETOOLONG = 24063
  148. Global Const WSAEHOSTDOWN = 24064
  149. Global Const WSAEHOSTUNREACH = 24065
  150. Global Const WSAENOTEMPTY = 24066
  151. Global Const WSAEPROCLIM = 24067
  152. Global Const WSAEUSERS = 24068
  153. Global Const WSAEDQUOT = 24069
  154. Global Const WSAESTALE = 24070
  155. Global Const WSAEREMOTE = 24071
  156. Global Const WSASYSNOTREADY = 24091
  157. Global Const WSAVERNOTSUPPORTED = 24092
  158. Global Const WSANOTINITIALISED = 24093
  159. Global Const WSAHOST_NOT_FOUND = 25001
  160. Global Const WSATRY_AGAIN = 25002
  161. Global Const WSANO_RECOVERY = 25003
  162. Global Const WSANO_DATA = 25004
  163. Global Const WSANO_ADDRESS = 25004
  164.  
  165. Option Explicit
  166.  
  167. Function FTPcommand (commnd As String, controlsocket As Control, message As Label) As Integer
  168. '__
  169. '__ GLOBAL FTPcommand
  170. '__
  171. '__   parameter commnd As String
  172. '__   parameter controlsocket As Control
  173. '__   parameter message As Label
  174. '__   called by GLOBAL FTPGetDirectory
  175. '__   called by GLOBAL FTPGetDirList
  176. '__   called by GLOBAL FTPGetFile
  177. '__   called by GLOBAL FTPListen
  178. '__   called by GLOBAL FTPLogin
  179. '__   called by GLOBAL FTPPutFile
  180. '__   called by GLOBAL FTPSetDirectory
  181. '__   called by FTP_form SendFTPCOMMAND
  182. '__   calls     GLOBAL FTPResult
  183. '__
  184.     Dim cmd
  185.     Dim reply
  186.     cmd = commnd
  187.     On Error Resume Next
  188.     While controlsocket.IsReadable
  189.       reply = FTPResult(controlsocket, message)
  190.     Wend
  191.     If Left(cmd, 4) <> "PASS" Then message = "> " & cmd
  192.     ctldata = cmd
  193.     ctldata = ctldata & Chr$(13) & Chr$(10)
  194.     controlsocket.SendLen = Len(ctldata)
  195.     controlsocket.SendData = ctldata
  196.  
  197.     If Err <> 0 Then
  198.         FTPcommand = False
  199.     Else
  200.         FTPcommand = True
  201.     End If
  202.  
  203. End Function
  204.  
  205.  
  206. Function FTPConnect (HostName As String, controlsocket As Control, message As Label)
  207. '__
  208. '__ GLOBAL FTPConnect
  209. '__
  210. '__   parameter HostName As String
  211. '__   parameter controlsocket As Control
  212. '__   parameter message As Label
  213. '__   called by FTP_form DoConnectOnly
  214. '__   calls     GLOBAL FTPResult
  215. '__
  216.     Dim reply As Integer
  217.     Dim Errmess
  218.     On Error GoTo ConnectError
  219.     ctldata = ""
  220.     Errmess = "Connect Error: "
  221.     FTPConnect = False
  222.     If HostName = "" Then Exit Function
  223.     controlsocket.AddressFamily = AF_INET
  224.     controlsocket.Protocol = IPPROTO_IP
  225.     controlsocket.Type = SOCK_STREAM
  226.     Errmess = "Error in Host Name " & HostName
  227.     controlsocket.HostName = HostName
  228.     controlsocket.RemotePort = IPPORT_FTP
  229.     Errmess = "Connect Error: "
  230.     controlsocket.Binary = False
  231.     controlsocket.BufferSize = 1024
  232.     controlsocket.Blocking = True
  233.  
  234.     On Error Resume Next
  235.     Err = 0
  236.     controlsocket.Action = SOCKET_CONNECT
  237.     If Err Then
  238.         MsgBox Error$
  239.         Exit Function
  240.     End If
  241.  
  242.       reply = FTPResult(controlsocket, message)
  243.     
  244.       If reply = 220 Then
  245.         FTPConnect = True
  246.       Else
  247.         controlsocket.Action = SOCKET_CLOSE
  248.       End If
  249.     Exit Function
  250. ConnectError:
  251.     MsgBox Errmess, 64
  252.     ctldata = Errmess
  253.     Exit Function
  254. End Function
  255.  
  256.  
  257. Sub FTPDisconnect (controlsocket As Control)
  258. '__
  259. '__ GLOBAL FTPDisconnect
  260. '__
  261. '__   parameter controlsocket As Control
  262. '__   called by FTP_form DoDisconnect
  263. '__
  264.         controlsocket.Action = SOCKET_CLOSE
  265. End Sub
  266.  
  267.  
  268. Sub FTPGetDirectory (controlsocket As Control, message As Label)
  269. '__
  270. '__ GLOBAL FTPGetDirectory
  271. '__
  272. '__   parameter controlsocket As Control
  273. '__   parameter message As Label
  274. '__   called by GLOBAL FTPSetDirectory
  275. '__   called by FTP_form DoConnFTPDisc
  276. '__   calls     GLOBAL FTPcommand
  277. '__   calls     GLOBAL FTPResult
  278. '__
  279.     
  280.     If Not FTPcommand("PWD", controlsocket, message) Then Exit Sub
  281.     If FTPResult(controlsocket, message) <> 257 Then Exit Sub
  282.     ctldata = Mid$(ctldata, 2, InStr(ctldata, " ") - 3)
  283. End Sub
  284.  
  285.  
  286. Function FTPGetDirList (controlsocket As Control, listendatasocket As Control, message As Label)
  287. '__
  288. '__ GLOBAL FTPGetDirList
  289. '__
  290. '__   parameter controlsocket As Control
  291. '__   parameter listendatasocket As Control
  292. '__   parameter message As Label
  293. '__   called by FTP_form Do_the_dirlist
  294. '__   calls     GLOBAL FTPcommand
  295. '__   calls     GLOBAL FTPListen
  296. '__   calls     GLOBAL FTPResult
  297. '__
  298.     Dim buffer As String
  299.     Dim result As Integer
  300.     Dim ifile As Integer
  301.     FTPGetDirList = False
  302.     If Not FTPListen(controlsocket, listendatasocket, message) Then Exit Function
  303.     result = FTPcommand("TYPE A", controlsocket, message)
  304.     If result Then result = FTPResult(controlsocket, message)
  305.     result = FTPcommand("NLST", controlsocket, message)
  306.     If Not result Then Exit Function
  307.     result = FTPResult(controlsocket, message)
  308.     While controlsocket.IsReadable
  309.       result = FTPResult(controlsocket, message)
  310.     Wend
  311.     If result > 299 Then
  312.         listendatasocket.Action = SOCKET_CLOSE
  313.         Exit Function
  314.     End If
  315.  
  316.     listendatasocket.Action = SOCKET_ACCEPT
  317.     On Error Resume Next
  318.     Kill Dir_File
  319.     ifile = FreeFile
  320.     Err = 0
  321.     Open Dir_File For Binary As #ifile
  322.     If Err Then
  323.         Close ifile
  324.         MsgBox Error$
  325.         listendatasocket.Action = SOCKET_CLOSE
  326.         Exit Function
  327.     End If
  328.  
  329.     Do
  330.         listendatasocket.RecvLen = 1024
  331.         Err = 0
  332.         buffer = listendatasocket.RecvData
  333.         If Err Then
  334.             MsgBox Error$
  335.             Exit Do
  336.         End If
  337.         If listendatasocket.RecvLen = 0 Then Exit Do
  338.         Put #ifile, , buffer
  339.         DoEvents
  340.     Loop
  341.  
  342.     Close #ifile
  343.     listendatasocket.Action = SOCKET_CLOSE
  344.     If controlsocket.IsReadable Then result = FTPResult(controlsocket, message)
  345.     FTPGetDirList = True
  346. End Function
  347.  
  348.  
  349. Function FTPGetFile (RemoteFile As String, LocalFile As String, controlsocket As Control, listendatasocket As Control, message As Label)
  350. '__
  351. '__ GLOBAL FTPGetFile
  352. '__
  353. '__   parameter RemoteFile As String
  354. '__   parameter LocalFile As String
  355. '__   parameter controlsocket As Control
  356. '__   parameter listendatasocket As Control
  357. '__   parameter message As Label
  358. '__   called by FTP_form getfilenow
  359. '__   calls     GLOBAL FTPcommand
  360. '__   calls     GLOBAL FTPListen
  361. '__   calls     GLOBAL FTPResult
  362. '__
  363.     Dim buffer As String
  364.     Dim result As Integer
  365.     Dim unit As Integer
  366.     Dim ti As Double
  367.     FTPGetFile = False
  368.     transferaborted = False
  369.  
  370.     If RemoteFile = "" Or LocalFile = "" Then Exit Function
  371.     On Error Resume Next
  372.     unit = FreeFile
  373.     ''was a bug!!! missing:
  374.     Kill LocalFile
  375.     Err = 0
  376.     Open LocalFile For Binary As unit
  377.     If Err Then
  378.         ctldata = Error$
  379.         Close unit
  380.         Exit Function
  381.     End If
  382.     
  383.     If Not FTPListen(controlsocket, listendatasocket, message) Then Close unit: Exit Function
  384.     If Not FTPcommand("RETR " & RemoteFile, controlsocket, message) Then Close unit: Exit Function
  385.     
  386.     result = FTPResult(controlsocket, message)
  387.     If result \ 100 <> 1 Then
  388.         listendatasocket.Action = SOCKET_CLOSE
  389.         Close unit
  390.         Exit Function
  391.     End If
  392.  
  393.     listendatasocket.Action = SOCKET_ACCEPT
  394.     
  395.  
  396.     FTPGetFile = True
  397.  
  398.     Do
  399.         listendatasocket.RecvLen = listendatasocket.BufferSize
  400.         Err = 0
  401.         buffer = listendatasocket.RecvData
  402.         If Err Then
  403.             FTPGetFile = False
  404.             MsgBox Error$
  405.             Exit Do
  406.         End If
  407.         If transferaborted Then
  408.             FTPGetFile = False
  409.             MsgBox "File Transfer Aborted", 32
  410.             message = "File Transfer Aborted"
  411.             Exit Do
  412.         End If
  413.         If listendatasocket.RecvLen = 0 Then Exit Do
  414.         Put unit, , buffer
  415.         message = Seek(1)
  416.         DoEvents
  417.     Loop
  418.  
  419.     Close unit
  420.     listendatasocket.Action = SOCKET_CLOSE
  421.     result = FTPResult(controlsocket, message)
  422. End Function
  423.  
  424.  
  425. Function FTPListen (controlsocket As Control, listendatasocket As Control, message As Label)
  426. '__
  427. '__ GLOBAL FTPListen
  428. '__
  429. '__   parameter controlsocket As Control
  430. '__   parameter listendatasocket As Control
  431. '__   parameter message As Label
  432. '__   called by GLOBAL FTPGetDirList
  433. '__   called by GLOBAL FTPGetFile
  434. '__   called by GLOBAL FTPPutFile
  435. '__   calls     GLOBAL FTPcommand
  436. '__   calls     GLOBAL FTPResult
  437. '__
  438.     Dim Port As Integer, HexPort As String, Address As String
  439.     Dim reply As Integer
  440.     Dim i As Integer, P As Integer
  441.  
  442.     FTPListen = False
  443.     
  444.     listendatasocket.AddressFamily = AF_INET
  445.     listendatasocket.Binary = True
  446.     listendatasocket.Blocking = True
  447.     listendatasocket.BufferSize = 1024
  448.     listendatasocket.HostAddress = INADDR_ANY
  449.     listendatasocket.LocalPort = IPPORT_ANY
  450. '    listendatasocket.Protocol = IPPROTO_TCP
  451.     listendatasocket.Protocol = IPPROTO_IP
  452.     listendatasocket.Timeout = 0
  453.     listendatasocket.Type = SOCK_STREAM
  454.     listendatasocket.Action = SOCKET_LISTEN
  455.  
  456.     '
  457.     ' Construct a PORT command string that consists of the
  458.     ' local IP address and port number broken down into six
  459.     ' bytes seperated by commas
  460.     '
  461.     Port = listendatasocket.LocalPort
  462.     Address = listendatasocket.LocalAddress
  463.  
  464.     '
  465.     ' The IP address part is easy because it's already in
  466.     ' dot notation; just substitute commas for the dots
  467.     '
  468.     For i = 1 To 3
  469.         P = InStr(Address, ".")
  470.         If P <> 0 Then Mid$(Address$, P, 1) = ","
  471.     Next i
  472.     
  473.     '
  474.     ' Split the local port number into high and low bytes by
  475.     ' converting it to hex, pulling it apart, and then converting
  476.     ' the pieces back to decimal
  477.     '
  478.     HexPort = Hex$(Port)
  479.     If Len(HexPort) = 3 Then HexPort = "0" + HexPort
  480.     ctldata = "PORT " & Address & "," & (Val("&h" + Left$(HexPort, 2))) & "," & (Port And &HFF)
  481.     
  482.     '
  483.     ' Send the PORT command to the server so that it knows
  484.     ' where we are
  485.     '
  486.     If Not FTPcommand(ctldata, controlsocket, message) Then GoTo OpenFailed
  487.     If FTPResult(controlsocket, message) <> 200 Then GoTo OpenFailed
  488.     
  489.     '
  490.     ' Select the file type for transfer
  491.     '
  492.     If TransType = Asc("I") Then
  493.         ctldata = "TYPE I"
  494.     Else
  495.         ctldata = "TYPE A"
  496.     End If
  497.     
  498.     If Not FTPcommand(ctldata, controlsocket, message) Then GoTo OpenFailed
  499.     If FTPResult(controlsocket, message) \ 100 <> 2 Then GoTo OpenFailed
  500.     
  501.     FTPListen = True
  502.     Exit Function
  503.  
  504. OpenFailed:
  505.     If listendatasocket.Listening Then listendatasocket.Action = SOCKET_CLOSE
  506.     Exit Function
  507. End Function
  508.  
  509.  
  510. Function FTPLogin (Username As String, Password As String, controlsocket As Control, listendatasocket As Control, message As Label) As Integer
  511. '__
  512. '__ GLOBAL FTPLogin
  513. '__
  514. '__   parameter Username As String
  515. '__   parameter Password As String
  516. '__   parameter controlsocket As Control
  517. '__   parameter listendatasocket As Control
  518. '__   parameter message As Label
  519. '__   called by FTP_form DoConnectOnly
  520. '__   calls     GLOBAL FTPcommand
  521. '__   calls     GLOBAL FTPResult
  522. '__
  523.     Dim reply As Integer
  524.     Dim Counter As Integer
  525.     
  526.     FTPLogin = False
  527.     If controlsocket.IsReadable Then
  528.         reply = FTPResult(controlsocket, message)
  529.     End If
  530.  
  531.     While reply \ 100 <> 2 And controlsocket.IsReadable
  532.         reply = FTPResult(controlsocket, message)
  533.     Wend
  534.  
  535.     ctldata = "USER " & Username
  536.     If Not FTPcommand(ctldata, controlsocket, message) Then Exit Function
  537.     reply = FTPResult(controlsocket, message)
  538.  
  539.     If reply = 331 Then
  540.         ctldata = "PASS " & Password
  541.         If Not FTPcommand(ctldata, controlsocket, message) Then Exit Function
  542.         reply = FTPResult(controlsocket, message)
  543.     End If
  544.     
  545.     While reply \ 100 <> 2 And controlsocket.IsReadable
  546.         reply = FTPResult(controlsocket, message)
  547.     Wend
  548.  
  549.     If reply = 230 Then
  550.         FTPLogin = True
  551.     Else
  552.         MsgBox "Invalid user name or password"
  553.     End If
  554.  
  555. End Function
  556.  
  557.  
  558. Function FTPPutFile (LocalFile As String, RemoteFile As String, controlsocket As Control, listendatasocket As Control, message As Label)
  559. '__
  560. '__ GLOBAL FTPPutFile
  561. '__
  562. '__   parameter LocalFile As String
  563. '__   parameter RemoteFile As String
  564. '__   parameter controlsocket As Control
  565. '__   parameter listendatasocket As Control
  566. '__   parameter message As Label
  567. '__   called by FTP_form putfilenow
  568. '__   calls     GLOBAL FTPcommand
  569. '__   calls     GLOBAL FTPListen
  570. '__   calls     GLOBAL FTPResult
  571. '__
  572.     Dim buffer As String
  573.     Dim result As Integer, size As Long
  574.     Dim unit As Integer
  575.     Dim i As Integer
  576.     Dim ti As Double
  577.     On Error Resume Next
  578.     Err = 0
  579.     ctldata = "Unknown Error"
  580.     FTPPutFile = False
  581.     transferaborted = False
  582.  
  583.     If RemoteFile = "" Or LocalFile = "" Then Exit Function
  584.     unit = FreeFile
  585.     Open LocalFile For Binary As unit
  586.  
  587.     If Err Then
  588.         'got an error...on file open...don't proceed
  589.         ctldata = Error$
  590.         Close unit
  591.         Exit Function
  592.     End If
  593.  
  594.     If Not FTPListen(controlsocket, listendatasocket, message) Then Close unit: Exit Function
  595.     If Not FTPcommand("STOR " & RemoteFile, controlsocket, message) Then Close unit: Exit Function
  596.     
  597.     If FTPResult(controlsocket, message) \ 100 <> 1 Then
  598.         listendatasocket.Action = SOCKET_ABORT
  599.         Close unit
  600.         Exit Function
  601.     End If
  602.  
  603.     Err = 0
  604.     listendatasocket.Action = SOCKET_ACCEPT
  605.     
  606.     size = FileLen(LocalFile)
  607. '    If size < listendatasocket.buffersize Then
  608. '            listendatasocket.SendLen = size
  609. '    Else
  610. '            listendatasocket.SendLen = listendatasocket.buffersize
  611. '    End If
  612.     buffer = Space(listendatasocket.BufferSize)
  613.     
  614.     If Err Then
  615.         listendatasocket.Action = SOCKET_CLOSE
  616.         ctldata = Error$
  617.         Close unit
  618.         Exit Function
  619.     End If
  620.     
  621.     FTPPutFile = True
  622.     Do
  623.         Get unit, , buffer
  624.         If size < Len(buffer) Then
  625.             listendatasocket.SendLen = size
  626.             listendatasocket.SendData = Left(buffer, size)
  627.             size = 0
  628.         Else
  629.              listendatasocket.SendLen = Len(buffer)
  630.              listendatasocket.SendData = buffer
  631.              size = size - Len(buffer)
  632.         End If
  633.         Debug.Print listendatasocket.SendLen
  634.         While Not listendatasocket.IsWritable: DoEvents: Wend
  635.         ti = Timer: While Timer - .1 < ti: DoEvents: Wend
  636.         message = size
  637.         If Err > 0 Then
  638.             FTPPutFile = False
  639.             MsgBox Error$
  640.             Exit Do
  641.         End If
  642.         If transferaborted Then
  643.             FTPPutFile = False
  644.             MsgBox "File Transfer Aborted", 32
  645.             Exit Do
  646.         End If
  647.         If size = 0 Then Exit Do
  648.         For i = 1 To 200: DoEvents: Next
  649.     Loop
  650.  
  651.     Close unit
  652.     listendatasocket.Action = SOCKET_CLOSE
  653.     result = FTPResult(controlsocket, message)
  654. End Function
  655.  
  656.  
  657. Function FTPResult (controlsocket As Control, message As Label) As Integer
  658. '__
  659. '__ GLOBAL FTPResult
  660. '__
  661. '__   parameter controlsocket As Control
  662. '__   parameter message As Label
  663. '__   called by GLOBAL FTPcommand
  664. '__   called by GLOBAL FTPConnect
  665. '__   called by GLOBAL FTPGetDirectory
  666. '__   called by GLOBAL FTPGetDirList
  667. '__   called by GLOBAL FTPGetFile
  668. '__   called by GLOBAL FTPListen
  669. '__   called by GLOBAL FTPLogin
  670. '__   called by GLOBAL FTPPutFile
  671. '__   called by GLOBAL FTPSetDirectory
  672. '__   called by FTP_form SendFTPCOMMAND
  673. '__
  674.     Dim sockdata As String, reply As Integer
  675.     Dim continued As Integer
  676.     On Error Resume Next
  677.     
  678.   continued = 0
  679.   Do
  680.     
  681.     DoEvents
  682.     controlsocket.RecvLen = 255
  683.     '
  684.     '
  685.     sockdata = ""
  686.     
  687.     sockdata = controlsocket.RecvData & "     " 'pad just in case
  688.     message = "< " & sockdata
  689.  
  690.     reply = Val(Left$(sockdata, 3))
  691. '    If Mid$(sockdata, 4, 1) = "-" Then
  692. '        Do
  693. '            controlsocket.RecvLen = 255
  694. '            sockdata = controlsocket.RecvData
  695. '            If Val(Left$(sockdata, 3)) = reply Then Exit Do
  696. '            message = "<" & sockdata
  697. '        Loop
  698. '    End If
  699.     ctldata = Right$(sockdata, Len(sockdata) - InStr(sockdata, " "))
  700.     On Error Resume Next
  701.     
  702.     If Mid(sockdata, 4, 1) = " " Then
  703.       If reply = continued Then continued = 0
  704.     ElseIf Mid(sockdata, 4, 1) = "-" And continued = 0 Then
  705.         '- is continuation character, first line only
  706.         'keep going until RFC959 is satisfied:
  707.         'same code with space
  708.         continued = reply
  709.     End If
  710.     DoEvents
  711.   Loop Until continued = 0
  712.   FTPResult = reply
  713. End Function
  714.  
  715.  
  716. Sub FTPSetDirectory (dirname As String, controlsocket As Control, message As Label)
  717. '__
  718. '__ GLOBAL FTPSetDirectory
  719. '__
  720. '__   parameter dirname As String
  721. '__   parameter controlsocket As Control
  722. '__   parameter message As Label
  723. '__   called by FTP_form DoConnFTPDisc
  724. '__   called by FTP_form GoToDir
  725. '__   calls     GLOBAL FTPcommand
  726. '__   calls     GLOBAL FTPGetDirectory
  727. '__   calls     GLOBAL FTPResult
  728. '__
  729.     Dim cmd As String
  730.     If dirname = ".." Then cmd = "CDUP" Else cmd = "CWD " & dirname
  731.     If Not FTPcommand(cmd, controlsocket, message) Then Exit Sub
  732.     
  733.     If FTPResult(controlsocket, message) <> 250 Then Exit Sub
  734.     Call FTPGetDirectory(controlsocket, message)
  735. End Sub
  736.  
  737.  
  738.