502647092
/
VBFunctionBas
mirror of https://e.coding.net/circlecloud/VBFunctionBas.git
1
0
Fork 0
Code Releases Activity

新增功能模块... 

Signed-off-by: 502647092 <jtb1@163.com>
master
502647092 2015-10-27 10:36:53 +08:00
parent 8492ab368b
commit db463fa993
4 changed files with 953 additions and 979 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1217
Frm_Tools.bas
View File

File diff suppressed because it is too large Load Diff

447
HttpHelper.bas Normal file
View File

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

31
JsonUtils.bas Normal file
View File

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

237
System.bas Normal file
View File

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