事情是这样的:
我需要一个代码,支持网站上下载附件,比如http://aaa.com/attach.php?id=9999这种非断点续传和http://aaa.com/a.rar这种可断点续传的。使用单线程,winsock组件。按道理说,这个很简单的,但现在我遇到了麻烦。麻烦在于:Winsock1_DataArrival 这个事件是在接收服务器信息时运行,但我使用httpanalyer监控,发现服务器已经不向软件发送数据了,但这个Winsock1_DataArrival 事件还在运行。有时候能多运行6-10次,最多时能运行37次。上代码
Dim ip As Integer '这个是计数器,不是记录IP的'---------------------------------------------------------
'winsocks相关
Dim HeaderReceived As Boolean '判断是否得到header
Dim SaveFileCompleted As Boolean '判断文章是否下载完毕
Dim oTotalLenght As Long '总长度
Dim oAlreadyLenght As Long '已经下载的长度,去掉header的长度
Dim oRemainingLenght As Long '剩余的长度
Dim oSaveFileLoad As String
Dim oSaveFileName As String
'---------------------------------------------------------Private Sub DownLoadFromWinSock()
Dim GetUrl As String
'初始化之前的数据
HeaderReceived = False
SaveFileCompleted = True
oTotalLenght = 0
oSaveFileLoad = ""
oSaveFileName = ""
FileUrl = GetFullUrl(FileUrl) '注意:这里的FILEURL是下载链接
GetUrl = GetUrlClearHttp(FileUrl)
' Text5.Text = FileUrl
If InStr(1, GetUrl, "/") Then '接收文件的文件名
FileString = Mid(GetUrl, InStr(1, GetUrl, "/"))
FileHost = Mid(GetUrl, 1, InStr(1, GetUrl, "/") - 1)
Else
FileString = "/"
FileHost = GetUrl
End If
Winsock1.RemoteHost = FileHost '设置连接的网址
Winsock1.RemotePort = 80 '设置要连接的远程端口号
Winsock1.Connect '返回与远程计算机的连接。
End SubPrivate Sub Winsock1_Connect()
Dim strCommand As String
'当一个 Connect 操作完成时发生
'On Error Resume Next
DisEnableControl '相关控件失效
strCommand = "GET " + FileString + " HTTP/1.1" + vbCrLf 'GET 为FTP命令 取得文件
strCommand = strCommand + "Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/x-shockwave-flash, application/vnd.ms-excel, application/vnd.ms-powerpoint, application/msword, */*" + vbCrLf
strCommand = strCommand + "Referer: " + RefererUrl + vbCrLf
strCommand = strCommand + "Accept-Language: zh-cn" + vbCrLf
strCommand = strCommand + "Accept-Encoding: gzip, deflate" + vbCrLf
strCommand = strCommand + "User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 2.0.50727)" + vbCrLf
strCommand = strCommand + "Host: " + FileHost + vbCrLf
strCommand = strCommand + "Connection: Keep-Alive" + vbCrLf
strCommand = strCommand + vbCrLf
Text4.Text = strCommand
Winsock1.SendData strCommand '给远程计算机发送数据End SubPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long) '取得数据时产生该事件
On Error Resume Next
DoEvents
Sleep 200
DoEventsip = ip + 1 '奇怪的就是这里,在已经弹出“下载完成”的情况下,这里按道理应该就结束了,但他还要继续循环
Text5.Text = Text5.Text & " " & ip'所有变量以o开头
Dim oData() As Byte '接收的二进制数组
Dim oHtml As String '接收的全部内容
Dim oHeader As String 'header部分
Dim oHeadLines() As String 'header部分分割为数组
Dim oHeadLine As Variant '数组的每一段
Dim oBody As String '正文部分
Dim oPos As Long '断点位置
Dim i As Long '用于循环
Dim fnum As Integer
ReDim oData(bytesTotal)Winsock1.GetData oData, vbArray + vbByte, bytesTotal
oAlreadyLenght = oAlreadyLenght + bytesTotalIf Not HeaderReceived Then '如果头文件没有找到
oHtml = oHtml & StrConv(oData, vbUnicode) 'ohtml继续接收数据
oPos = InStr(1, oHtml, vbCrLf & vbCrLf) '字符串状态下的断点位置
If oPos Then
HeaderReceived = True '已经获得了头文件
oHeader = Left(oHtml, oPos - 1)
oHeadLines = Split(oHeader, vbCrLf) '分割header
'以下检查header中从服务器返回状态
If InStr(1, oHeadLines(0), "40") Then '40x错误
Winsock1.Close
MsgBox "文件不存在或权限不足!", vbInformation
Exit Sub
ElseIf InStr(1, oHeadLines(0), "302") Then '302跳转
For Each oHeadLine In oHeadLines
If InStr(1, oHeadLine, "Location:") Then
FileUrl = ComLoadUrl(Mid(oHeadLine, InStr(1, oHeadLine, " ") + 1), FileUrl)
'这里解决302时,相对链接转变为绝对链接的问题
Exit For
End If
Next
Winsock1.Close '关闭本次链接,等待重新建立连接
DownLoadFromWinSock '重定向后再次链接
Exit Sub
ElseIf InStr(1, oHeadLines(0), "200") Then '正确接收数据
SaveFileCompleted = False '文件是否接收完成
For Each oHeadLine In oHeadLines
If InStr(1, oHeadLine, "Content-LENGTH:") Then '接收文件的总长度
oTotalLenght = CLng(Mid(oHeadLine, InStr(1, oHeadLine, " ") + 1))
End If
If InStr(1, oHeadLine, "filename=") Then '接收文件的文件名
oSaveFileName = Mid(oHeadLine, InStr(1, oHeadLine, "filename=") + 9)
End If
Next
'如果不是附件下载的方式,则直接获取文件名
If oSaveFileName = "" Then
oSaveFileName = FileUrl
If InStr(1, oHeadLine, "?") Then '接收文件的文件名
oSaveFileName = Mid(FileUrl, 1, InStr(1, FileUrl, "?"))
End If
oSaveFileName = Mid(oSaveFileName, InStrRev(oSaveFileName, "/"))
End If
oSaveFileLoad = GetFileLoad(oSaveFileName)
oPos = 0 '初始化断点位置,从数组中取值,避免汉字造成的大小与真实值不符
For i = 0 To UBound(oData) - 3
If oData(i) = 13 And oData(i + 1) = 10 And oData(i + 2) = 13 And oData(i + 3) = 10 Then
oPos = i + 4
Exit For
End If
Next
If oPos = 0 And oData(0) = 13 And oData(1) = 10 Then
oPos = 2
End If
oAlreadyLenght = oAlreadyLenght - oPos ' 已经下载的长度
oRemainingLenght = oTotalLenght - oAlreadyLenght '剩余的下载长度
Else
Winsock1.Close
MsgBox "服务器错误", vbInformation
Exit Sub
End If
Else
oAlreadyLenght = 0
End If
End IfIf HeaderReceived And (Not SaveFileCompleted) Then 'HeaderReceived 接收文件头 SaveFileCompleted 下载文章完成
fnum = FreeFile
Open oSaveFileLoad For Binary Access Write As #fnum '打开文件
If LOF(fnum) > 0 Then
Seek #fnum, LOF(fnum) + 1
End If
If oPos > 0 Then
For i = oPos To UBound(oData)
Put #fnum, , oData(i) '写入要保存的文件中
Next
Else
Put #fnum, , oData()
End If
If oAlreadyLenght >= oTotalLenght Then
'按道理说,当下载完成后,关闭了winsock和关闭了文件,这里就应该直接跳出 sub 了,但我这里没有,所以不得不设置一个 savefilecompleted 阻止继续程序继续向文件写数据。
'而且,On Error Resume Next注释掉就会出现错误。
'我就想知道为什么?? SaveFileCompleted = True
Winsock1.Close
Close #fnum
MsgBox "下载完成!", vbInformation
EnableControl
End If
End IfReDim oData(1)
End Sub
我需要一个代码,支持网站上下载附件,比如http://aaa.com/attach.php?id=9999这种非断点续传和http://aaa.com/a.rar这种可断点续传的。使用单线程,winsock组件。按道理说,这个很简单的,但现在我遇到了麻烦。麻烦在于:Winsock1_DataArrival 这个事件是在接收服务器信息时运行,但我使用httpanalyer监控,发现服务器已经不向软件发送数据了,但这个Winsock1_DataArrival 事件还在运行。有时候能多运行6-10次,最多时能运行37次。上代码
Dim ip As Integer '这个是计数器,不是记录IP的'---------------------------------------------------------
'winsocks相关
Dim HeaderReceived As Boolean '判断是否得到header
Dim SaveFileCompleted As Boolean '判断文章是否下载完毕
Dim oTotalLenght As Long '总长度
Dim oAlreadyLenght As Long '已经下载的长度,去掉header的长度
Dim oRemainingLenght As Long '剩余的长度
Dim oSaveFileLoad As String
Dim oSaveFileName As String
'---------------------------------------------------------Private Sub DownLoadFromWinSock()
Dim GetUrl As String
'初始化之前的数据
HeaderReceived = False
SaveFileCompleted = True
oTotalLenght = 0
oSaveFileLoad = ""
oSaveFileName = ""
FileUrl = GetFullUrl(FileUrl) '注意:这里的FILEURL是下载链接
GetUrl = GetUrlClearHttp(FileUrl)
' Text5.Text = FileUrl
If InStr(1, GetUrl, "/") Then '接收文件的文件名
FileString = Mid(GetUrl, InStr(1, GetUrl, "/"))
FileHost = Mid(GetUrl, 1, InStr(1, GetUrl, "/") - 1)
Else
FileString = "/"
FileHost = GetUrl
End If
Winsock1.RemoteHost = FileHost '设置连接的网址
Winsock1.RemotePort = 80 '设置要连接的远程端口号
Winsock1.Connect '返回与远程计算机的连接。
End SubPrivate Sub Winsock1_Connect()
Dim strCommand As String
'当一个 Connect 操作完成时发生
'On Error Resume Next
DisEnableControl '相关控件失效
strCommand = "GET " + FileString + " HTTP/1.1" + vbCrLf 'GET 为FTP命令 取得文件
strCommand = strCommand + "Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/x-shockwave-flash, application/vnd.ms-excel, application/vnd.ms-powerpoint, application/msword, */*" + vbCrLf
strCommand = strCommand + "Referer: " + RefererUrl + vbCrLf
strCommand = strCommand + "Accept-Language: zh-cn" + vbCrLf
strCommand = strCommand + "Accept-Encoding: gzip, deflate" + vbCrLf
strCommand = strCommand + "User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; .NET CLR 2.0.50727)" + vbCrLf
strCommand = strCommand + "Host: " + FileHost + vbCrLf
strCommand = strCommand + "Connection: Keep-Alive" + vbCrLf
strCommand = strCommand + vbCrLf
Text4.Text = strCommand
Winsock1.SendData strCommand '给远程计算机发送数据End SubPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long) '取得数据时产生该事件
On Error Resume Next
DoEvents
Sleep 200
DoEventsip = ip + 1 '奇怪的就是这里,在已经弹出“下载完成”的情况下,这里按道理应该就结束了,但他还要继续循环
Text5.Text = Text5.Text & " " & ip'所有变量以o开头
Dim oData() As Byte '接收的二进制数组
Dim oHtml As String '接收的全部内容
Dim oHeader As String 'header部分
Dim oHeadLines() As String 'header部分分割为数组
Dim oHeadLine As Variant '数组的每一段
Dim oBody As String '正文部分
Dim oPos As Long '断点位置
Dim i As Long '用于循环
Dim fnum As Integer
ReDim oData(bytesTotal)Winsock1.GetData oData, vbArray + vbByte, bytesTotal
oAlreadyLenght = oAlreadyLenght + bytesTotalIf Not HeaderReceived Then '如果头文件没有找到
oHtml = oHtml & StrConv(oData, vbUnicode) 'ohtml继续接收数据
oPos = InStr(1, oHtml, vbCrLf & vbCrLf) '字符串状态下的断点位置
If oPos Then
HeaderReceived = True '已经获得了头文件
oHeader = Left(oHtml, oPos - 1)
oHeadLines = Split(oHeader, vbCrLf) '分割header
'以下检查header中从服务器返回状态
If InStr(1, oHeadLines(0), "40") Then '40x错误
Winsock1.Close
MsgBox "文件不存在或权限不足!", vbInformation
Exit Sub
ElseIf InStr(1, oHeadLines(0), "302") Then '302跳转
For Each oHeadLine In oHeadLines
If InStr(1, oHeadLine, "Location:") Then
FileUrl = ComLoadUrl(Mid(oHeadLine, InStr(1, oHeadLine, " ") + 1), FileUrl)
'这里解决302时,相对链接转变为绝对链接的问题
Exit For
End If
Next
Winsock1.Close '关闭本次链接,等待重新建立连接
DownLoadFromWinSock '重定向后再次链接
Exit Sub
ElseIf InStr(1, oHeadLines(0), "200") Then '正确接收数据
SaveFileCompleted = False '文件是否接收完成
For Each oHeadLine In oHeadLines
If InStr(1, oHeadLine, "Content-LENGTH:") Then '接收文件的总长度
oTotalLenght = CLng(Mid(oHeadLine, InStr(1, oHeadLine, " ") + 1))
End If
If InStr(1, oHeadLine, "filename=") Then '接收文件的文件名
oSaveFileName = Mid(oHeadLine, InStr(1, oHeadLine, "filename=") + 9)
End If
Next
'如果不是附件下载的方式,则直接获取文件名
If oSaveFileName = "" Then
oSaveFileName = FileUrl
If InStr(1, oHeadLine, "?") Then '接收文件的文件名
oSaveFileName = Mid(FileUrl, 1, InStr(1, FileUrl, "?"))
End If
oSaveFileName = Mid(oSaveFileName, InStrRev(oSaveFileName, "/"))
End If
oSaveFileLoad = GetFileLoad(oSaveFileName)
oPos = 0 '初始化断点位置,从数组中取值,避免汉字造成的大小与真实值不符
For i = 0 To UBound(oData) - 3
If oData(i) = 13 And oData(i + 1) = 10 And oData(i + 2) = 13 And oData(i + 3) = 10 Then
oPos = i + 4
Exit For
End If
Next
If oPos = 0 And oData(0) = 13 And oData(1) = 10 Then
oPos = 2
End If
oAlreadyLenght = oAlreadyLenght - oPos ' 已经下载的长度
oRemainingLenght = oTotalLenght - oAlreadyLenght '剩余的下载长度
Else
Winsock1.Close
MsgBox "服务器错误", vbInformation
Exit Sub
End If
Else
oAlreadyLenght = 0
End If
End IfIf HeaderReceived And (Not SaveFileCompleted) Then 'HeaderReceived 接收文件头 SaveFileCompleted 下载文章完成
fnum = FreeFile
Open oSaveFileLoad For Binary Access Write As #fnum '打开文件
If LOF(fnum) > 0 Then
Seek #fnum, LOF(fnum) + 1
End If
If oPos > 0 Then
For i = oPos To UBound(oData)
Put #fnum, , oData(i) '写入要保存的文件中
Next
Else
Put #fnum, , oData()
End If
If oAlreadyLenght >= oTotalLenght Then
'按道理说,当下载完成后,关闭了winsock和关闭了文件,这里就应该直接跳出 sub 了,但我这里没有,所以不得不设置一个 savefilecompleted 阻止继续程序继续向文件写数据。
'而且,On Error Resume Next注释掉就会出现错误。
'我就想知道为什么?? SaveFileCompleted = True
Winsock1.Close
Close #fnum
MsgBox "下载完成!", vbInformation
EnableControl
End If
End IfReDim oData(1)
End Sub
解决方案 »
- 散分,发布Crimm ImageShop BETA 1.0版本,欢迎大家试用。
- 一个OCX的开发思路的问题
- MDI窗口可不可以设置它为无边框的.?
- 简单问题,进来看看,谢谢了!!
- 一个初学者请教一个关于值的问题:
- API调用中如何使被调用的窗体等显示在屏幕中央?
- 求助高手 很早开发的一个项目 VB com+ 组件 客户端无法访问到server 端的dll (有代码 )
- 为何我做的测试ACTIVE控件的程序不能启动?
- 我为什么不能添加ActiveX控件中的Sheridan 3D Controls(三维)控件?
- 尽管有很多浮动按钮控件,可还是用一天时间自己写了一个,想要的可以下载,内有下载地址:)
- 关于tab跳动光标的问题?
- 求TX Text Control的控件文件(老版本的TX40LE.ocx)
这可麻烦了,因为经常要用这软件下载一些较大的文件。如果服务器发送的时候不是按先后顺序,那接收后怎么保存啊?头痛了。
连13M的迅雷都下载不回来,真是讨厌。
兄弟们写这个的时候都用了什么组件啊?