vb实现http协议
2007-07-01 20:45
'''作者：何道德
'''网名:hedaode
'''网站:www.hedaode.cn/www.wo789.com
'''2007/07/1
'保持属性值的局部变量
Private mvarstrUrl As String '局部复制
'保持属性值的局部变量
Private mvarstrFileFiled As String '局部复制
Private mvarstrTextFiled As String '局部复制
Public Host As String
'保持属性值的局部变量
Public Function RequestData() As Byte()
Dim i As Long
Dim PostByte() As Byte '要发送的数据包
Dim headByte() As Byte '请求头域
Dim LastByte() As Byte 'multiPart/form数据包结束标记
Dim strFileByte() As Byte '文件属性
Dim fileByte() As Byte '文件体
Dim newLine() As Byte '回车换行符号
Dim strHeader As String
Dim strPostData As String
Dim boundary As String
Dim path As String
Dim textArr,fileArr,tArr,fArr

Host = Replace(strUrl,"http://","")
i = InStr(Host,"/")
If i = 0 Then
path = "/"
Else
path = Mid(Host,i,Len(Host)) '获取资源路径
End If
Host = Replace(Host,path,"") '获取主机名
boundary = "--hedaode--"
StrToByte vbCrLf,newLine

If strTextFiled = "" And strFileFiled = "" Then
'不发送任何数据
strHeader = "GET " + path + " HTTP/1.1" + vbCrLf
strHeader = strHeader + "Accept: */*" + vbCrLf
strHeader = strHeader + "Accept-Language: zh-cn" + vbCrLf
strHeader = strHeader + "User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.2; SV1; .NET CLR 1.1.4322; .NET CLR 2.0.50727)" + vbCrLf
strHeader = strHeader + "Host: " + Host + vbCrLf
If Cookies <> "" Then
strHeader = strHeader + "Cookie: " + Cookies + vbCrLf
End If
strHeader = strHeader + vbCrLf

StrToByte strHeader,PostByte
RequestData = PostByte
ElseIf strTextFiled <> "" And strFileFiled = "" Then
'只发送文本数据
strHeader = "POST " + path + " HTTP/1.1" + vbCrLf
strHeader = strHeader + "Accept: */*" + vbCrLf
strHeader = strHeader + "User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.2; SV1; .NET CLR 1.1.4322; .NET CLR 2.0.50727)" + vbCrLf
If Cookies <> "" Then
strHeader = strHeader + "Cookie: " + Cookies + vbCrLf
End If
strHeader = strHeader + "Host: " + Host + vbCrLf
strHeader = strHeader + "Content-Type: application/x-www-form-urlencoded" + vbCrLf
strHeader = strHeader + "Content-Length: " & strLen(strTextFiled) & vbCrLf & vbCrLf
strHeader = strHeader + strTextFiled

StrToByte strHeader,PostByte
RequestData = PostByte
ElseIf strTextFiled = "" And strFileFiled <> "" Then
'只发送文件数据
fileArr = Split(strFileFiled,"&")

For i = 0 To UBound(fileArr)
fArr = Split(fileArr(i),"=")

strPostData = "--" + boundary + vbCrLf
strPostData = strPostData + "Content-Disposition: form-data; name=""" + fArr(0) + """; filename=""" + fArr(1) + """" + vbCrLf
strPostData = strPostData + "Content-Type: image/jpeg" + vbCrLf + vbCrLf
StrToByte strPostData,PostByte

Open fArr(1) For Binary As #1
ReDim fileByte(LOF(1) - 1)
Get #1,fileByte
Close #1

PostByte = UniteArr(PostByte,fileByte)
PostByte = UniteArr(PostByte,newLine)
Next

StrToByte "--" + boundary + "--" + vbCrLf,LastByte()
PostByte = UniteArr(PostByte,LastByte)

strHeader = "POST " + path + " HTTP/1.1" + vbCrLf
strHeader = strHeader + "Accept: */*" + vbCrLf
strHeader = strHeader + "User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.2; SV1; .NET CLR 1.1.4322; .NET CLR 2.0.50727)" + vbCrLf
strHeader = strHeader + "Content-Type: multipart/form-data; boundary=" + boundary + vbCrLf
strHeader = strHeader + "Content-Length: " & (UBound(PostByte) + 1) & vbCrLf
strHeader = strHeader + "Host: " + Host + vbCrLf

If Cookies <> "" Then
strHeader = strHeader + "Cookie: " + Cookies + vbCrLf
End If
strHeader = strHeader + vbCrLf

StrToByte strHeader,headByte
PostByte = UniteArr(headByte,PostByte)

RequestData = PostByte
Else
'发送文本和文件数据
textArr = Split(strTextFiled,"&")
fileArr = Split(strFileFiled,"&")

For i = 0 To UBound(textArr)
tArr = Split(textArr(i),"=")
strPostData = strPostData + "--" + boundary + vbCrLf
strPostData = strPostData + "Content-Disposition: form-data; name=""" + tArr(0) + """" + vbCrLf + vbCrLf + tArr(1) + vbCrLf
Next

StrToByte strPostData,PostByte()

For i = 0 To UBound(fileArr)


fArr = Split(fileArr(i),"=")
strPostData = "--" + boundary + vbCrLf
strPostData = strPostData + "Content-Disposition: form-data; name=""" + fArr(0) + """; filename=""" + fArr(1) + """" + vbCrLf
strPostData = strPostData + "Content-Type: image/jpeg" + vbCrLf + vbCrLf
StrToByte strPostData,strFileByte

Open fArr(1) For Binary As #1
ReDim fileByte(LOF(1) - 1)
Get #1,strFileByte)
PostByte = UniteArr(PostByte,PostByte)

RequestData = PostByte
End If
End Function

Public Property Let strTextFiled(ByVal vData As String)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.strTextFiled = 5
mvarstrTextFiled = vData
End Property

Public Property Get strTextFiled() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.strTextFiled
strTextFiled = mvarstrTextFiled
End Property

Public Property Let strFileFiled(ByVal vData As String)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.strFileFiled = 5
mvarstrFileFiled = vData
End Property

Public Property Get strFileFiled() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.strFileFiled
strFileFiled = mvarstrFileFiled
End Property

Public Property Let strUrl(ByVal vData As String)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.strUrl = 5
mvarstrUrl = vData
End Property

Public Property Get strUrl() As String'检索属性值时使用，位于赋值语句的右边。'Syntax: Debug.Print X.strUrl strUrl = mvarstrUrlEnd Property