1,502
社区成员
发帖
与我相关
我的任务
分享
Private Sub Command1_Click()
Winsock1.RemoteHost = "www.baidu.com" '设置连接的网址
Winsock1.RemotePort = 80 '设置要连接的远程端口号
Winsock1.Connect '返回与远程计算机的连接。
End Sub
Private Sub Winsock1_Connect()
Dim strCommand As String
Dim strWebPage As String
'当一个 Connect 操作完成时发生
'On Error Resume Next
strWebPage = "http://www.baidu.com/index.html" '要下载的文件
strCommand = "GET " + strWebPage + " HTTP/1.0" + vbCrLf ''GET 为FTP命令 取得文件
strCommand = strCommand + "Accept: */*" + vbCrLf '这句可以不要
strCommand = strCommand + "Accept: text/html" + vbCrLf '这句可以不要
strCommand = strCommand + vbCrLf '记住一定要加上vbCrLf
'Debug.Print strCommand '注:你可以用Debug.Print strCommand 来查看一下格式
Winsock1.SendData strCommand '给远程计算机发送数据
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long) '取得数据时产生该事件
On Error Resume Next '在错误处理程序结束后,恢复原有的运行
Dim webData As String
Winsock1.GetData webData, vbString '检取当前的数据块
Text1.Text = Text4.Text + webData
End Sub
Private Sub WinSockCconnect()
Dim i As Integer
i = InStr(8, FileUrl, "/")
FileHost = Mid(FileUrl, 8, i - 8)
Text5.Text = FileHost
Winsock1.RemoteHost = FileHost '设置连接的网址
Winsock1.RemotePort = 80 '设置要连接的远程端口号
Winsock1.Connect '返回与远程计算机的连接。
End Sub
Private Sub Winsock1_Connect()
Dim strCommand As String
'当一个 Connect 操作完成时发生
On Error Resume Next
DisEnableControl '相关控件失效
strCommand = "GET " + FileUrl + " HTTP/1.0" + vbCrLf ''GET 为FTP命令 取得文件
strCommand = strCommand + "Accept: */*" + 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 '记住一定要加上vbCrLf
'Debug.Print strCommand '注:你可以用Debug.Print strCommand 来查看一下格式
Winsock1.SendData strCommand '给远程计算机发送数据
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long) '取得数据时产生该事件
'On Error Resume Next '在错误处理程序结束后,恢复原有的运行
'Dim webData As String
'Winsock1.GetData webData, vbString '检取当前的数据块
'Text4.Text = Text4.Text + webData
Dim HeaderReceived As Boolean '定义header是否接收完成
Dim strData As Variant '定义接收的字符串
Dim intBreakePosition As Integer '定义header结束的位置
Dim strHttpResponse As Variant '定义下载的内容
Dim vHeaders As Variant '定义header数组
Dim vHeader As Variant '定义header中的每一行
Dim ContentLength As Long
Dim FileTotalLenght As Long '文件正文总长度
Dim SaveFileName As String '保存文件名,如 a.rar
Dim SaveFileLoad As String '保存文件路径 如 c:\data\a.rar
Dim DownloadedBytes As Integer '已经接收文件正文的长度
Dim mintFile As Long '打开文件
Dim databyte()
ReDim databyte(bytesTotal)
On Error Resume Next
Winsock1.GetData strData, vbArray + vbByte, bytesTotal
strHttpResponse = strHttpResponse & strData '已经下载的数据,包含header
DownloadedBytes = DownloadedBytes + bytesTotal '已经下载的数据量 包含 header
Text5.Text = strHttpResponse
If Not HeaderReceived Then '如果头文件没有结束
intBreakePosition = InStr(1, strHttpResponse, vbCrLf & vbCrLf) '找头文件结束点
If intBreakePosition Then '如果找到了头文件结束点
HeaderReceived = True '头文件结束
DownloadedBytes = DownloadedBytes - intBreakePosition - 3 '正式文件长度
vHeaders = Split(Left(strHttpResponse, intBreakePosition - 1), vbCrLf) '将头文件每行分割成一个数组
'接下来分析是200 302 404
If InStr(1, vHeaders(0), "404") Then
Winsock1.Close
MsgBox "文件地址错误!", vbInformation
Exit Sub
ElseIf InStr(1, vHeaders(0), "302") Then
For Each vHeader In vHeaders
If InStr(1, vHeader, "Location:") Then
FileUrl = Mid(vHeader, InStr(1, vHeader, " ") + 1)
Text5.Text = FileUrl
Exit For
End If
Next
Winsock1.Close
Text5.Text = FileUrl
WinSockCconnect '重定向后再次链接
ElseIf InStr(1, vHeaders(0), "200") Then
For Each vHeader In vHeaders
If InStr(1, vHeader, "Content-Length") Then
ContentLength = CLng(Mid(vHeader, InStr(1, vHeader, " ") + 1))
FileTotalLenght = CInt(ContentLength / 1024) & " KB" '获取文件长度
ElseIf InStr(1, vHeader, "filename=") Then
SaveFileName = Mid(vHeader, InStr(1, vHeader, "filename=") + 9) '获取文件名
End If
Next
If SaveFileName <> "" Then
SaveFileLoad = VB.App.Path & "\data\" & SaveFileName
Else
SaveFileLoad = VB.App.Path & "\data\" & "error.txt"
End If
strData = Mid(strData, intBreakePosition + 4)
Open SaveFileLoad For Binary Access Write As #mintFile '打开文件
End If
End If
'Else
'If ContentLength > 0 Then
'lvItem(Index).SubItems(2) = CInt(DownloadedBytes / (ContentLength / 100)) & "%"
'lvItem(Index).SubItems(4) = CInt(DownloadedBytes / 1024) & " KB"
'Else
'lvItem(Index).SubItems(4) = CInt(DownloadedBytes / 1024) & " KB"
'End If
End If
Put #mintFile, , strData '写入要保存的文件中
If DownloadedBytes >= ContentLength Then
Close #mintFile
Winsock1.Close
MsgBox "下载完成!", vbInformation
EnableControl
End If
End Sub