已实现FTP断点下载,求FTP断点上传代码(自已改的不能上传)

彭希仁 · 发表于 2009-10-21 15:54

Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Info() As String, TimerCountA As Long

Private WithEvents wscControl As MSWinsockLib.Winsock
Private WithEvents wscData As MSWinsockLib.Winsock
Private Tmp As String, FileSize As String, DFile As String, ren

Private Sub TimerControl_Timer()
LabelControl.Caption = "控制连接状态：" & wscControl.State
End Sub

Private Sub TimerData_Timer()
LabelData.Caption = "数据连接状态：" & wscData.State
End Sub

Private Sub wscControl_DataArrival(ByVal bytesTotal As Long)
Dim i As String
wscControl.GetData Tmp
End Sub

Private Sub wscData_DataArrival(ByVal bytesTotal As Long)
Dim ByteData() As Byte
wscData.GetData ByteData(), vbByte
Open DFile For Binary Lock Write As #1
ProgressBar.Value = FileLen(DFile)
If LOF(1) > 0 Then
      Seek #1, LOF(1) + 1
End If
Put #1, , ByteData()
Close #1
End Sub

Private Sub wscData_Close()
wscData.Close
End Sub

Function ChkTime()
Dim i As Integer
i = 50
Do While i > 0
      If Tmp <> "" Then Exit Function
      Sleep (100)
      DoEvents
      i = i - 1
Loop
wscControl.Close
ChkTime = True
End Function

Function ConnFtp(HostIp, HostPort, User, Pass)

If wscControl Is Nothing Then
      Set wscControl = Controls.Add("MSWinsock.Winsock", "wscControl", Me)
      TimerControl.Interval = 100
      TimerControl.Enabled = True
End If

If wscControl.RemoteHost <> "" Then '已连接了就不用再连了
   ConnFtp = "OK"
   Exit Function
End If
With wscControl
      .RemoteHost = HostIp
      .RemotePort = HostPort
      .Connect
End With
If ChkTime Then
      ConnFtp = "连接超时，是否重试？"
      Exit Function
End If
Debug.Print Tmp
Select Case Left(Tmp, 3)
Case "220"
      Tmp = ""
      wscControl.SendData "USER " & User & vbCrLf
      Debug.Print "USER " & User & vbCrLf
      If ChkTime Then
         ConnFtp = "连接错误USER，是否重试？" & vbCrLf & Tmp
         Exit Function
      End If
      Debug.Print Tmp
      Select Case Left(Tmp, 3)
      Case "331"
         Tmp = ""
         wscControl.SendData "PASS " & Pass & vbCrLf
         Debug.Print "PASS " & Pass & vbCrLf
PassCS:
         If ChkTime Then
            ConnFtp = "连接错误PASS，是否重试？" & vbCrLf & Tmp
            Exit Function
         End If
         Debug.Print Tmp
         Select Case Left(Tmp, 3)
         Case "230"
            If InStr(Tmp, "230 ") > 0 Then
                  ConnFtp = "OK"
                  Tmp = ""
                  Exit Function
            End If
            Tmp = ""
            GoTo PassCS
         Case "530"
            ConnFtp = "登陆失败，用户名或密码错误，是否重试？" & vbCrLf & Tmp
            wscControl.Close
            Tmp = ""
            Exit Function
         End Select
      End Select
End Select
ConnFtp = "错误"
End Function

Function DownFile(File As String, TransferMode As String)
Dim FileHaveLen As String
If wscControl.State <> 7 Then
      MsgBox "请确认当前连接状态！1"
      Exit Function
End If
wscControl.SendData "NOOP " & vbCrLf
Debug.Print "NOOP " & vbCrLf
If ChkTime Or Left(Tmp, 3) <> 200 Then
      Debug.Print Tmp
      DownFile = "请确认当前连接状态！2" & vbCrLf & Tmp
      Tmp = ""
      Exit Function
Else
      Debug.Print Tmp
      Tmp = ""
End If
If TransferMode = "I" Or TransferMode = "A" Then
      wscControl.SendData "TYPE " & TransferMode & vbCrLf
      Debug.Print "TYPE " & TransferMode & vbCrLf
      If ChkTime Or Left(Tmp, 3) <> 200 Then
         Debug.Print Tmp
         DownFile = "改变状态失败！" & vbCrLf & Tmp
         Tmp = ""
         Exit Function
      Else
         Debug.Print Tmp
         Tmp = ""
      End If
End If
File = Replace(File, "\", "/")
Dim PathT As String
PathT = Left(File, InStrRev(File, "/"))
If PathT <> "" Then
      wscControl.SendData "CWD " & PathT & vbCrLf
      Debug.Print "CWD " & PathT & vbCrLf
      If ChkTime Or Left(Tmp, 3) <> 250 Then
         Debug.Print Tmp
         DownFile = "改变目录失败！" & vbCrLf & Tmp
         Tmp = ""
         Exit Function
      Else
         Debug.Print Tmp
         Tmp = ""
      End If
End If
Dim FileT As String
FileT = Right(File, Len(File) - InStrRev(File, "/"))
wscControl.SendData "SIZE " & FileT & vbCrLf
Debug.Print "SIZE " & FileT & vbCrLf
If ChkTime Or Left(Tmp, 3) <> 213 Then
      Debug.Print Tmp
      DownFile = "取得文件大小失败！" & vbCrLf & Tmp
      Tmp = ""
      Exit Function
Else
      Debug.Print Tmp
      FileSize = Right(Tmp, Len(Tmp) - 4)
      ProgressBar.Max = FileSize
      Me.Label1.Caption = "文件大小：" + CStr(FormatNumber(FileSize / 1024, 2)) + "KB..."
      Tmp = ""
End If
wscControl.SendData "PASV" & vbCrLf
Debug.Print "PASV" & vbCrLf
If ChkTime Or Left(Tmp, 3) <> 227 Then
      Debug.Print Tmp
      DownFile = "获取Pasv端口失败！" & vbCrLf & Tmp
      Tmp = ""
      Exit Function
Else
      Debug.Print Tmp
      Dim Tmp1, Tmp2, Tmp3, Tmp4, TmpIp, TmpPort
      Tmp1 = InStr(Tmp, Chr(40)) + 1
      Tmp2 = InStrRev(Tmp, Chr(41))
      Tmp3 = Mid(Tmp, Tmp1, Tmp2 - Tmp1)
      Tmp4 = Split(Tmp3, ",")
      TmpIp = Tmp4(0) & "." & Tmp4(1) & "." & Tmp4(2) & "." & Tmp4(3)
      TmpPort = Tmp4(4) * 256 + Tmp4(5)
      Tmp = ""
End If
Open DFile For Binary Lock Write As #1
If LOF(1) > 0 Then
      FileHaveLen = FileLen(DFile)
      Close #1
   '  If MsgBox("文件已存在，是否续传？", vbYesNo, "提示：") <> vbYes Then
   '    Kill DFile
   '  Else
         wscControl.SendData "REST " & FileHaveLen & vbCrLf
         Debug.Print "REST " & FileHaveLen & vbCrLf
         If ChkTime Or Left(Tmp, 3) <> 350 Then
            MsgBox "服务器不支持续传，将重新下载文件！" & vbCrLf & Tmp
            Kill DFile
         End If
         Debug.Print Tmp
         Tmp = ""
   '  End If
Else
      Close #1
End If
'数据下载部分
If wscData Is Nothing Then
      Set wscData = Controls.Add("MSWinsock.Winsock", "wscData", Me)
      TimerData.Interval = 100
      TimerData.Enabled = True
End If
With wscData
      .RemoteHost = TmpIp
      .RemotePort = TmpPort
      .Connect
End With
wscControl.SendData "RETR " & FileT & vbCrLf
Debug.Print "RETR " & FileT & vbCrLf
If ChkTime Then
      DownFile = "连接数据超时！"
      Exit Function
End If
Debug.Print Tmp
If InStr(Tmp, "226 ") > 0 Then GoTo End1
Tmp = ""
Do While wscData.State = 7
      DoEvents
Loop
If ChkTime Then
      DownFile = "下载失败！"
      Exit Function
End If
Debug.Print Tmp
End1:
Tmp = ""
DownFile = "OK"
End Function

Private Sub Command1_Click()
Dim n
DFile = "F:\资产管理系统.exe"
a1:
n = ConnFtp("*.*.*.*", "21", "用户名", "密码")
If n <> "OK" Then
      If MsgBox(n, vbYesNo, "提示：") = vbYes Then GoTo a1
      Exit Sub
End If

n = DownFile("2009-10-19.txt", "I")
  Timer1.Enabled = True
' n = ldFile("2009-10-19.txt", "A")
If n <> "OK" Then
      MsgBox n, , "提示："
      Exit Sub
End If
MsgBox "下载成功！"
End Sub

Private Sub Timer1_Timer()
Dim n
'ren = ren + 1
'If ren < 4 Then Exit Sub
'ren = 0

n = DownFile("资产管理系统.exe", "I")

End Sub

'以下是我改的断点上传代码，为什么不能上传啊
Function ldFile(File As String, TransferMode As String)
Dim FileHaveLen As String
If wscControl.State <> 7 Then
      MsgBox "请确认当前连接状态！1"
      Exit Function
End If
wscControl.SendData "NOOP " & vbCrLf
Debug.Print "NOOP " & vbCrLf
If ChkTime Or Left(Tmp, 3) <> 200 Then
      Debug.Print Tmp
      ldFile = "请确认当前连接状态！2" & vbCrLf & Tmp
      Tmp = ""
      Exit Function
Else
      Debug.Print Tmp
      Tmp = ""
End If
If TransferMode = "I" Or TransferMode = "A" Then
      wscControl.SendData "TYPE " & TransferMode & vbCrLf
      Debug.Print "TYPE " & TransferMode & vbCrLf
      If ChkTime Or Left(Tmp, 3) <> 200 Then
         Debug.Print Tmp
         ldFile = "改变状态失败！" & vbCrLf & Tmp
         Tmp = ""
         Exit Function
      Else
         Debug.Print Tmp
         Tmp = ""
      End If
End If
File = Replace(File, "\", "/")
Dim PathT As String
PathT = Left(File, InStrRev(File, "/"))
If PathT <> "" Then
      wscControl.SendData "CWD " & PathT & vbCrLf
      Debug.Print "CWD " & PathT & vbCrLf
      If ChkTime Or Left(Tmp, 3) <> 250 Then
         Debug.Print Tmp
         ldFile = "改变目录失败！" & vbCrLf & Tmp
         Tmp = ""
         Exit Function
      Else
         Debug.Print Tmp
         Tmp = ""
      End If
End If
Dim FileT As String
FileT = Right(File, Len(File) - InStrRev(File, "/"))
wscControl.SendData "SIZE " & FileT & vbCrLf
Debug.Print "SIZE " & FileT & vbCrLf
If ChkTime Or Left(Tmp, 3) <> 213 Then
      Debug.Print Tmp
      ldFile = "取得文件大小失败！" & vbCrLf & Tmp
      Tmp = ""
      Exit Function
Else
      Debug.Print Tmp
      FileSize = Right(Tmp, Len(Tmp) - 4)

      Open DFile For Binary Lock Write As #1
      Close #1

      ProgressBar.Max = FileLen(DFile)
      Me.Label1.Caption = "文件大小：" + CStr(FormatNumber(FileSize / 1024, 2)) + "KB..."
      Tmp = ""
End If
wscControl.SendData "PASV" & vbCrLf
Debug.Print "PASV" & vbCrLf
If ChkTime Or Left(Tmp, 3) <> 227 Then
      Debug.Print Tmp
      ldFile = "获取Pasv端口失败！" & vbCrLf & Tmp
      Tmp = ""
      Exit Function
Else
      Debug.Print Tmp
      Dim Tmp1, Tmp2, Tmp3, Tmp4, TmpIp, TmpPort
      Tmp1 = InStr(Tmp, Chr(40)) + 1
      Tmp2 = InStrRev(Tmp, Chr(41))
      Tmp3 = Mid(Tmp, Tmp1, Tmp2 - Tmp1)
      Tmp4 = Split(Tmp3, ",")
      TmpIp = Tmp4(0) & "." & Tmp4(1) & "." & Tmp4(2) & "." & Tmp4(3)
      TmpPort = Tmp4(4) * 256 + Tmp4(5)
      Tmp = ""
End If

If FileSize < FileLen(DFile) Then
   '  If MsgBox("文件已存在，是否续传？", vbYesNo, "提示：") <> vbYes Then
   '    Kill DFile
   '  Else
         wscControl.SendData "REST " & FileSize & vbCrLf
         Debug.Print "REST " & FileSize & vbCrLf
         If ChkTime Or Left(Tmp, 3) <> 350 Then
            MsgBox "服务器不支持续传，将重新下载文件！" & vbCrLf & Tmp
            Kill DFile
         End If
         Debug.Print Tmp
         Tmp = ""
   '  End If
End If

'数据下载部分
If wscData Is Nothing Then
      Set wscData = Controls.Add("MSWinsock.Winsock", "wscData", Me)
      TimerData.Interval = 100
      TimerData.Enabled = True
End If
With wscData
      .RemoteHost = TmpIp
      .RemotePort = TmpPort
      .Connect
End With
wscControl.SendData "APPE " & FileT & vbCrLf
Debug.Print "APPE " & FileT & vbCrLf
If ChkTime Then
      ldFile = "连接数据超时！"
      Exit Function
End If
Debug.Print Tmp
If InStr(Tmp, "226 ") > 0 Then GoTo End1
Tmp = ""
Do While wscData.State = 7
      DoEvents
Loop
If ChkTime Then
      ldFile = "下载失败！"
      Exit Function
End If
Debug.Print Tmp
End1:
Tmp = ""
ldFile = "OK"
End Function

彭希仁 · 发表于 2009-10-21 16:03

在不使用断点上传的情况下,用FTP来实现远程群聊功能,实在让人无法忍受其速度.

lb_bn · 发表于 2009-10-21 16:05

占位等彭总大作。

laoyebin · 发表于 2009-10-21 16:09

这个太专业了，没见人这么用EXCEL的

FTP用FLASHFXP不更好？

彭希仁 · 发表于 2009-10-22 16:31

谁对Winsock上传文件比较熟啊?能不能出来帮我一把啊

彭希仁 · 发表于 2009-10-23 21:25

Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Info() As String, TimerCountA As Long

Private WithEvents wscControl As MSWinsockLib.Winsock
Private WithEvents wscData As MSWinsockLib.Winsock
Private Tmp As String, FileSize As String, DFile As String, ren
Dim SrcPath As String '源路径
Dim DstPath As String '目标路径
Dim IsReceived As Boolean '接收完毕为True

Private Sub TimerControl_Timer()
LabelControl.Caption = "控制连接状态：" & wscControl.State
End Sub

Private Sub TimerData_Timer()
LabelData.Caption = "数据连接状态：" & wscData.State
End Sub

Private Sub wscControl_DataArrival(ByVal bytesTotal As Long)
Dim i As String
wscControl.GetData Tmp
Text1.Text = Text1.Text & Tmp
End Sub

Private Sub wscData_DataArrival(ByVal bytesTotal As Long)
Dim byteData() As Byte
wscData.GetData byteData(), vbByte
Open DFile For Binary Lock Write As #1
ProgressBar.Value = FileLen(DFile)
If LOF(1) > 0 Then
      Seek #1, LOF(1) + 1
End If
Put #1, , byteData()
Close #1
ren:
End Sub

Private Sub wscData_Close()
wscData.Close
End Sub

Function ChkTime()
Dim i As Integer
i = 50
Do While i > 0
      If Tmp <> "" Then Exit Function
      Sleep (100)
      DoEvents
      i = i - 1
Loop
wscControl.Close
ChkTime = True
End Function

Function ConnFtp(HostIp, HostPort, User, Pass)

If wscControl Is Nothing Then
      Set wscControl = Controls.Add("MSWinsock.Winsock", "wscControl", Me)
      TimerControl.Interval = 100
      TimerControl.Enabled = True
End If

If wscControl.RemoteHost <> "" Then '已连接了就不用再连了
      ConnFtp = "OK"
      Exit Function
End If
With wscControl
      .RemoteHost = HostIp
      .RemotePort = HostPort
      .Connect
End With
If ChkTime Then
      ConnFtp = "连接超时，是否重试？"
      Exit Function
End If
Text1.Text = Text1.Text & Tmp
Select Case Left(Tmp, 3)
Case "220"
      Tmp = ""
      wscControl.SendData "USER " & User & vbCrLf
      Text1.Text = Text1.Text & "USER " & User & vbCrLf
      If ChkTime Then
         ConnFtp = "连接错误USER，是否重试？" & vbCrLf & Tmp
         Exit Function
      End If
      Text1.Text = Text1.Text & Tmp
      Select Case Left(Tmp, 3)
      Case "331"
         Tmp = ""
         wscControl.SendData "PASS " & Pass & vbCrLf
         Text1.Text = Text1.Text & "PASS " & Pass & vbCrLf
PassCS:
         If ChkTime Then
            ConnFtp = "连接错误PASS，是否重试？" & vbCrLf & Tmp
            Exit Function
         End If
         Text1.Text = Text1.Text & Tmp
         Select Case Left(Tmp, 3)
         Case "230"
            If InStr(Tmp, "230 ") > 0 Then
                  ConnFtp = "OK"
                  Tmp = ""
                  Exit Function
            End If
            Tmp = ""
            GoTo PassCS
         Case "530"
            ConnFtp = "登陆失败，用户名或密码错误，是否重试？" & vbCrLf & Tmp
            wscControl.Close
            Tmp = ""
            Exit Function
         End Select
      End Select
End Select
ConnFtp = "错误"
End Function

Function DownFile(File As String, TransferMode As String)
Dim FileHaveLen As String
If wscControl.State <> 7 Then
      MsgBox "请确认当前连接状态！1"
      Exit Function
End If
wscControl.SendData "NOOP " & vbCrLf
Text1.Text = Text1.Text & "NOOP " & vbCrLf
If ChkTime Or Left(Tmp, 3) <> 200 Then
      Text1.Text = Text1.Text & Tmp
      DownFile = "请确认当前连接状态！2" & vbCrLf & Tmp
      Tmp = ""
      Exit Function
Else
      Text1.Text = Text1.Text & Tmp
      Tmp = ""
End If
If TransferMode = "I" Or TransferMode = "A" Then
      wscControl.SendData "TYPE " & TransferMode & vbCrLf
      Text1.Text = Text1.Text & "TYPE " & TransferMode & vbCrLf
      If ChkTime Or Left(Tmp, 3) <> 200 Then
         Text1.Text = Text1.Text & Tmp
         DownFile = "改变状态失败！" & vbCrLf & Tmp
         Tmp = ""
         Exit Function
      Else
         Text1.Text = Text1.Text & Tmp
         Tmp = ""
      End If
End If
File = Replace(File, "\", "/")
Dim PathT As String
PathT = Left(File, InStrRev(File, "/"))
If PathT <> "" Then
      wscControl.SendData "CWD " & PathT & vbCrLf
      Text1.Text = Text1.Text & "CWD " & PathT & vbCrLf
      If ChkTime Or Left(Tmp, 3) <> 250 Then
         Text1.Text = Text1.Text & Tmp
         DownFile = "改变目录失败！" & vbCrLf & Tmp
         Tmp = ""
         Exit Function
      Else
         Text1.Text = Text1.Text & Tmp
         Tmp = ""
      End If
End If
Dim FileT As String
FileT = Right(File, Len(File) - InStrRev(File, "/"))
wscControl.SendData "SIZE " & FileT & vbCrLf
Text1.Text = Text1.Text & "SIZE " & FileT & vbCrLf
If ChkTime Or Left(Tmp, 3) <> 213 Then
      Text1.Text = Text1.Text & Tmp
      DownFile = "取得文件大小失败！" & vbCrLf & Tmp
      Tmp = ""
      Exit Function
Else
      Text1.Text = Text1.Text & Tmp
      FileSize = Right(Tmp, Len(Tmp) - 4)
      ProgressBar.Max = FileSize
      Me.Label1.Caption = "文件大小：" + CStr(FormatNumber(FileSize / 1024, 2)) + "KB..."
      Tmp = ""
End If
wscControl.SendData "PASV" & vbCrLf
Text1.Text = Text1.Text & "PASV" & vbCrLf
If ChkTime Or Left(Tmp, 3) <> 227 Then
      Text1.Text = Text1.Text & Tmp
      DownFile = "获取Pasv端口失败！" & vbCrLf & Tmp
      Tmp = ""
      Exit Function
Else
      Text1.Text = Text1.Text & Tmp
      Dim Tmp1, Tmp2, Tmp3, Tmp4, TmpIp, TmpPort
      Tmp1 = InStr(Tmp, Chr(40)) + 1
      Tmp2 = InStrRev(Tmp, Chr(41))
      Tmp3 = Mid(Tmp, Tmp1, Tmp2 - Tmp1)
      Tmp4 = Split(Tmp3, ",")
      TmpIp = Tmp4(0) & "." & Tmp4(1) & "." & Tmp4(2) & "." & Tmp4(3)
      TmpPort = Tmp4(4) * 256 + Tmp4(5)
      Tmp = ""
End If
Open DFile For Binary Lock Write As #1
If LOF(1) > 0 Then
      FileHaveLen = FileLen(DFile)
      Close #1
      '  If MsgBox("文件已存在，是否续传？", vbYesNo, "提示：") <> vbYes Then
      '    Kill DFile
      '  Else
      wscControl.SendData "REST " & FileHaveLen & vbCrLf
      Text1.Text = Text1.Text & "REST " & FileHaveLen & vbCrLf
      If ChkTime Or Left(Tmp, 3) <> 350 Then
         MsgBox "服务器不支持续传，将重新下载文件！" & vbCrLf & Tmp
         Kill DFile
      End If
      Text1.Text = Text1.Text & Tmp
      Tmp = ""
      '  End If
Else
      Close #1
End If
'数据下载部分
If wscData Is Nothing Then
      Set wscData = Controls.Add("MSWinsock.Winsock", "wscData", Me)
      TimerData.Interval = 100
      TimerData.Enabled = True
End If
With wscData
      .RemoteHost = TmpIp
      .RemotePort = TmpPort
      .Connect
End With
wscControl.SendData "RETR " & FileT & vbCrLf
Text1.Text = Text1.Text & "RETR " & FileT & vbCrLf
If ChkTime Then
      DownFile = "连接数据超时！"
      Exit Function
End If
Text1.Text = Text1.Text & Tmp
If InStr(Tmp, "226 ") > 0 Then GoTo End1
Tmp = ""
Do While wscData.State = 7
      DoEvents
Loop
If ChkTime Then
      DownFile = "下载失败！"
      Exit Function
End If
Text1.Text = Text1.Text & Tmp
End1:
Tmp = ""
DownFile = "OK"
End Function

Private Sub Command1_Click()
Dim n
DFile = "E:\2009-10-19.txt"
a1:
n = ConnFtp("0.0.41.122", "21", "00", "242342")
If n <> "OK" Then
      If MsgBox(n, vbYesNo, "提示：") = vbYes Then GoTo a1
      Exit Sub
End If
ren = 1
'n = DownFile("server/server/2009-10-19.txt", "I")
' Timer1.Enabled = True
n = ldFile("server/server/2009-10-19.txt", "I")

If n <> "OK" Then
      MsgBox n, , "提示："
      Exit Sub
End If
MsgBox "下载成功！"
End Sub

Private Sub Timer1_Timer()
Dim n
n = DownFile("资产管理系统.exe", "I")
End Sub

Function ldFile(File As String, TransferMode As String)
Dim FileHaveLen As String, iBlockCount As Long

Dim BufFile() As Byte '文件内容
Dim LnFile As Long    '长度
Dim nLoop As Long    '文件内容分的块数
Dim nRemain As Long    '最后剩下的大小
Dim Cn As Long
Dim xc As Long
''''''''''''''''''''

If wscControl.State <> 7 Then
      MsgBox "请确认当前连接状态！1"
      Exit Function
End If
wscControl.SendData "NOOP " & vbCrLf
Text1.Text = Text1.Text & "NOOP " & vbCrLf
If ChkTime Or Left(Tmp, 3) <> 200 Then
      Text1.Text = Text1.Text & Tmp
      ldFile = "请确认当前连接状态！2" & vbCrLf & Tmp
      Tmp = ""
      Exit Function
Else
      Text1.Text = Text1.Text & Tmp
      Tmp = ""
End If
If TransferMode = "I" Or TransferMode = "A" Then
      wscControl.SendData "TYPE " & TransferMode & vbCrLf
      Text1.Text = Text1.Text & "TYPE " & TransferMode & vbCrLf
      If ChkTime Or Left(Tmp, 3) <> 200 Then
         Text1.Text = Text1.Text & Tmp
         ldFile = "改变状态失败！" & vbCrLf & Tmp
         Tmp = ""
         Exit Function
      Else
         Text1.Text = Text1.Text & Tmp
         Tmp = ""
      End If
End If
File = Replace(File, "\", "/")
Dim PathT As String
PathT = Left(File, InStrRev(File, "/"))
If PathT <> "" Then
      wscControl.SendData "CWD " & PathT & vbCrLf
      Text1.Text = Text1.Text & "CWD " & PathT & vbCrLf
      If ChkTime Or Left(Tmp, 3) <> 250 Then
         Text1.Text = Text1.Text & Tmp
         ldFile = "改变目录失败！" & vbCrLf & Tmp
         Tmp = ""
         Exit Function
      Else
         Text1.Text = Text1.Text & Tmp
         Tmp = ""
      End If
End If
Dim FileT As String
FileT = Right(File, Len(File) - InStrRev(File, "/"))
wscControl.SendData "SIZE " & FileT & vbCrLf
Text1.Text = Text1.Text & "SIZE " & FileT & vbCrLf
If ChkTime Or Left(Tmp, 3) <> 213 Then
      Text1.Text = Text1.Text & Tmp
      FileSize = 0
      Tmp = ""
Else
      Text1.Text = Text1.Text & Tmp
      FileSize = Right(Tmp, Len(Tmp) - 4)

      Me.Label1.Caption = "文件大小：" + CStr(FormatNumber(FileSize / 1024, 2)) + "KB..."
      Tmp = ""
End If
wscControl.SendData "PASV" & vbCrLf
Text1.Text = Text1.Text & "PASV" & vbCrLf
If ChkTime Or Left(Tmp, 3) <> 227 Then
      Text1.Text = Text1.Text & Tmp
      ldFile = "获取Pasv端口失败！" & vbCrLf & Tmp
      Tmp = ""
      Exit Function
Else
      Text1.Text = Text1.Text & Tmp
      Dim Tmp1, Tmp2, Tmp3, Tmp4, TmpIp, TmpPort
      Tmp1 = InStr(Tmp, Chr(40)) + 1
      Tmp2 = InStrRev(Tmp, Chr(41))
      Tmp3 = Mid(Tmp, Tmp1, Tmp2 - Tmp1)
      Tmp4 = Split(Tmp3, ",")
      TmpIp = Tmp4(0) & "." & Tmp4(1) & "." & Tmp4(2) & "." & Tmp4(3)
      TmpPort = Tmp4(4) * 256 + Tmp4(5)
      Tmp = ""
End If

Open DFile For Binary Lock Write As #1
If LOF(1) > 0 And FileSize > 0 And LOF(1) > FileSize Then
      Close #1
      '  If MsgBox("文件已存在，是否续传？", vbYesNo, "提示：") <> vbYes Then
      '    Kill DFile
      '  Else
      wscControl.SendData "REST " & FileSize & vbCrLf
      Text1.Text = Text1.Text & "REST " & FileSize & vbCrLf
      xc = 1
      If ChkTime Or Left(Tmp, 3) <> 350 Then
         xc = 0 '不支持续传
      End If
      Text1.Text = Text1.Text & Tmp
      Tmp = ""
      '  End If
Else
      Close #1
End If

'数据下载部分
If wscData Is Nothing Then
      Set wscData = Controls.Add("MSWinsock.Winsock", "wscData", Me)
      TimerData.Interval = 100
      TimerData.Enabled = True
End If
With wscData
      .RemoteHost = TmpIp
      .RemotePort = TmpPort
      .Connect
End With

wscControl.SendData "STOR " & FileT & vbCrLf
Text1.Text = Text1.Text & "STOR " & FileT & vbCrLf

While Mid(Tmp, 1, 3) <> "150"
      DoEvents
Wend

   '数据下载部分
If wscData Is Nothing Then
      Set wscData = Controls.Add("MSWinsock.Winsock", "wscData", Me)
      TimerData.Interval = 100
      TimerData.Enabled = True
End If
With wscData
      .RemoteHost = TmpIp
      .RemotePort = TmpPort
      .Connect
End With

wscControl.SendData "STOR " & FileT & vbCrLf
Text1.Text = Text1.Text & "STOR " & FileT & vbCrLf

While Mid(Tmp, 1, 3) <> "150"
      DoEvents
Wend

'数据下载部分

'''''''''''''''''''''''''''''''''
SrcPath = DFile
If xc = 0 Then '设置进度条
      ProgressBar.Max = FileLen(DFile)
      ProgressBar.Value = 0
Else
      If FileLen(DFile) - FileSize < 1 Then Exit Function
      ProgressBar.Max = FileLen(DFile) - FileSize
      ProgressBar.Value = 0
End If

LnFile = ProgressBar.Max '文件长度
Open SrcPath For Binary As #1

If xc = 1 Then '设置进度条
      Seek #1, FileSize + 1
End If

For Cn = 1 To Fix(LnFile \ 8192)
      ReDim BufFile(1 To 8192) As Byte
      Get #1, , BufFile '获取文件内容
      '发送文件块内容
      wscData.SendData BufFile
      ProgressBar.Value = ProgressBar.Value + 8192
      IsReceived = False
      While IsReceived = False
         DoEvents
      Wend
Next

ReDim BufFile(1 To LnFile Mod 8192) As Byte
Get #1, , BufFile
wscData.SendData BufFile
ProgressBar.Value = ProgressBar.Max
IsReceived = False
While IsReceived = False
      DoEvents
Wend

'发送结束符号
wscControl.SendData "RETR " & FileT & vbCrLf
Text1.Text = Text1.Text & "RETR " & FileT & vbCrLf
'关闭文件
Close #1
Exit Function
End1:
Tmp = ""
ldFile = "OK"
Exit Function
GLocal:
MsgBox Err.Description
End Function

Private Sub wscData_SendComplete()
IsReceived = True
End Sub

[ 本帖最后由彭希仁于 2009-10-23 21:44 编辑 ]

nmcfbgttyl · 发表于 2020-1-18 15:00

彭希仁发表于 2009-10-23 21:25
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private In ...

彭老师，问题解决了吗？我遇到几乎和您一样的问题了，您上面的示例下载后缺少窗体文件，能分享您的作品吗？谢谢！

		自动登录	找回密码
密码			免费注册

[求助] 已实现FTP断点下载,求FTP断点上传代码(自已改的不能上传)