1
0
mirror of https://e.coding.net/circlecloud/VBFunctionBas.git synced 2024-10-31 22:38:50 +00:00
VBFunctionBas/HttpHelper.bas
502647092 026f9cf403 url为空则推出...
Signed-off-by: 502647092 <jtb1@163.com>
2015-11-11 12:44:32 +08:00

450 lines
18 KiB
QBasic
Raw Permalink Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

Attribute VB_Name = "HttpHelper"
'#######################################用户控件说明#########################################
'名称:XmlHttp控件
'功能:实现XmlHttp的网络处理功能。
'最后更新日期:2014年6月4日
'创建人:蒋天蓓
'单位:上海市定海水电工程安装有限公司
'#######################################用户控件说明#########################################
'****************************************************
'GET网页GetData (网址 As String, 数据类型 As DataEnum )
'****************************************************
'POST网页PostData (网址 As String, 数据类型 As DataEnum )
'****************************************************
'XmlHttp.Status 常见值
'Web服务器响应浏览器或其他客户程序的请求时其应答一般由以下几个部分组成一个状态行几个应答头一个空行内容文档。下面是一个最简单的应答
'
'  状态行包含HTTP版本、状态代码、与状态代码对应的简短说明信息。在大多数情况下除了Content-Type之外的所有应答头都是可选的。但Content-Type是必需的它描述的是后面文档的MIME类型。虽然大多数应答都包含一个文档但也有一些不包含例如对HEAD请求的应答永远不会附带文档。有许多状态代码实际上用来标识一次失败的请求这些应答也不包含文档或只包含一个简短的错误信息说明
'
'  当用户试图通过 HTTP 访问一台正在运行 Internet 信息服务 (IIS) 的服务器上的内容时IIS 返回一个表示该请求的状态的数字代码。状态代码可以指明具体请求是否已成功,还可以揭示请求失败的确切原因。
'
'1 xx -信息提示
'
'这些状态代码表示临时的响应。客户端在收到常规响应之前,应准备接收一个或多个 1xx 响应。
' · 100 - Continue 初始的请求已经接受客户应当继续发送请求的其余部分。HTTP 1.1新)
' · 101 - Switching Protocols 服务器将遵从客户的请求转换到另外一种协议HTTP 1.1新)
'
'2 xx -成功
'
'这类状态代码表明服务器成功地接受了客户端请求?
' · 200 - OK 一切正常对GET和POST请求的应答文档跟在后面。
' · 201 - Created 服务器已经创建了文档Location头给出了它的URL。
' · 202 - Accepted 已经接受请求,但处理尚未完成。
' · 203 - Non-Authoritative Information 文档已经正常地返回但一些应答头可能不正确因为使用的是文档的拷贝非权威性信息HTTP 1.1新)。
' · 204 - No Content 没有新文档浏览器应该继续显示原来的文档。如果用户定期地刷新页面而Servlet可以确定用户文档足够新这个状态代码是很有用的。
' · 205 - Reset Content 没有新的内容但浏览器应该重置它所显示的内容。用来强制浏览器清除表单输入内容HTTP 1.1新)。
' · 206 - Partial Content 客户发送了一个带有Range头的GET请求服务器完成了它HTTP 1.1新)。
'
'3 xx -重定向
'
'客户端浏览器必须采取更多操作来实现请求。例如,浏览器可能不得不请求服务器上的不同的页面,或通过代理服务器重复该请求。
' · 300 - Multiple Choices 客户请求的文档可以在多个位置找到这些位置已经在返回的文档内列出。如果服务器要提出优先选择则应该在Location应答头指明。
' · 301 - Moved Permanently 客户请求的文档在其他地方新的URL在Location头中给出浏览器应该自动地访问新的URL。
' · 302 - Found 类似于301但新的URL应该被视为临时性的替代而不是永久性的。注意在HTTP1.0中对应的状态信息是“Moved Temporatily”。出现该状态代码时浏览器能够自动访问新的URL因此它是一个很有用的状态代码。注意这个状态代码有时候可以和301替换使用。例如如果浏览器错误地请求 http://host/~user 缺少了后面的斜杠有的服务器返回301有的则返回302。严格地说我们只能假定只有当原来的请求是GET时浏览器才会自动重定向。请参见307。
' · 303 - See Other 类似于301/302不同之处在于如果原来的请求是POSTLocation头指定的重定向目标文档应该通过GET提取HTTP 1.1新)。
' · 304 - Not Modified 客户端有缓冲的文档并发出了一个条件性的请求一般是提供If-Modified-Since头表示客户只想比指定日期更新的文档。服务器告诉客户原来缓冲的文档还可以继续使用。
' · 305 - Use Proxy 客户请求的文档应该通过Location头所指明的代理服务器提取HTTP 1.1新)。
' · 307 - Temporary Redirect 和302Found相同。许多浏览器会错误地响应302应答进行重定向即使原来的请求是POST即使它实际上只能在POST请求的应答是303时才能重定向。由于这个原因HTTP 1.1新增了307以便更加清除地区分几个状态代码当出现303应答时浏览器可以跟随重定向的GET和POST请求如果是307应答则浏览器只能跟随对GET请求的重定向。HTTP 1.1新)
'
'4 xx -客户端错误
'
'发生错误,客户端似乎有问题。例如,客户端请求不存在的页面,客户端未提供有效的身份验证信息。
'
' · 400 - Bad Request 请求出现语法错误。
' · 401 - Unauthorized 访问被拒绝客户试图未经授权访问受密码保护的页面。应答中会包含一个WWW-Authenticate头浏览器据此显示用户名字/密码对话框然后在填写合适的Authorization头后再次发出请求。IIS 定义了许多不同的 401 错误,它们指明更为具体的错误原因。这些具体的错误代码在浏览器中显示,但不在 IIS 日志中显示:
' · 401.1 - 登录失败?
' · 401.2 - 服务器配置导致登录失败?
' · 401.3 - 由于 ACL 对资源的限制而未获得授权。
' · 401.4 - 筛选器授权失败?
' · 401.5 - ISAPI/CGI 应用程序授权失败。
' · 401.7 访问被 Web 服务器上的 URL 授权策略拒绝。这个错误代码为 IIS 6.0 所专用。
' · 403 - Forbidden 资源不可用。服务器理解客户的请求但拒绝处理它。通常由于服务器上文件或目录的权限设置导致。禁止访问IIS 定义了许多不同的 403 错误,它们指明更为具体的错误原因:
' · 403.1 - 执行访问被禁止?
' · 403.2 - 读访问被禁止?
' · 403.3 - 写访问被禁止?
' · 403.4 - 要求 SSL。
' · 403.5 - 要求 SSL 128。
' · 403.6 - IP 地址被拒绝。
' · 403.7 - 要求客户端证书?
' · 403.8 - 站点访问被拒绝?
' · 403.9 - 用户数过多?
' · 403.1 - 配置无效?
' · 403.11 - 密码更改?
' · 403.12 - 拒绝访问映射表?
' · 403.13 - 客户端证书被吊销?
' · 403.14 - 拒绝目录列表?
' · 403.15 - 超出客户端访问许可?
' · 403.16 - 客户端证书不受信任或无效?
' · 403.17 - 客户端证书已过期或尚未生效?
' · 403.18 - 在当前的应用程序池中不能执行所请求的 URL。这个错误代码为 IIS 6.0 所专用。
' · 403.19 - 不能为这个应用程序池中的客户端执行 CGI。这个错误代码为 IIS 6.0 所专用。
' · 403.20 - Passport 登录失败。这个错误代码为 IIS 6.0 所专用。
' · 404 - Not Found 无法找到指定位置的资源。这也是一个常用的应答。
' · 404.0 -(无) 没有找到文件或目录。
' · 404.1 - 无法在所请求的端口上访问 Web 站点。
' · 404.2 - Web 服务扩展锁定策略阻止本请求。
' · 404.3 - MIME 映射策略阻止本请求。
'
' · 405 - Method Not Allowed 请求方法GET、POST、HEAD、DELETE、PUT、TRACE等对指定的资源不适用用来访问本页面的 HTTP 谓词不被允许方法不被允许HTTP 1.1新)
' · 406 - Not Acceptable 指定的资源已经找到但它的MIME类型和客户在Accpet头中所指定的不兼容客户端浏览器不接受所请求页面的 MIME 类型HTTP 1.1新)。
' · 407 - Proxy Authentication Required 要求进行代理身份验证类似于401表示客户必须先经过代理服务器的授权。HTTP 1.1新)
' · 408 - Request Timeout 在服务器许可的等待时间内客户一直没有发出任何请求。客户可以在以后重复同一请求。HTTP 1.1新)
' · 409 - Conflict 通常和PUT请求有关。由于请求和资源的当前状态相冲突因此请求不能成功。HTTP 1.1新)
' · 410 - Gone 所请求的文档已经不再可用而且服务器不知道应该重定向到哪一个地址。它和404的不同在于返回407表示文档永久地离开了指定的位置而404表示由于未知的原因文档不可用。HTTP 1.1新)
' · 411 - Length Required 服务器不能处理请求除非客户发送一个Content-Length头。HTTP 1.1新)
' · 412 - Precondition Failed 请求头中指定的一些前提条件失败HTTP 1.1新)。
' · 413 Request Entity Too Large 目标文档的大小超过服务器当前愿意处理的大小。如果服务器认为自己能够稍后再处理该请求则应该提供一个Retry-After头HTTP 1.1新)。
' · 414 - Request URI Too Long URI太长HTTP 1.1新)。
' · 415 不支持的媒体类型。
' · 416 Requested Range Not Satisfiable 服务器不能满足客户在请求中指定的Range头。HTTP 1.1新)
' · 417 执行失败。
' · 423 锁定的错误。
'
'5 xx -服务器错误
'
'服务器由于遇到错误而不能完成该请求?
'
' · 500 - Internal Server Error 服务器遇到了意料不到的情况,不能完成客户的请求。
' · 500.12 - 应用程序正忙于在 Web 服务器上重新启动。
' · 500.13 - Web 服务器太忙。
' · 500.15 - 不允许直接请求 Global.asa。
' · 500.16 UNC 授权凭据不正确。这个错误代码为 IIS 6.0 所专用。
' · 500.18 URL 授权存储不能打开。这个错误代码为 IIS 6.0 所专用。
' · 500.100 - 内部 ASP 错误。
' · 501 - Not Implemented 服务器不支持实现请求所需要的功能页眉值指定了未实现的配置。例如客户发出了一个服务器不支持的PUT请求。
' · 502 - Bad Gateway 服务器作为网关或者代理时,为了完成请求访问下一个服务器,但该服务器返回了非法的应答。 亦说Web 服务器用作网关或代理服务器时收到了无效响应。
' · 502.1 - CGI 应用程序超时。
' · 502.2 - CGI 应用程序出错。
' · 503 - Service Unavailable 服务不可用服务器由于维护或者负载过重未能应答。例如Servlet可能在数据库连接池已满的情况下返回503。服务器返回503时可以提供一个Retry-After头。这个错误代码为 IIS 6.0 所专用。
' · 504 - Gateway Timeout 网关超时由作为代理或网关的服务器使用表示不能及时地从远程服务器获得应答。HTTP 1.1新) 。
'· 505 - HTTP Version Not Supported 服务器不支持请求中所指明的HTTP版本。HTTP 1.1新)。
Option Explicit
Public Enum DataEnum
ResponseText = 1
ResponseBody = 2
ResponseBodyToText = 3
End Enum
Private Type TGUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'// 用来加载Internet上的图片
Private Declare Function OleLoadPicturePath Lib "oleaut32.dll" (ByVal szURLorPath As Long, ByVal punkCaller As Long, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As TGUID, ByRef ppvRet As IPicture) As Long
Public Function GetData(ByVal url As String, Optional ByVal DataStic As DataEnum) As Variant
'On Error GoTo ERR:
Dim XmlHttp As Object
Dim DataS As String
Dim DataB() As Byte
Dim DataB2S As String
Set XmlHttp = CreateObject("Msxml2.XMLHTTP")
If Not IsObject(XmlHttp) Then
Set XmlHttp = CreateObject("Microsoft.XMLHTTP")
If Not IsObject(XmlHttp) Then Exit Function
End If
If url = "" Then Exit Function
XmlHttp.Open "get", url, True
XmlHttp.Send
While XmlHttp.ReadyState <> 4
DoEvents
Wend
'--------------------------------------函数返回
Select Case DataStic
Case ResponseText
'----------------------------------直接返回字符串
DataS = XmlHttp.ResponseText
GetData = DataS
Case ResponseBody
'----------------------------------直接返回二进制
DataB = XmlHttp.ResponseBody
GetData = DataB
Case ResponseBodyToText
'----------------------------------二进制转字符串[直接返回字串出现乱码时尝试]
DataB2S = BytesToStr(XmlHttp.ResponseBody)
GetData = DataB2S
Case Else
'----------------------------------无效的返回
GetData = ""
End Select
'--------------------------------------释放空间
Set XmlHttp = Nothing
Exit Function
ERR:
GetData = ""
End Function
Public Function PostData(ByVal strURL As String, ByVal StrData As String, ByVal DataStic As DataEnum, _
Optional ByVal DataType As String = "application/x-www-form-urlencoded", Optional ByVal UrlCode As Boolean) As Variant
On Error GoTo ERR:
Dim XmlHttp As Object
Dim DataS As String
Dim DataB() As Byte
Dim DataB2S As String
Set XmlHttp = CreateObject("Msxml2.XMLHTTP")
If Not IsObject(XmlHttp) Then
Set XmlHttp = CreateObject("Microsoft.XMLHTTP")
If Not IsObject(XmlHttp) Then Exit Function
End If
XmlHttp.Open "POST", strURL, True
XmlHttp.SetRequestHeader "Content-Length", Len(PostData)
XmlHttp.SetRequestHeader "CONTENT-TYPE", DataType
If UrlCode Then StrData = URLEncode(StrData)
XmlHttp.Send (StrData)
Do Until XmlHttp.ReadyState = 4
DoEvents
Loop
'------------------------------------函数返回
Select Case DataStic
Case ResponseText
'--------------------------------直接返回字符串
DataS = XmlHttp.ResponseText
PostData = DataS
Case ResponseBody
'--------------------------------直接返回二进制
DataB = XmlHttp.ResponseBody
PostData = DataB
Case ResponseBodyToText
'--------------------------------二进制转字符串[直接返回字串出现乱码时尝试]
DataB2S = BytesToStr(XmlHttp.ResponseBody)
PostData = DataB2S
Case Else
'--------------------------------无效的返回
PostData = ""
End Select
'------------------------------------释放空间
Set XmlHttp = Nothing
Exit Function
ERR:
PostData = ""
End Function
'================获得外网IP======================
Public Function GetWanIp()
On Error Resume Next
Dim Temp
Temp = GetData("http://members.3322.org/dyndns/getip", ResponseBodyToText)
Debug.Print Temp
If Temp = "" Then
GetWanIp = ""
Else
GetWanIp = Temp
End If
End Function
'// 从Internet上加载图片
Public Function LoadPicture(ByVal strFileName As String) As Picture
Dim IID As TGUID
With IID
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
On Error GoTo LocalErr
OleLoadPicturePath StrPtr(strFileName), 0&, 0&, 0&, IID, LoadPicture
Exit Function
LocalErr:
Set LoadPicture = VB.LoadPicture(strFileName)
ERR.Clear
End Function
Private Function BytesToStr(Bytes)
Dim Unicode As String
If IsUTF8(Bytes) Then '如果不是UTF-8编码则按照GB2312来处理
Unicode = "UTF-8"
Else
Unicode = "GB2312"
End If
Dim objstream As Object
Set objstream = CreateObject("ADODB.Stream")
With objstream
.Type = 1
.Mode = 3
.Open
.Write Bytes
.Position = 0
.Type = 2
.Charset = Unicode
BytesToStr = .ReadText
.Close
End With
End Function
'判断网页编码函数
Private Function IsUTF8(Bytes) As Boolean
On Error Resume Next
Dim i As Long, AscN As Long, Length As Long
Length = UBound(Bytes) + 1
If Length < 3 Then
IsUTF8 = False
Exit Function
ElseIf Bytes(0) = &HEF And Bytes(1) = &HBB And Bytes(2) = &HBF Then
IsUTF8 = True
Exit Function
End If
Do While i <= Length - 1
If Bytes(i) < 128 Then
i = i + 1
AscN = AscN + 1
ElseIf (Bytes(i) And &HE0) = &HC0 And (Bytes(i + 1) And &HC0) = &H80 Then
i = i + 2
ElseIf i + 2 < Length Then
If (Bytes(i) And &HF0) = &HE0 And (Bytes(i + 1) And &HC0) = &H80 And (Bytes(i + 2) And &HC0) = &H80 Then
i = i + 3
Else
IsUTF8 = False
Exit Function
End If
Else
IsUTF8 = False
Exit Function
End If
Loop
If AscN = Length Then
IsUTF8 = False
Else
IsUTF8 = True
End If
End Function
'编码函数
Public Function URLEncode(ByRef strURL As String) As String
Dim i As Long
Dim tempStr As String
For i = 1 To Len(strURL)
If Asc(Mid(strURL, i, 1)) < 0 Then
tempStr = "%" & Right(CStr(Hex(Asc(Mid(strURL, i, 1)))), 2)
tempStr = "%" & Left(CStr(Hex(Asc(Mid(strURL, i, 1)))), Len(CStr(Hex(Asc(Mid(strURL, i, 1))))) - 2) & tempStr
URLEncode = URLEncode & tempStr
ElseIf (Asc(Mid(strURL, i, 1)) >= 65 And Asc(Mid(strURL, i, 1)) <= 90) Or (Asc(Mid(strURL, i, 1)) >= 97 And Asc(Mid(strURL, i, 1)) <= 122) Then
URLEncode = URLEncode & Mid(strURL, i, 1)
Else
URLEncode = URLEncode & "%" & Hex(Asc(Mid(strURL, i, 1)))
End If
Next
End Function
'解码函数
Public Function URLDecode(ByRef strURL As String) As String
Dim i As Long
If InStr(strURL, "%") = 0 Then URLDecode = strURL: Exit Function
For i = 1 To Len(strURL)
If Mid(strURL, i, 1) = "%" Then
If Val("&H" & Mid(strURL, i + 1, 2)) > 127 Then
URLDecode = URLDecode & Chr(Val("&H" & Mid(strURL, i + 1, 2) & Mid(strURL, i + 4, 2)))
i = i + 5
Else
URLDecode = URLDecode & Chr(Val("&H" & Mid(strURL, i + 1, 2)))
i = i + 2
End If
Else
URLDecode = URLDecode & Mid(strURL, i, 1)
End If
Next
End Function
'UTF-8 URL编码
Public Function UTF8_URLEncoding(ByVal szInput As String)
Dim wch, uch, szRet
Dim X
Dim nAsc, nAsc2, nAsc3
If szInput = "" Then
UTF8_URLEncoding = szInput
Exit Function
End If
For X = 1 To Len(szInput)
wch = Mid(szInput, X, 1)
nAsc = AscW(wch)
If nAsc < 0 Then nAsc = nAsc + 65536
If (nAsc And &HFF80) = 0 Then
szRet = szRet & wch
Else
If (nAsc And &HF000) = 0 Then
uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
szRet = szRet & uch
Else
uch = "%" & Hex((nAsc \ 2 ^ 12) Or &HE0) & "%" & _
Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & "%" & _
Hex(nAsc And &H3F Or &H80)
szRet = szRet & uch
End If
End If
Next
UTF8_URLEncoding = szRet
End Function
'UTF-8 URL解码
Public Function UTF8_URLDecode(ByVal url As String)
Dim B, ub ''中文字的Unicode码(2字节)
Dim UtfB ''Utf-8单个字节
Dim UtfB1, UtfB2, UtfB3 ''Utf-8码的三个字节
Dim i, n, S
n = 0
ub = 0
For i = 1 To Len(url)
B = Mid(url, i, 1)
Select Case B
Case "+"
S = S & " "
Case "%"
ub = Mid(url, i + 1, 2)
UtfB = CInt("&H" & ub)
If UtfB < 128 Then
i = i + 2
S = S & ChrW(UtfB)
Else
UtfB1 = (UtfB And &HF) * &H1000 ''取第1个Utf-8字节的二进制后4位
UtfB2 = (CInt("&H" & Mid(url, i + 4, 2)) And &H3F) * &H40 ''取第2个Utf-8字节的二进制后6位
UtfB3 = CInt("&H" & Mid(url, i + 7, 2)) And &H3F ''取第3个Utf-8字节的二进制后6位
S = S & ChrW(UtfB1 Or UtfB2 Or UtfB3)
i = i + 8
End If
Case Else ''Ascii码
S = S & B
End Select
Next
UTF8_URLDecode = S
End Function