parent
8492ab368b
commit
db463fa993
1191
Frm_Tools.bas
1191
Frm_Tools.bas
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,447 @@
|
||||||
|
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,不同之处在于,如果原来的请求是POST,Location头指定的重定向目标文档应该通过GET提取(HTTP 1.1新)。
|
||||||
|
' · 304 - Not Modified 客户端有缓冲的文档并发出了一个条件性的请求(一般是提供If-Modified-Since头表示客户只想比指定日期更新的文档)。服务器告诉客户,原来缓冲的文档还可以继续使用。
|
||||||
|
' · 305 - Use Proxy 客户请求的文档应该通过Location头所指明的代理服务器提取(HTTP 1.1新)。
|
||||||
|
' · 307 - Temporary Redirect 和302(Found)相同。许多浏览器会错误地响应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
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,31 @@
|
||||||
|
Attribute VB_Name = "JsonUtils"
|
||||||
|
Option Explicit
|
||||||
|
|
||||||
|
Public Function CreateJson(JsonFile As String) As Object
|
||||||
|
Dim JsonLine As String
|
||||||
|
Dim S As String
|
||||||
|
Dim js
|
||||||
|
Open JsonFile For Input As 1
|
||||||
|
Do Until EOF(1)
|
||||||
|
Line Input #1, S
|
||||||
|
JsonLine = JsonLine & S
|
||||||
|
Loop
|
||||||
|
Close #1
|
||||||
|
Set js = CreateObject("ScriptControl")
|
||||||
|
js.Language = "JScript"
|
||||||
|
js.AddCode "function j(s) { return eval('(' + s + ')'); }"
|
||||||
|
Set CreateJson = js.Run("j", JsonLine)
|
||||||
|
Set js = Nothing
|
||||||
|
End Function
|
||||||
|
|
||||||
|
Public Function StrToJson(ByVal jsonstring As String) As Object
|
||||||
|
On Error Resume Next
|
||||||
|
Dim S As String
|
||||||
|
Dim js
|
||||||
|
Set StrToJson = Nothing
|
||||||
|
Set js = CreateObject("ScriptControl")
|
||||||
|
js.Language = "JScript"
|
||||||
|
js.AddCode "function j(s) { return eval('(' + s + ')'); }"
|
||||||
|
Set StrToJson = js.Run("j", jsonstring)
|
||||||
|
Set js = Nothing
|
||||||
|
End Function
|
|
@ -0,0 +1,237 @@
|
||||||
|
Attribute VB_Name = "System"
|
||||||
|
'#######################################用户控件说明#########################################
|
||||||
|
|
||||||
|
'名称:系统控件
|
||||||
|
|
||||||
|
'功能:获取系统信息
|
||||||
|
|
||||||
|
'最后更新日期:2014年12月8日
|
||||||
|
|
||||||
|
'创建人:蒋天蓓
|
||||||
|
|
||||||
|
'单位:上海市定海水电工程安装有限公司
|
||||||
|
|
||||||
|
''====================================用户控件使用说明=======================================
|
||||||
|
|
||||||
|
Option Explicit
|
||||||
|
''================================API调用打开文件窗口=========================================
|
||||||
|
'调用“打开”窗体
|
||||||
|
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long 'API调用打开
|
||||||
|
Private Type OPENFILENAME
|
||||||
|
lStructSize As Long
|
||||||
|
hwndOwner As Long
|
||||||
|
hInstance As Long
|
||||||
|
lpstrFilter As String
|
||||||
|
lpstrCustomFilter As String
|
||||||
|
nMaxCustFilter As Long 'API调用打开
|
||||||
|
nFilterIndex As Long
|
||||||
|
lpstrFile As String
|
||||||
|
nMaxFile As Long
|
||||||
|
lpstrFileTitle As String
|
||||||
|
nMaxFileTitle As Long
|
||||||
|
lpstrInitialDir As String
|
||||||
|
lpstrTitle As String
|
||||||
|
Flags As Long
|
||||||
|
nFileOffset As Integer
|
||||||
|
nFileExtension As Integer
|
||||||
|
lpstrDefExt As String
|
||||||
|
lCustData As Long
|
||||||
|
lpfnHook As Long
|
||||||
|
lpTemplateName As String
|
||||||
|
End Type 'API调用打开
|
||||||
|
Private Const MAX_PATH As Long = 260
|
||||||
|
''================================获得进程最高权限=========================================
|
||||||
|
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
|
||||||
|
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
|
||||||
|
Private Const PROCESS_ALL_ACCESS = &H1F0FFF '全权打开进程
|
||||||
|
|
||||||
|
''================================删除文件=========================================
|
||||||
|
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
|
||||||
|
Private Type SHFILEOPSTRUCT
|
||||||
|
hWnd As Long
|
||||||
|
wFunc As Long
|
||||||
|
pFrom As String
|
||||||
|
pTo As String
|
||||||
|
fFlags As Integer
|
||||||
|
fAborted As Boolean
|
||||||
|
hNameMaps As Long
|
||||||
|
sProgress As String
|
||||||
|
End Type
|
||||||
|
Private Const FO_DELETE = &H3
|
||||||
|
Private Const FOF_ALLOWUNDO = &H40 ' 移入回收站
|
||||||
|
Private Const FOF_CONFIRMMOUSE = &H2 ' 删除。不放入回收站
|
||||||
|
Private Const FOF_NOCONFIRMATION = &H10 ' 没有提示
|
||||||
|
|
||||||
|
''#####################################################模块代码#####################################################
|
||||||
|
'#############################################控件函数模块#################################################
|
||||||
|
'**********************************************************************************************************
|
||||||
|
'***过程名:DeleteFolder
|
||||||
|
'***功 能 :删除一个文件或文件夹。该过程可以删除非空的文件夹
|
||||||
|
'***输入值:(文件夹或文件名称 As String)
|
||||||
|
'***输出值:NULL
|
||||||
|
'***说 明:NULL
|
||||||
|
'**********************************************************************************************************
|
||||||
|
Public Sub DeleteFolder(sObject As String)
|
||||||
|
Dim SHFileOp As SHFILEOPSTRUCT
|
||||||
|
|
||||||
|
With SHFileOp
|
||||||
|
.wFunc = FO_DELETE
|
||||||
|
.pFrom = sObject
|
||||||
|
.fFlags = FOF_CONFIRMMOUSE Or FOF_NOCONFIRMATION
|
||||||
|
End With
|
||||||
|
SHFileOperation SHFileOp
|
||||||
|
End Sub
|
||||||
|
'**********************************************************************************************************
|
||||||
|
'***过程名:GetFilePath
|
||||||
|
'***功 能 :API调用打开窗口
|
||||||
|
'***输入值:(PID As Long)
|
||||||
|
'***输出值:String
|
||||||
|
'***说 明:NULL
|
||||||
|
'**********************************************************************************************************
|
||||||
|
Public Function GetFilePath(ByVal hWnd As Long, _
|
||||||
|
Optional ByVal DefaultFile As String, _
|
||||||
|
Optional ByVal DefaultFilterStr As String, _
|
||||||
|
Optional ByVal DefaultFilter As String, _
|
||||||
|
Optional ByVal DefaultTitle As String, Optional ByVal DefaultPath As String) As String
|
||||||
|
Dim ofn As OPENFILENAME
|
||||||
|
Dim rtn As Long
|
||||||
|
ofn.lStructSize = Len(ofn)
|
||||||
|
ofn.hwndOwner = hWnd
|
||||||
|
ofn.hInstance = App.hInstance
|
||||||
|
If DefaultFilter & DefaultFilterStr <> "" Then
|
||||||
|
ofn.lpstrFilter = DefaultFilterStr & "(" & DefaultFilter & ")" + Chr$(0) + DefaultFilter + Chr$(0) + _
|
||||||
|
"所有文件 (*.*)" + Chr$(0) + "*.*" + Chr$(0) + Chr$(0)
|
||||||
|
Else
|
||||||
|
ofn.lpstrFilter = "所有文件 (*.*)" + Chr$(0) + "*.*" + Chr$(0) + Chr$(0)
|
||||||
|
End If
|
||||||
|
ofn.lpstrFile = DefaultFile + Space(255 - Len(DefaultFile)) '这里可以改一个默认的文件名
|
||||||
|
ofn.nMaxFile = MAX_PATH
|
||||||
|
ofn.lpstrFileTitle = Space(255)
|
||||||
|
ofn.nMaxFileTitle = MAX_PATH
|
||||||
|
ofn.lpstrInitialDir = DefaultPath
|
||||||
|
ofn.lpstrTitle = DefaultTitle
|
||||||
|
ofn.Flags = 6148
|
||||||
|
rtn = GetOpenFileName(ofn)
|
||||||
|
If rtn >= 1 Then GetFilePath = ofn.lpstrFile Else GetFilePath = ""
|
||||||
|
End Function
|
||||||
|
'**********************************************************************************************************
|
||||||
|
'***过程名:CheckPid
|
||||||
|
'***功 能 :检查PID是否存活
|
||||||
|
'***输入值:(PID As Long)
|
||||||
|
'***输出值:Boolean
|
||||||
|
'***说 明:NULL
|
||||||
|
'**********************************************************************************************************
|
||||||
|
Public Function CheckPid(ByVal PID As Long) As Boolean
|
||||||
|
Dim info As Long
|
||||||
|
info = OpenProcess(PROCESS_ALL_ACCESS, &O0, PID)
|
||||||
|
If info = 0 Then
|
||||||
|
CheckPid = False
|
||||||
|
Else
|
||||||
|
CloseHandle CheckPid
|
||||||
|
CloseHandle PID
|
||||||
|
CheckPid = True
|
||||||
|
End If
|
||||||
|
End Function
|
||||||
|
|
||||||
|
Public Function GetSystemPath() As String
|
||||||
|
Dim aa$, jj%
|
||||||
|
aa = Environ("ComSpec")
|
||||||
|
jj = InStrRev(aa, "\")
|
||||||
|
GetSystemPath = Mid(aa, 1, jj - 1)
|
||||||
|
End Function
|
||||||
|
|
||||||
|
Public Function IsX86() As Boolean
|
||||||
|
'If Environ("PROCESSOR_ARCHITECTURE") = "x86" Then IsX86 = True: Exit Function
|
||||||
|
If Dir(Left(Environ("ComSpec"), 1) & ":\Windows\SysWOW64", vbDirectory) = "" Then
|
||||||
|
IsX86 = True
|
||||||
|
Else
|
||||||
|
IsX86 = False
|
||||||
|
End If
|
||||||
|
End Function
|
||||||
|
|
||||||
|
Public Function FileCheck(ByVal FileName As String, Optional ByVal Reg As Boolean) As Boolean
|
||||||
|
Dim FileData() As Byte
|
||||||
|
Dim FileInfo() As String
|
||||||
|
Dim SystemPath As String
|
||||||
|
SystemPath = GetSystemPath
|
||||||
|
If Dir(SystemPath & "\" & FileName) = "" Then
|
||||||
|
FileInfo = Split(FileName, ".")
|
||||||
|
If UBound(FileInfo) < 1 Then MsgBox "文件" & FileName & "名称错误!", vbCritical
|
||||||
|
FileData = LoadResData(UCase(FileInfo(0)), UCase(FileInfo(1)))
|
||||||
|
Open SystemPath & "\" & FileName For Binary As #1 '以二进制方式写(生成)控件(kjmc.kjlx)到主程序所在的目录
|
||||||
|
Put #1, , FileData
|
||||||
|
Close #1
|
||||||
|
If Reg Then Shell "regsvr32 \s " & SystemPath & "\" & FileName, vbHide
|
||||||
|
End If
|
||||||
|
End Function
|
||||||
|
|
||||||
|
Public Sub MkMulDirs(ByVal Path As String)
|
||||||
|
Dim FilePath As String
|
||||||
|
Dim Index As Long
|
||||||
|
Index = InStr(1, Path, "\")
|
||||||
|
Debug.Print Index
|
||||||
|
Do While Index > 0
|
||||||
|
FilePath = Left(Path, Index)
|
||||||
|
If Dir(FilePath, vbDirectory) = "" Then _
|
||||||
|
MkDir FilePath
|
||||||
|
Index = InStr(Index + 1, Path, "\")
|
||||||
|
Loop
|
||||||
|
Debug.Print "创建文件夹: " & Path
|
||||||
|
End Sub
|
||||||
|
|
||||||
|
Public Function FindPath(ByVal AppName As String) As String
|
||||||
|
On Error Resume Next
|
||||||
|
Dim PathDir As String
|
||||||
|
Dim WshShell
|
||||||
|
Set WshShell = CreateObject("Wscript.Shell")
|
||||||
|
' 注册表写入
|
||||||
|
' WshShell.RegWrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName, App.Path & "\" & App.EXEName & ".exe"
|
||||||
|
' 注册表删除
|
||||||
|
' WshShell.RegDelete "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName
|
||||||
|
' 注册表读取
|
||||||
|
FindPath = WshShell.RegRead("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\" & AppName & "\Path")
|
||||||
|
Set WshShell = Nothing
|
||||||
|
' PathDir = Left(Environ("ComSpec"), 1)
|
||||||
|
' If Dir(PathDir & ":\Program Files\Java\jre6\bin\java.exe") <> "" Then
|
||||||
|
' FindJava = PathDir & ":\Program Files\Java\jre6\bin\java.exe"
|
||||||
|
' ElseIf Dir(PathDir & ":\Program Files (x86)\Java\jre6\bin\java.exe") <> "" Then
|
||||||
|
' FindJava = PathDir & ":\Program Files (x86)\Java\jre6\bin\java.exe"
|
||||||
|
' ElseIf Dir(PathDir & ":\Program Files\Java\jre7\bin\java.exe") <> "" Then
|
||||||
|
' FindJava = PathDir & ":\Program Files\Java\jre7\bin\java.exe"
|
||||||
|
' ElseIf Dir(PathDir & ":\Program Files (x86)\Java\jre7\bin\java.exe") <> "" Then
|
||||||
|
' FindJava = PathDir & ":\Program Files (x86)\Java\jre7\bin\java.exe"
|
||||||
|
' ElseIf Dir(PathDir & ":\Program Files\Java\jre8\bin\java.exe") <> "" Then
|
||||||
|
' FindJava = PathDir & ":\Program Files\Java\jre8\bin\java.exe"
|
||||||
|
' ElseIf Dir(PathDir & ":\Program Files (x86)\Java\jre8\bin\java.exe") <> "" Then
|
||||||
|
' FindJava = PathDir & ":\Program Files (x86)\Java\jre8\bin\java.exe"
|
||||||
|
' Else
|
||||||
|
' FindJava = ""
|
||||||
|
' End If
|
||||||
|
End Function
|
||||||
|
|
||||||
|
Public Function FindJar() As String
|
||||||
|
If Dir(App.Path & "/*.jar") <> "" Then
|
||||||
|
FindJar = Dir(App.Path & "/*.jar")
|
||||||
|
End If
|
||||||
|
End Function
|
||||||
|
|
||||||
|
Public Function GetMaxMem() As String
|
||||||
|
Dim strComputer
|
||||||
|
Dim strNameSpace
|
||||||
|
Dim strClass
|
||||||
|
Dim objSWbemObject
|
||||||
|
Dim objSWbemServices
|
||||||
|
Dim objSWbemObjectSet
|
||||||
|
Dim MaxMemN
|
||||||
|
MaxMemN = 0
|
||||||
|
Set objSWbemServices = GetObject("winmgmts:")
|
||||||
|
Set objSWbemObjectSet = objSWbemServices.ExecQuery("select Capacity from Win32_PhysicalMemory where CreationClassName='Win32_PhysicalMemory'")
|
||||||
|
For Each objSWbemObject In objSWbemObjectSet
|
||||||
|
MaxMemN = objSWbemObject.Capacity + MaxMemN
|
||||||
|
Next
|
||||||
|
GetMaxMem = Int(MaxMemN / 1024 / 1024)
|
||||||
|
GetMaxMem = Trim(Str(GetMaxMem))
|
||||||
|
Set objSWbemObject = Nothing
|
||||||
|
Set objSWbemServices = Nothing
|
||||||
|
Set objSWbemObjectSet = Nothing
|
||||||
|
End Function
|
Loading…
Reference in New Issue