vb通过inet控件实现FTP文件上传

来自：http://hi.baidu.com/jiangdbna/item/b8177de997933b275a7cfb1e

Private Sub YdFileUp(sUpfile As String)
'sUpfile 上传文件名
On Error GoTo End_Sjsb
Dim rsFtp As Recordset
Dim LocalFile As String
Dim WebFile As String
Dim LtFtp_Ip As String 'FTP IP地址
Dim LtFtp_Port As String 'FTP端口
Dim LtFtp_User As String'FTP用户名
Dim LtFtp_Pass As String 'FTP用户密码
Dim bUnload As Boolean
TsFTP = True
XfUpok = False

With InetClient 'InetClient为Inet控件
     .AccessType = icUseDefault
     .URL = "" & Trim(LtFtp_Ip) & "'"
     .Protocol = icFTP
     .RemoteHost = Trim(LtFtp_Ip)
     .RemotePort = Val(LtFtp_Port)
     .UserName = Trim(LtFtp_User)
     .Password = Trim(LtFtp_Pass)
End With
LocalFile = "D:\GPS_Data\BusData\outputFile\" & sUpfile '文件绝对路径

If XfUpok = False Then
   InetClient.Execute , "DELETE " & sUpfile
   Do While InetClient.StillExecuting
      DoEvents
   Loop
   For iCount = 0 To 1000
       For rCount = 0 To 500
           DoEvents
      Next rCount
   Next iCount
   If Dir(LocalFile) <> Space(0) Then '加载文件，如果文件存在
      InetClient.Execute , "SEND " & LocalFile & "  " & sUpfile '上传文件
      Do While InetClient.StillExecuting
         DoEvents
      Loop
         'Kill LocalFile ’删除本地文件
   Else
      'MsgBox "没有找到相应的文件，请重试！"
   Exit Sub
   End If
End If
If XfUpok = True Then
   XfUpok = False
End If
For iCount = 0 To 1000
    For rCount = 0 To 100
        DoEvents
        If bUnload = True Then Exit Sub
    Next rCount
Next iCount
InetClient.Execute , "CLOSE"
If TsFTP = True Then
   ‘Wdbsf.Execute "UpDate Wd_Output Set Bz='已上传',ScRQ='" & Format(Date, "yyyy-MM-dd") & "',ScSJ='" & Format(Time, "HH:mm:ss") & "' where FileName='" & sUpfile & "'", dbFailOnError ’上传完后执行次更新操作
   If Dir(LocalFile) <> Space(0) Then Kill LocalFile'上传完后删除本地文件
      MsgBox sUpfile & "文件上传成功!", vbOKOnly + vbInformation, "<提示信息>"
Else
        MsgBox sUpfile & "文件上传失败.", vbCritical + vbOKOnly, "<提示信息>"
End If
Exit Sub
End_Sjsb:
    If AutoSj = 1 Then
        If Err.Number = 35764 Then
           If MsgBox("上次请求未完成，要继续等待吗?", 4 + 32, "<提示信息>") <> vbYes Then GoTo End_1
        ElseIf Err.Number = 35761 Then
           If MsgBox("网络连接超时，要重新连接吗?", 4 + 32, "<提示信息>") <> vbYes Then GoTo End_1
        ElseIf Err.Number = 35754 Then
           If MsgBox("无法连接到服务中心，要重试吗?", 4 + 32, "<提示信息>") <> vbYes Then GoTo End_1
        Else
           MsgBox "无法连接到服务中心服务器！", vbCritical + vbOKOnly, "<提示信息>"
           GoTo End_1
        End If
    Else
        If Err.Number = 35761 Then

  MsgBox Date & Space(2) & Time & "  网络连接超时", vbCritical + vbOKOnly, "<提示信息>"
        ElseIf Err.Number = 35754 Then

MsgBox Date & Space(2) & Time & "  无法连接到服务中心", vbCritical + vbOKOnly, "<提示信息>"
        Else

MsgBox Date & Space(2) & Time & "  文件上传失败", vbCritical + vbOKOnly, "<提示信息>"
           GoTo End_1
        End If
    End If
    Exit Sub
End_1:
    Screen.MousePointer = 0
     MsgBox "文件上传出错!错误编号:" & Err.Number & "描述:" & Err.Description, vbCritical + vbOKOnly, "<提示信息>"
End Sub

Private Sub InetClient_StateChanged(ByVal State As Integer)‘Inet控件的StateChanged监听事件
Dim MessStr As String
Select Case State
       Case 0
            MessStr = "没有状态可报告！"
       Case 1
            MessStr = "正在查询所指定的主机IP地址！"
       Case 2
            MessStr = "已成功找到所指定的主机的IP地址！"
       Case 3
            MessStr = "正在与主机连接..."
       Case 4
            MessStr = "  已与主机连接成功,请稍后...   "
       Case 5
            MessStr = "正在向主机发送请求..."
       Case 6
            MessStr = "发送请求已成功..."
            MessStr = "正在传输数据记录，请稍候 ... "
       Case 7
            MessStr = "正在接收主机的响应..."
       Case 8
            MessStr = "已成功接收到主机的响应..."
       Case 9
            MessStr = "正在解除与主机的连接..."
       Case 10
            MessStr = "已成功地与主机解除了连接..."
       Case 11
            MessStr = "与主机通讯时出现了错误..."
            MessStr = "Unconnected"
            MessStr = "与主机通讯时出现了错误..."
            UXfsjSb = False
       Case 12
           TsFTP = True
       
            For iCount = 0 To 1000
                For rCount = 0 To 1000
                    DoEvents
                Next rCount
            Next iCount
            Dim vtData As Variant '数据变量。
            '取得第一块。
            strData = Space(0)
            vtData = InetClient.GetChunk(1024, icString) 'icString   'icByteArray
            DoEvents
            Do While Not bDone
               strData = strData & Trim(vtData)
               DoEvents
               vtData = InetClient.GetChunk(1024, icString) 'icString   'icByteArray
               If Len(vtData) = 0 Then
                  bDone = True
               End If
            Loop
            strData = strData & Trim(vtData)
            If sDownStep = 1 Then
               sDownFileName = Trim(strData)
            ElseIf sDownStep = 3 Or sDownStep = 4 Then
               XfUpok = True
            ElseIf sDownStep = 6 Then
               sDownFileName = Trim(strData)
               For sCount = 0 To 20
                   sDownFileCount = Len(sDownFileName)
                   If sDownFileStrr(sCount) = Space(0) And sDownFileCount > 16 Then
                      sDownFileStrr(sCount) = Mid(sDownFileName, 1, 16)
                      sDownFileName = Right(sDownFileName, sDownFileCount - 18)
                   End If
               Next
            ElseIf sDownStep = 8 Then
               MessStr = "所有文件交换任务完成 ！"
            End If
            
End Select
End Sub