新增功能模块...

Signed-off-by: 502647092 <jtb1@163.com>

HttpHelper.bas

@@ -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
+
+

JsonUtils.bas

@@ -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

System.bas

@@ -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