|
楼主 |
发表于 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 编辑 ] |
|