From db463fa993cf118858f485a1a7cd1ec2bdf16d33 Mon Sep 17 00:00:00 2001 From: 502647092 Date: Tue, 27 Oct 2015 10:36:53 +0800 Subject: [PATCH] =?UTF-8?q?=E6=96=B0=E5=A2=9E=E5=8A=9F=E8=83=BD=E6=A8=A1?= =?UTF-8?q?=E5=9D=97...?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Signed-off-by: 502647092 --- Frm_Tools.bas | 1217 ++++++++++-------------------------------------- HttpHelper.bas | 447 ++++++++++++++++++ JsonUtils.bas | 31 ++ System.bas | 237 ++++++++++ 4 files changed, 953 insertions(+), 979 deletions(-) create mode 100644 HttpHelper.bas create mode 100644 JsonUtils.bas create mode 100644 System.bas diff --git a/Frm_Tools.bas b/Frm_Tools.bas index 371a617..3e5440b 100644 --- a/Frm_Tools.bas +++ b/Frm_Tools.bas @@ -1,1085 +1,344 @@ Attribute VB_Name = "Frm_Tools" -'#######################################用户控件说明######################################### +'#######################################模块说明######################################### -'名称:窗体控件 +'名称:窗体工具 -'功能:实现窗体透明，移动，靠边隐藏等功能 +'功能:实现VB窗体透明，移动，靠边隐藏等功能 -'最后更新日期:2014年6月5日 +'最后更新日期:2014年5月14日 '创建人:蒋天蓓 '单位:上海市定海水电工程安装有限公司 -''====================================用户控件使用说明======================================= -'窗体靠边自动隐藏:Auto_Hide(窗体句柄 As Long, 隐藏后显示部分长度 As Long, 检测间隔 As Long, [(可选)移动速度 As Long = 1]) -'窗体靠边自动吸附:Auto_Magnet(窗体名 As Form, 吸附距离 As Long,[可选，鼠标状态]) -'***************************************************************************************************************************** -'窗体大小延时处理:Daily_Show(窗体 As Form, 延时时间 As Long) -'窗体透明延时处理:Daily_Tpt(运行模式 As Boolean, 句柄 As Long, 透明度 As Integer, 延时时间 As Long) -'***************************************************************************************************************************** -'全屏窗口移动(通过窗体移动):fMove(窗体 As Form, Button As Integer, Shift As Integer, X As Single, Y As Single) -'全屏窗口移动(通过窗体句柄):hMove(窗体句柄 As Long) -'***************************************************************************************************************************** -'获取窗体类名:GetClassName(窗体句柄 As Long) As String -'***************************************************************************************************************************** -'获取激活窗体句柄: GetFedWnd() As Long -'激活窗体(通过窗体句柄):SetFedWnd(窗体句柄 As Long) -'***************************************************************************************************************************** -'获取原有窗体控件大小: GetFrmSize -'根据窗体大小调整控件大小: SetFrmSize -'***************************************************************************************************************************** -'通过类名标题查找窗体:GetWindowhWnd(窗体标题 As String,窗体类名 As String) As Long -'通过类名查找窗体:GethWndByClass(窗体类名 As String) As Long -'通过标题查找窗体:GethWndByTitle(窗体标题 As String) As Long -'获取窗体图标句柄:GetIconhWnd(窗体句柄 As Long) As Long -'获取鼠标所在窗体句柄: GetMouseWindowhWnd() As Long -'***************************************************************************************************************************** -'获取窗体标题(通过窗体句柄):GetTitle(窗体句柄 As Long) As String -'设置窗体标题(通过窗体句柄):SetTitle(窗体句柄 As Long, 窗体标题 As String) -'***************************************************************************************************************************** -'后台按下键:hWndKeyDown(窗体句柄 As Long, 按键码 As Long, [按键模式 As KeyPressMode = Normal]) -'后台按键:hWndKeyPress(窗体句柄 As Long, 按键码 As Long, [按键模式 As KeyPressMode = Normal]) -'后台释放键:hWndKeyUp(窗体句柄 As Long, 按键码 As Long, [按键模式 As KeyPressMode = Normal]) -'根据按键码返回按键信息:KeyNum2Key(按键码 As long) As String -'制作按键扫描码MakeKeyLparam:(按键码 As long,按键模式 As Long) As String -'***************************************************************************************************************************** -'窗体显示函数:InShow(窗体句柄 As Long, [显示模式 As Boolean = True](True是显示，False是隐藏)) -'窗口置顶函数:InTop(窗体句柄 As Long, [显示模式 As Boolean = True](True是置顶，False是不置顶)) -'***************************************************************************************************************************** -'使窗体不接受鼠标消息，可操作后面窗体:NoControl(句柄 As Long, [模式 As Boolean](Mode=Ture表示不接受，False表示接受)) -'***************************************************************************************************************************** -'窗口加载真彩图标:GethWndByClassEx(窗体句柄 As Long，图标句柄 As Long) -'***************************************************************************************************************************** -'延时:Sleep(延时大小 As Long[毫秒]) -'***************************************************************************************************************************** -'窗体透明:Tpt(窗体句柄 As Long, 透明度(0-100) As Integer, [需要透明的颜色 As Long]) -'#######################################用户控件说明######################################### +''====================================模块使用说明======================================= +'**************************************************** +'窗体透明：Frm_Tpt (窗体句柄 As Long, 透明度(0-100) As Integer, [可选：指定颜色透明TransColor As Long]) +'**************************************************** +'窗体透明延时显示：Frm_Daily_Tpt (模式 As Boolean(True是显示，False是隐藏), 窗体句柄 As Long, 透明度(0-100) As Integer,显示速度(1-10)) +'**************************************************** +'窗体置顶：Frm_InTop (窗体句柄 As Long, Mode As Boolean) +'**************************************************** +'窗体靠边隐藏：Frm_Auto_Hide (窗体名 As Form, 计时器 As Timer, 隐藏后显示部分长度 As Long, 检测间隔 As Long) +'**************************************************** +'窗体靠边吸附：Frm_Auto_Magnet (窗体名 As Form, 吸附距离 As Long) +'**************************************************** +'得到激活窗体句柄：Frm_GetFedWnd () +'设置激活窗体：Frm_SetFedWnd (窗体句柄 As Long) +'**************************************************** +'得到窗体标题：Frm_Title_Get (窗体句柄 As Long) +'修改窗体标题：Frm_Title_Set (窗体句柄 As Long, 标题内容 As String) +'**************************************************** +'加载真彩图标：Frm_RGBAIcon +'**************************************************** +'读取窗体控件原有大小比例：Frm_ResizeGet(FormName As Form) +'保持窗体控件原有大小比例：Frm_ResizeSet(FormName As Form) +'#######################################模块说明######################################### + + +''#########################################模块函数######################################## Option Explicit -Public VisibleT As Boolean -''#########################################模块函数######################################## -'====================句柄后台按键======================= -Public Enum KeyPressMode - Normal - System - GameMode -End Enum - -Private Const WM_KEYDOWN As Long = &H100 -Private Const WM_KEYUP As Long = &H101 -Private Const WM_CHAR As Long = &H102 -Private Const WM_SYSKEYDOWN As Long = &H104 -Private Const WM_SYSKEYUP As Long = &H105 - -Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long -Private Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long -'====================获取鼠标所在窗体句柄======================= -Private Declare Function WindowFromPoint Lib "user32.dll" (ByVal xPoint As Long, ByVal yPoint As Long) As Long +''================================保持窗体控件原有大小比例========================================= +Private FormOldWidth As Long '保存窗体的原始宽度 +Private FormOldHeight As Long '保存窗体的原始高度 ''================================窗体消息发送========================================= -Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long +Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Const WM_SETICON As Long = &H80 ''================================窗体查找========================================= Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long ''================================窗体激活========================================= Private Declare Function GetForegroundWindow Lib "user32" () As Long -Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long +Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long ''================================窗体标题========================================= -Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long -Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long -Private Declare Function GetClassNameh Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long -Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long -''================================窗口操作函数========================================= -Private Declare Function SetWindowPos& Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) -Private Const FRM_TOP = -1 '置顶 -Private Const FRM_NORMAL = -2 '普通 -Private Const FRM_NOSIZE = &H1 '不改变大小 -Private Const FRM_NOMOVE = &H2 '不移动 -Private Const FRM_TOPMOST = &H3 '仅置顶 +Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String) As Long +Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long +Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long +Private Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long +''================================窗口置顶函数========================================= +Private Declare Function SetWindowPos& Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) +Private Const FRM_TOP = -1 +Private Const FRM_NORMAL = -2 +Private Const FRM_NOSIZE = &H1 +Private Const FRM_NOMOVE = &H2 +Private Const FRM_TOPMOST = &H3 Private Const FRM_NOZEROER = &H4 -Private Const FRM_NOREDRAW = &H8 '不重画窗体 -Private Const FRM_NOACTIVATE = &H10 '不激活窗体 +Private Const FRM_NOREDRAW = &H8 +Private Const FRM_NOACTIVATE = &H10 Private Const FRM_FRAMECHANGED = &H20 -Private Const FRM_SHOWWINDOW = &H40 '显示窗体 -Private Const FRM_HIDEWINDOW = &H80 '隐藏窗体 +Private Const FRM_SHOWWINDOW = &H40 +Private Const FRM_HIDEWINDOW = &H80 Private Const FRM_NOCOPYBITS = &H100 Private Const FRM_NOOWNERZORDER = &H200 Private Const FRM_NOSENDCHANGING = &H400 '========================全屏窗口移动============================ Private Declare Function ReleaseCapture Lib "user32" () As Long +'Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Const HTCAPTION = 2 Private Const WM_NCLBUTTONDOWN = &HA1 '''========================窗体靠边自动隐藏============================ Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long -Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long -Private Type RECT '获取窗体位置 +Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long +Private Type RECT '获取窗体位置 Left As Long Top As Long Right As Long Bottom As Long End Type -Public Enum SetPos - SpTop - SPButton - SpLeft - SPRight -End Enum -Private Type POINTAPI '获取鼠标位置 - X As Long - Y As Long +Private Type POINTAPI '获取鼠标位置 + x As Long + y As Long End Type -Private IsInFrm As Boolean '检测窗体与鼠标状态。防止窗体闪烁 -Private Const HWND_TOPMOST = -1 '定义变量 +Private Const HWND_TOPMOST = -1 '定义变量 Private Const SWP_NOSIZE = &H1 Private Const SWP_NOMOVE = &H2 Private Const HWND_TOP = 0 Private Const SWP_NOACTIVATE = &H10 Private Const SWP_SHOWWINDOW = &H40 -Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long -Private Declare Function IsIconic Lib "user32" (ByVal hwnd As Long) As Long -Private Declare Function IsZoomed Lib "user32" (ByVal hwnd As Long) As Long -Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long '''========================窗体透明============================ -Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long -Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long -Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long +Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long +Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long +Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Private Const WS_EX_LAYERED = &H80000 -Private Const WS_EX_TRANSPARENT = &H20& -Private Const WS_EX_TOPMOST = &H8 Private Const GWL_EXSTYLE = (-20) Private Const LWA_ALPHA = &H2 Private Const LWA_COLORKEY = &H1 -'===================================圆角窗体==================================================== -Private Declare Function SetWindowRgn Lib "user32.dll" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long -Private Declare Function CreateRoundRectRgn Lib "gdi32.dll" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long -Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long -'=================================Sleep======================================== + Private Declare Function timeGetTime Lib "winmm.dll" () As Long Private Savetime As Double -''================================根据句柄获得PID========================================= -Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, ByRef lpdwprocessid As Long) As Long -''================================系统版本获取函数========================================= -Private Type OSVERSIONINFO - dwOSVersionInfoSize As Long - dwMajorVersion As Long - dwMinorVersion As Long - dwBuildNumber As Long - dwPlatformId As Long - szCSDVersion As String * 128 ' Maintenance string for PSS usage -End Type -Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long -Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long -Private Const SM_CLEANBOOT = 67 -Private Const SM_DEBUG = 22 -Private Const SM_SLOWMACHINE = 73 -Private Const VER_PLATFORM_WIN32s = 0 -Private Const VER_PLATFORM_WIN32_WINDOWS = 1 -Private Const VER_PLATFORM_WIN32_NT = 2 - -Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long -Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" (ByRef saArray() As Any) As Long -Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) As Long -Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long ''#####################################################模块代码##################################################### - -'#############################################控件函数模块################################################# -'********************************************************************************************************** -'***过程名：SetWindowIcon -'***功 能 ：改变窗体ICO图标 -'***输入值：(窗体句柄 As Long, [可选]图标文件 As String, [可选]图标位数 As Integer) -'***输出值：句柄所指向的PID -'***说 明：NULL -'********************************************************************************************************** -Public Sub SetWindowIcon(hwnd As Long, Optional FileName As String, Optional IconIndex As Integer) - Dim m_Icon As Long - Dim hModule As Long - If Len(FileName) = 0 Or Len(Dir(FileName, vbHidden)) = 0 Then - Dim MyPath As String - MyPath = App.Path - If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" - FileName = MyPath & App.EXEName & ".exe" +'''========================窗体透明============================ +Public Sub Frm_Tpt(ByVal hWnd As Long, ByVal range As Integer, Optional ByVal TransColor As Long) + If range > 100 Then '如果透明度大于100则定义为100 + range = 100 + ElseIf range < 0 Then '如果透明度小于0则定义为0 + range = 0 End If - hModule = GetModuleHandle(FileName) - m_Icon = ExtractIcon(hModule, FileName, IconIndex) - SendMessage hwnd, WM_SETICON, 0, ByVal m_Icon -End Sub - -Public Function GetSystemVer() - Dim myVer As OSVERSIONINFO - Dim q As Long - myVer.dwOSVersionInfoSize = 148 '获取系统版本 - q& = GetVersionEx(myVer) - GetSystemVer = myVer.dwMajorVersion & "." & myVer.dwMinorVersion -End Function -'********************************************************************************************************** -'***过程名：SetRgnWindows -'***功 能 ：改变窗体可视大小 -'***输入值：(窗体 As Form,边缘大小 As Long) -'***输出值：句柄所指向的PID -'***说 明：NULL -'********************************************************************************************************** -Public Function SetRgnWindows(Frm, Rng As Long) As Long - Dim FRng As Long - Dim w As Long - Dim h As Long - w = ScaleX(Frm.Width, vbTwips, vbPixels) - h = ScaleX(Frm.Height, vbTwips, vbPixels) - FRng = CreateRectRgn(Rng, Rng, w - Rng, h - Rng) - SetRgnWindows = SetWindowRgn(Frm.hwnd, FRng, True) -End Function -'********************************************************************************************************** -'***过程名：SetRoundWindows -'***功 能 ：改变窗体为圆角窗体 -'***输入值：(窗体 As Form,圆角大小 As Long) -'***输出值：句柄所指向的PID -'***说 明：NULL -'********************************************************************************************************** -Public Function SetRoundWindows(Frm, Rng As Long) As Long - Dim FRng As Long - Dim w As Long - Dim h As Long - w = ScaleX(Frm.Width, vbTwips, vbPixels) - h = ScaleX(Frm.Height, vbTwips, vbPixels) - FRng = CreateRoundRectRgn(0, 0, w - 0, h - 0, Rng, Rng) - SetRoundWindows = SetWindowRgn(Frm.hwnd, FRng, True) -End Function -'********************************************************************************************************** -'***过程名：GetPidByhWnd -'***功 能 ：根据句柄获得PID -'***输入值：(窗体句柄 As Long) -'***输出值：句柄所指向的PID -'***说 明：NULL -'********************************************************************************************************** -Public Function GetPidByhWnd(ByVal hwnd As Long) As Long - Dim PID As Long - GetWindowThreadProcessId hwnd, PID - GetPidByhWnd = PID -End Function -'********************************************************************************************************** -'***过程名：Tpt -'***功 能 ：句柄窗体透明 -'***输入值：(窗体句柄 As Long, 透明度(0-100) As Integer, [需要透明的颜色 As Long = -1]) -'***输出值：NULL -'***说 明：窗体中用Me.hWnd代表窗体句柄 -'********************************************************************************************************** -Public Sub Tpt(ByVal hwnd As Long, ByVal Range As Integer, Optional ByVal TransColor As Long = -1) - If Range > 100 Then Range = 100 '如果透明度大于100则定义为100 - If Range < 0 Then Range = 0 '如果透明度小于0则定义为0 Dim rtn As Long - rtn = GetWindowLong(hwnd, GWL_EXSTYLE) '取得窗体状态 + rtn = GetWindowLong(hWnd, GWL_EXSTYLE) '取得窗体句柄 rtn = rtn Or WS_EX_LAYERED - SetWindowLong hwnd, GWL_EXSTYLE, rtn - If TransColor = -1 Then - SetLayeredWindowAttributes hwnd, 0, Range * 2.55, LWA_ALPHA '设置窗体透明度 - Else - SetLayeredWindowAttributes hwnd, TransColor, Range * 2.55, LWA_COLORKEY '根据颜色设置窗体透明度 - End If + SetWindowLong hWnd, GWL_EXSTYLE, rtn + SetLayeredWindowAttributes hWnd, TransColor, range * 2.55, LWA_ALPHA '设置窗体透明度 End Sub -'********************************************************************************************************** -'***过程名：NoControl -'***功 能 ：使窗体不接受鼠标消息，可操作后面窗体 -'***输入值：(句柄 As Long, [模式 As Boolean]) -'***输出值：NULL -'***说 明：窗体中用Me.hWnd代表窗体句柄，Mode=Ture表示不接受，False表示接受。 -'********************************************************************************************************** -Public Sub NoControl(ByVal hwnd As Long, Optional ByVal Mode As Boolean = True) - Dim rtn As Long - rtn = GetWindowLong(hwnd, GWL_EXSTYLE) '取得窗体状态 - rtn = rtn Or WS_EX_LAYERED - If Mode Then - rtn = rtn Or WS_EX_TRANSPARENT - Else - rtn = rtn And Not WS_EX_TRANSPARENT - End If - SetWindowLong hwnd, GWL_EXSTYLE, rtn -End Sub -'********************************************************************************************************** -'***过程名：Daily_Tpt -'***功 能 ：窗体透明延时处理 -'***输入值：(运行模式 As Boolean, 句柄 As Long, 透明度 As Integer, 延时时间 As Long) -'***输出值：NULL -'***说 明：窗体中用Me.hWnd代表窗体句柄,Mode = True '显示窗体，Mode = False '隐藏窗体 -'********************************************************************************************************** -Public Sub Daily_Tpt(ByVal Mode As Boolean, ByVal hwnd As Long, ByVal Range As Integer, ByVal Daily As Long, Optional ByVal AddTpt As Long = 1) +'''========================窗体透明延时显示============================ +Public Sub Frm_Daily_Tpt(ByVal Mode As Boolean, ByVal hWnd As Long, ByVal range As Integer, Daily As Long) 'Mode = True '显示窗体 'Mode = False '隐藏窗体 - If Daily > 5 Then Daily = 5 '防止参数过大，导致显示异常缓慢 - If Daily <= 0 Then Daily = 0.1 Daily = Daily * 10 - Dim Tpti As Integer + Dim Tpti If Mode = True Then - Do Until Tpti > Range - Tpti = Tpti + AddTpt + Do Until Tpti > range + Tpti = Tpti + 1 Sleep Daily - Tpt hwnd, Tpti + Frm_Tpt hWnd, Tpti Loop Else - Tpti = Range + Tpti = range Do Until Tpti < 0 - Tpti = Tpti - AddTpt + Tpti = Tpti - 1 Sleep Daily - Tpt hwnd, Tpti + Frm_Tpt hWnd, Tpti Loop End If End Sub -'********************************************************************************************************** -'***过程名：Daily_Show -'***功 能 ：窗体大小延时处理 -'***输入值：(窗体 As Form, 延时时间 As Long) -'***输出值：NULL -'********************************************************************************************************** -Public Sub Daily_Show(ByVal Frm As Form, ByVal Daily As Long) +'''========================窗体大小延时显示============================ +Public Sub Frm_Daily_Show(frm As Form, Daily As Long) Dim h As Long Dim w As Long - Dim i As Long - h = Frm.Height - w = Frm.Width - Frm.Height = 20 - Frm.Width = 20 - For i = 20 To w Step Daily + Dim I As Long + h = frm.Height + w = frm.Width + frm.Height = 20 + frm.Width = 20 + + For I = 20 To w Step Daily Sleep 10 - Frm.Width = i - Frm.Refresh + frm.Width = I + frm.Show Next - For i = 20 To h Step Daily + + For I = 20 To h Step Daily Sleep 10 - Frm.Height = i - Frm.Refresh + frm.Height = I + frm.Show Next + End Sub -'********************************************************************************************************** -'***过程名：InTop -'***功 能 ：窗口置顶函数 -'***输入值：(窗体句柄 As Long, [显示模式 As Boolean = True](True是置顶，False是不置顶)) -'***输出值：NULL -'***说 明：窗体中用Me.hWnd代表窗体句柄 -'********************************************************************************************************** -Public Sub InTop(ByVal hwnd As Long, Optional ByVal Mode As Boolean = True) +''================================窗口置顶函数========================================= +Public Sub Frm_InTop(ByVal hWnd As Long, Optional ByVal Mode As Boolean = True) If Mode Then - SetWindowPos hwnd, FRM_TOP, 0, 0, 0, 0, FRM_TOPMOST '置顶 + SetWindowPos hWnd, FRM_TOP, 0, 0, 0, 0, FRM_TOPMOST Else - SetWindowPos hwnd, FRM_NORMAL, 0, 0, 0, 0, FRM_TOPMOST '不置顶 + SetWindowPos hWnd, FRM_NORMAL, 0, 0, 0, 0, FRM_TOPMOST End If End Sub -'********************************************************************************************************** -'***过程名：InShow -'***功 能 ：窗体显示函数 -'***输入值：(窗体句柄 As Long, [显示模式 As Boolean = True](True是显示，False是隐藏)) -'***输出值：NULL -'***说 明：窗体中用Me.hWnd代表窗体句柄 -'********************************************************************************************************** -Public Sub InShow(ByVal hwnd As Long, Optional ByVal Mode As Boolean = True) - If Mode Then - SetWindowPos hwnd, 0, 0, 0, 0, 0, FRM_SHOWWINDOW Or FRM_TOPMOST '显示 - Else - SetWindowPos hwnd, 0, 0, 0, 0, 0, FRM_HIDEWINDOW Or FRM_TOPMOST '不显示 - End If -End Sub -'********************************************************************************************************** -'***过程名：Auto_Hide -'***功 能：窗体靠边自动隐藏 -'***输入值：(窗体句柄 As Long, 隐藏后显示部分长度 As Long, 检测间隔 As Long, [(可选)移动速度 As Long = 1]) -'***输出值：NULL -'***说 明：窗体句柄可用Me.hWnd -'********************************************************************************************************** -Public Sub Auto_Hide(ByVal Enable As Boolean, Optional ByVal hwnd As Long, Optional ByVal Range As Long, Optional Daily As Long, Optional ByVal MoveInt As Long = 1) - Tim.Enabled = Enable - Tim.Interval = Daily - Tim.Tag = hwnd & " " & Range & " " & MoveInt + +Public Sub Frm_Show(ByVal hWnd As Long) + SetWindowPos hWnd, 0, 0, 0, 0, 0, FRM_SHOWWINDOW Or FRM_TOPMOST End Sub -Private Sub Tim_Timer() - Dim info - info = Split(Tim.Tag) - Auto_Hide_Load Val(info(0)), Val(info(1)), Val(info(2)) +Public Sub Frm_Hide(ByVal hWnd As Long) + SetWindowPos hWnd, 0, 0, 0, 0, 0, FRM_HIDEWINDOW Or FRM_TOPMOST End Sub +'''========================窗体靠边自动隐藏============================ +Public Sub Frm_Auto_Hide(ByVal frm As Form, ByVal tmr As Timer, ByVal range As Long, ByVal Daily As Long) + Dim p As POINTAPI + Dim f As RECT + tmr.Interval = Daily + GetCursorPos p '得到MOUSE位置 + GetWindowRect frm.hWnd, f '得到窗体的位置 + If frm.WindowState <> 1 Then + If p.x >= f.Left And p.x <= f.Right And p.y >= f.Top And p.y <= f.Bottom Then + 'MOUSE 在窗体上 + If frm.Top <= 0 Then + Do Until frm.Top >= 0 '从上显示窗体 + frm.Top = frm.Top + 1 + Loop + ElseIf frm.Left <= 0 Then '从左显示窗体 + Do Until frm.Left >= 0 + frm.Left = frm.Left + 1 + Loop + ElseIf frm.Top + frm.Height >= Screen.Height Then '从下显示窗体 + Do Until frm.Top <= Screen.Height - frm.Height + frm.Top = frm.Top - 1 + Loop + ElseIf frm.Left + frm.Width >= Screen.Width Then '从右显示窗体 + Do Until frm.Left <= Screen.Width - frm.Width + frm.Left = frm.Left - 1 + Loop -Private Sub Auto_Hide_Load(ByVal hwnd As Long, ByVal Range As Long, Optional ByVal MoveInt As Long) - Dim P As POINTAPI - Dim F As RECT - Dim T As Long - Dim WinHeight As Long - Dim WinWidth As Long - Dim ScrHeight As Long - Dim ScrWidth As Long - Dim IsTop As Long - IsTop = IsTopmost(hwnd) - GetCursorPos P '得到MOUSE位置 - GetWindowRect hwnd, F '得到窗体的位置 - WinWidth = F.Right - F.Left - WinHeight = F.Bottom - F.Top - ScrHeight = Screen.Height / 15 - ScrWidth = Screen.Width / 15 - If MoveInt <= 0 Then MoveInt = 0 - If IsZoomed(hwnd) = 0 And IsIconic(hwnd) = 0 Then - If P.X >= F.Left And P.X <= F.Right And P.Y >= F.Top And P.Y <= F.Bottom Then - If IsInFrm Then - SetWindowPos hwnd, FRM_TOP, 0, 0, 0, 0, FRM_TOPMOST - If F.Top <= 0 Then - T = F.Top - Do Until T >= 0 '从上显示窗体 - If MoveInt = 0 Then T = 0 Else T = T + MoveInt - If T > 0 Then T = 0 - SetWindowPos hwnd, 0, F.Left, T, 0, 0, FRM_NOSIZE - DoEvents - Loop - ElseIf F.Left <= 0 Then '从左显示窗体 - T = F.Left - Do Until T >= 0 - If MoveInt = 0 Then T = 0 Else T = T + MoveInt - If T > 0 Then T = 0 - SetWindowPos hwnd, 0, T, F.Top, 0, 0, FRM_NOSIZE - DoEvents - Loop - ElseIf F.Bottom >= ScrHeight Then '从下显示窗体 - T = F.Bottom - Do Until T <= ScrHeight - If MoveInt = 0 Then T = ScrHeight Else T = T - MoveInt - If T > ScrHeight Then T = ScrHeight - SetWindowPos hwnd, 0, F.Left, T - WinHeight, 0, 0, FRM_NOSIZE - DoEvents - Loop - ElseIf F.Right >= ScrWidth Then '从右显示窗体 - T = F.Right - Do Until T <= ScrWidth - If MoveInt = 0 Then T = ScrWidth Else T = T - MoveInt - If T > ScrWidth Then T = ScrWidth - SetWindowPos hwnd, 0, T - WinWidth, F.Top, 0, 0, FRM_NOSIZE - DoEvents - Loop - End If - IsInFrm = False End If Else - If Not IsInFrm Then - SetWindowPos hwnd, FRM_NORMAL, 0, 0, 0, 0, FRM_TOPMOST - If F.Top <= 5 Then - T = F.Top - Do Until T <= Range / 15 - WinHeight '从上隐藏窗体,range为露在外面长度 - If MoveInt = 0 Then T = Range / 15 - WinHeight Else T = T - MoveInt - If T < Range / 15 - WinHeight Then T = Range / 15 - WinHeight - SetWindowPos hwnd, 0, F.Left, T, 0, 0, FRM_NOSIZE - DoEvents - Loop - ElseIf F.Left <= 5 Then - T = F.Left - Do Until T <= Range / 15 - WinWidth '从左隐藏窗体 - If MoveInt = 0 Then T = Range / 15 - WinWidth Else T = T - MoveInt - If T < Range / 15 - WinWidth Then T = Range / 15 - WinWidth - SetWindowPos hwnd, 0, T, F.Top, 0, 0, FRM_NOSIZE - DoEvents - Loop - ElseIf F.Bottom >= ScrHeight - 5 Then '从下隐藏窗体 - T = F.Bottom - WinHeight - Do Until T >= ScrHeight - Range / 15 - If MoveInt = 0 Then T = ScrHeight - Range / 15 Else T = T + MoveInt - If T > ScrHeight - Range / 15 Then T = ScrHeight - Range / 15 - SetWindowPos hwnd, 0, F.Left, T, 0, 0, FRM_NOSIZE - DoEvents - Loop - ElseIf F.Right >= ScrWidth - 5 Then '从右隐藏窗体 - T = F.Right - WinWidth - Do Until T >= ScrWidth - Range / 15 - If MoveInt = 0 Then T = ScrWidth - Range / 15 Else T = T + MoveInt - If T > ScrWidth - Range / 15 Then T = ScrWidth - Range / 15 - SetWindowPos hwnd, 0, T, F.Top, 0, 0, FRM_NOSIZE - DoEvents - Loop - End If - IsInFrm = True + If frm.Top <= 5 Then + Do Until frm.Top <= range - frm.Height '从上隐藏窗体,range为露在外面长度 + frm.Top = frm.Top - 1 + Loop + ElseIf f.Left <= 5 Then + Do Until frm.Left <= range - frm.Width '从左隐藏窗体 + frm.Left = frm.Left - 1 + Loop + ElseIf frm.Top + frm.Height >= Screen.Height - 5 Then '从下隐藏窗体 + Do Until frm.Top >= Screen.Height - range + frm.Top = frm.Top + 1 + Loop + ElseIf frm.Left + frm.Width >= Screen.Width - 5 Then '从右隐藏窗体 + Do Until frm.Left >= Screen.Width - range + frm.Left = frm.Left + 1 + Loop End If End If End If - If IsTop <> IsTopmost(hwnd) Then SetWindowPos hwnd, IsTop, 0, 0, 0, 0, FRM_TOPMOST End Sub - -Public Function IsTopmost(hwnd As Long) As Long '判断窗口置顶函数 - Dim Ret As Long, t1 As Long - Ret = GetWindowLong(hwnd, GWL_EXSTYLE) - t1 = Ret Or WS_EX_TOPMOST - IsTopmost = IIF(Ret = t1, -1, -2) -End Function -'------------------------------------以下为老版本-------------------------------------------------------- -'********************************************************************************************************** -'***过程名：Auto_Hide -'***功 能：窗体靠边自动隐藏 -'***输入值：(窗体名 As Form, 计时器 As Timer, 隐藏后显示部分长度 As Long, 检测间隔 As Long) -'***输出值：NULL -'***说 明：请在窗体中计时器的Timer事件中调用(请手动设置Timer的延时数值) -'********************************************************************************************************** - -'Public Sub Auto_Hide(ByVal Frm As Form, ByVal Tmr As Timer, ByVal Range As Long, ByVal Daily As Long) -' Dim P As POINTAPI -' Dim f As RECT -' Tmr.Enabled = True -' Tmr.Interval = Daily -' GetCursorPos P '得到MOUSE位置 -' GetWindowRect Frm.hwnd, f '得到窗体的位置 -' If Frm.WindowState <> 1 Then -' If P.X >= f.Left And P.X <= f.Right And P.Y >= f.Top And P.Y <= f.Bottom Then -' 'MOUSE 在窗体上 -' If Not IsInFrm Then '如果鼠标之前不在窗体上则继续 -' If Frm.Top <= 0 Then -' Do Until Frm.Top >= 0 '从上显示窗体 -' Frm.Top = Frm.Top + 1 -' Loop -' ElseIf Frm.Left <= 0 Then '从左显示窗体 -' Do Until Frm.Left >= 0 -' Frm.Left = Frm.Left + 1 -' Loop -' ElseIf Frm.Top + Frm.Height >= Screen.Height Then '从下显示窗体 -' Do Until Frm.Top <= Screen.Height - Frm.Height -' Frm.Top = Frm.Top - 1 -' Loop -' ElseIf Frm.Left + Frm.Width >= Screen.Width Then '从右显示窗体 -' Do Until Frm.Left <= Screen.Width - Frm.Width -' Frm.Left = Frm.Left - 1 -' Loop -' End If -' IsInFrm = True -' End If -' Else -' If IsInFrm Then '如果鼠标之前在窗体上则继续 -' If Frm.Top <= 5 Then -' Do Until Frm.Top <= Range - Frm.Height '从上隐藏窗体,range为露在外面长度 -' Frm.Top = Frm.Top - 1 -' Loop -' ElseIf f.Left <= 5 Then -' Do Until Frm.Left <= Range - Frm.Width '从左隐藏窗体 -' Frm.Left = Frm.Left - 1 -' Loop -' ElseIf Frm.Top + Frm.Height >= Screen.Height - 5 Then '从下隐藏窗体 -' Do Until Frm.Top >= Screen.Height - Range -' Frm.Top = Frm.Top + 1 -' Loop -' ElseIf Frm.Left + Frm.Width >= Screen.Width - 5 Then '从右隐藏窗体 -' Do Until Frm.Left >= Screen.Width - Range -' Frm.Left = Frm.Left + 1 -' Loop -' End If -' IsInFrm = False -' End If -' End If -' End If -'End Sub - -'********************************************************************************************************** -'***过程名：Auto_Magnet -'***功 能 ：窗体靠边自动吸附 -'***输入值：(窗体名 As Form, 吸附距离 As Long,[可选，鼠标状态]) -'***输出值：NULL -'***说 明：请在窗体的MouseMove事件中调用 -'********************************************************************************************************** -Public Sub Auto_Magnet(ByVal Frm As Form, ByVal Range As Long, Optional ByVal Button As Integer) 'range是吸附距离 - Dim P As POINTAPI - GetCursorPos P '得到MOUSE位置 - If Button = 1 Then '得到鼠标状态，如果是左键按下则检测鼠标是否在边缘 - If P.X = 0 Then Frm.Left = 0 '鼠标处于屏幕边缘则直接吸附 - If P.Y = 0 Then Frm.Top = 0 - If P.X = Screen.Width Then Frm.Left = Screen.Width - Frm.Width - If P.Y = Screen.Height Then Frm.Top = Screen.Height - Frm.Height - Else - '如果窗体离屏幕距离小于吸附距离则吸附且未到屏幕外，就吸附到屏幕比边缘。 - If Frm.Left < Range And Frm.Left > 0 Then - Frm.Left = 0 '向左吸附 - End If - If Frm.Top < Range And Frm.Top > 0 Then - Frm.Top = 0 '向上吸附 - End If - If Frm.Left + Frm.Width > Screen.Width - Range And Frm.Left + Frm.Width < Screen.Width Then - Frm.Left = Screen.Width - Frm.Width '向右吸附 - End If - If Frm.Top + Frm.Height > Screen.Height - Range And Frm.Top + Frm.Height < Screen.Height Then - Frm.Top = Screen.Height - Frm.Height '向下吸附 - End If - ReleaseCapture +'''========================窗体靠边自动吸附============================ +Public Sub Frm_Auto_Magnet(ByVal frm As Form, ByVal range As Long) 'range是吸附距离 +'如果窗体离屏幕距离小于吸附距离则吸附且未到屏幕外，就吸附到屏幕比边缘。 + If frm.Left < range And frm.Left > 0 Then + frm.Left = 0 '向左吸附 + End If + If frm.Top < range And frm.Top > 0 Then + frm.Top = 0 '向上吸附 + End If + If frm.Left + frm.Width > Screen.Width - range And frm.Left + frm.Width < Screen.Width Then + frm.Left = Screen.Width - frm.Width '向右吸附 + End If + If frm.Top + frm.Height > Screen.Height - range And frm.Top + frm.Height < Screen.Height Then + frm.Top = Screen.Height - frm.Height '向下吸附 End If End Sub - -'********************************************************************************************************** -'***过程名：WindowKiss -'***功 能 ：窗体紧贴(通过窗体句柄) -'***输入值：(被贴窗体句柄 As Long,贴上窗体句柄 As Long) -'***输出值：NULL -'***说 明： -'********************************************************************************************************** -'Public Sub WindowKiss(ByVal Enable As Boolean, Optional ByVal BhWnd As Long, Optional ByVal KhWnd As Long, Optional ByVal SetRect As SetPos, Optional ByVal IsIN As Long, Optional ByVal Daily As Long) -' Ktmr.Enabled = Enable -' Ktmr.Interval = Daily -' Ktmr.Tag = BhWnd & " " & KhWnd & " " & SetRect & " " & IsIN -'End Sub -' -'Private Sub Ktmr_Timer() -' On Error Resume Next -' Dim AWK() As String -' AWK = Split(Ktmr.Tag) -' AutoWindowKiss AWK(0), AWK(1), AWK(2), AWK(3) -'End Sub -Public Sub AutoWindowKiss(ByVal BhWnd As Long, ByVal KhWnd As Long, ByVal SetRect As SetPos, ByVal IsIN As Boolean, ByVal IsTop As Boolean) - Dim B As RECT - Dim k As RECT - Dim BH As Long - Dim BW As Long - Dim KH As Long - Dim KW As Long - Dim BHK As Long - Dim BWK As Long - Dim Frm_ST As Long - If IsTop Then Frm_ST = -1 Else Frm_ST = -2 - GetWindowRect BhWnd, B - GetWindowRect KhWnd, k - BH = B.Bottom - B.Top - BW = B.Right - B.Left - KH = k.Bottom - k.Top - KW = k.Right - k.Left - BHK = Abs(BH - KH) / 2 - BWK = Abs(BW - KW) / 2 - Select Case SetRect - Case SpTop - If IsIN Then - SetWindowPos KhWnd, Frm_ST, B.Left + BWK, B.Top, 0, 0, FRM_NOSIZE - Else - SetWindowPos KhWnd, Frm_ST, B.Left + BWK, B.Top - KH, 0, 0, FRM_NOSIZE - End If - Case SPButton - If IsIN Then - SetWindowPos KhWnd, Frm_ST, B.Left + BWK, B.Bottom - KH, 0, 0, FRM_NOSIZE - Else - SetWindowPos KhWnd, Frm_ST, B.Left + BWK, B.Bottom, 0, 0, FRM_NOSIZE - End If - Case SpLeft - If IsIN Then - SetWindowPos KhWnd, Frm_ST, B.Left, B.Top, 0, 0, FRM_NOSIZE - Else - SetWindowPos KhWnd, Frm_ST, B.Left - KW, B.Top, 0, 0, FRM_NOSIZE - End If - Case SPRight - If IsIN Then - SetWindowPos KhWnd, Frm_ST, B.Left - KW, B.Top, 0, 0, FRM_NOSIZE - Else - SetWindowPos KhWnd, Frm_ST, B.Left, B.Top, 0, 0, FRM_NOSIZE - End If - End Select - +'========================全屏窗口移动============================ +Public Sub Frm_Move(ByVal hWnd As Long) + ReleaseCapture + SendMessage hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0& End Sub - -'********************************************************************************************************** -'***过程名：hMove -'***功 能 ：全屏窗口移动(通过窗体句柄) -'***输入值：(窗体句柄 As Long) -'***输出值：NULL -'***说 明：请在窗体的MouseDown事件中调用，窗体中用Me.hWnd代表窗体句柄 -'********************************************************************************************************** -Public Sub hMove(ByVal hwnd As Long) - ReleaseCapture '从当前线程中的窗口释放鼠标捕获，并恢复通常的鼠标输入处理。 - SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0& '移动窗体 -End Sub -'********************************************************************************************************** -'***过程名：fMove -'***功 能 ：全屏窗口移动(通过窗体移动) -'***输入值：(窗体 As Form, Button As Integer, Shift As Integer, X As Single, Y As Single) -'***输出值：NULL -'***说 明：请在窗体的MouseMove事件中调用，窗体中用Me代表窗体，剩下的直接用Button, Shift, X, Y -'********************************************************************************************************** -Public Sub fMove(Frm As Form, Button As Integer, Shift As Integer, X As Single, Y As Single) - On Error Resume Next - Static nX&, nY& - If Button = 1 Then - Frm.Move Frm.Left - nX + X, Frm.Top - nY + Y - Button = 0 - Else - nX = X - nY = Y - End If -End Sub -'********************************************************************************************************** -'***函数名：GetTitle -'***功 能 ：获取窗体标题(通过窗体句柄) -'***输入值：(窗体句柄 As Long) -'***输出值：窗体标题 As String -'********************************************************************************************************** -Public Function GetTitle(ByVal hwnd As Long) As String '得到窗体标题 - Dim StrText As String * 256 '定义一个指针获得字符串 - Dim cch As Long '定义一个参数获取字符串长度 - cch = GetWindowText(hwnd, StrText, 256) '获取窗体标题 - GetTitle = Left(StrText, cch) '根据长度截取标题 -End Function -'********************************************************************************************************** -'***过程名：SetTitle -'***功 能 ：设置窗体标题(通过窗体句柄) -'***输入值：(窗体句柄 As Long, 窗体标题 As String) -'***输出值：NULL -'********************************************************************************************************** -Public Sub SetTitle(ByVal hwnd As Long, ByVal TitleStr As String) '设置窗体标题 - SetWindowText hwnd, TitleStr '设置窗体标题 -End Sub -'********************************************************************************************************** -'***函数名：GetFedWnd -'***功 能 ：获取激活窗体句柄 -'***输入值：NULL -'***输出值：当前激活窗体的句柄 As Long -'********************************************************************************************************** -Public Function GetFedWnd() As Long - GetFedWnd = GetForegroundWindow '得到当前窗体句柄 -End Function -'********************************************************************************************************** -'***过程名：SetFedWnd -'***功 能 ：激活窗体(通过窗体句柄) -'***输入值：(窗体句柄 As Long) -'***输出值：NULL -'********************************************************************************************************** -Public Sub SetFedWnd(ByVal hwnd As Long) - SetForegroundWindow hwnd '设置句柄为激活窗体 -End Sub -'##########################################保持窗体控件原有大小比例############################################# -'********************************************************************************************************** -'***过程名：GetFrmSize -'***功 能 ：获取原有窗体控件大小 -'***输入值：Null -'***输出值：NULL -'***说 明：请在窗体的Load事件中调用，并且控件需在窗体上 -'********************************************************************************************************** -Public Sub GetFrmSize() 'FormName As Form) - On Error Resume Next - Dim FormName As Form - Set FormName = UserControl.Parent '获得父窗体 - Dim obj As Control '定义一个控件数组 - FormName.ScaleWidth = 1000 '设置窗体水平度量单位数 - FormName.ScaleHeight = 1000 '设置窗体垂直度量单位数 - For Each obj In FormName '遍历所有控件 - obj.Tag = Str(obj.Left) & Str(obj.Top) & Str(obj.Width) & Str(obj.Height) '存储空间度量位置到Tag - Next obj - On Error GoTo 0 -End Sub -'********************************************************************************************************** -'***过程名：SetFrmSize -'***功 能 ：根据窗体大小调整控件大小 -'***输入值：Null -'***输出值：NULL -'***说 明：请在窗体的Resize事件中调用，并且控件需在窗体上 -'********************************************************************************************************** -Public Sub SetFrmSize() 'Optional FormName As Form = UserControl.Parent) - On Error Resume Next - Dim FormName As Form - Dim Pos() As String - Dim obj As Control - Set FormName = UserControl.Parent '获得父窗体 - FormName.ScaleWidth = 1000 '设置窗体水平度量单位数 - FormName.ScaleHeight = 1000 '设置窗体垂直度量单位数 - For Each obj In FormName '遍历所有控件 - Pos = Split(obj.Tag) ' - obj.Left = Val(Pos(1)) '调整 - obj.Top = Val(Pos(2)) '控件 - obj.Width = Val(Pos(3)) '位置 - obj.Height = Val(Pos(4)) '大小 - Next obj - On Error GoTo 0 -End Sub -'##########################################保持窗体控件原有大小比例############################################# - -'##########################################窗口句柄后台按键############################################# -'********************************************************************************************************** -'***过程名：KeyNum2Key -'***功 能 ：根据按键码返回按键信息 -'***输入值：(按键码 As long) -'***输出值：按键信息 As String -'***说 明： -'********************************************************************************************************** -Public Function KeyNum2Key(ByVal KeyNum As Long) As String -'Debug.Print KeyNum - Select Case KeyNum - Case vbKeyLButton: KeyNum2Key = "鼠标左键" - Case vbKeyRButton: KeyNum2Key = "鼠标右键" - Case vbKeyCancel: KeyNum2Key = "CANCEL" - Case vbKeyMButton: KeyNum2Key = "鼠标中键" - Case 5: KeyNum2Key = "鼠标扩展键1" - Case 6: KeyNum2Key = "鼠标扩展键2" - Case vbKeyBack: KeyNum2Key = "退格键" '"BACKSPACE" - Case vbKeyTab: KeyNum2Key = "TAB" - Case vbKeyClear: KeyNum2Key = "CLEAR" - Case vbKeyReturn: KeyNum2Key = "ENTER" - Case vbKeyShift: KeyNum2Key = "SHIFT" - Case vbKeyControl: KeyNum2Key = "CTRL" - Case vbKeyMenu: KeyNum2Key = "MENU" - Case vbKeyPause: KeyNum2Key = "PAUSE" - Case vbKeyCapital: KeyNum2Key = "CAPS LOCK" - Case vbKeyEscape: KeyNum2Key = "ESC" - Case vbKeySpace: KeyNum2Key = "SPACEBAR" - Case vbKeyPageUp: KeyNum2Key = "PAGE UP" - Case vbKeyPageDown: KeyNum2Key = "PAGE DN" - Case vbKeyEnd: KeyNum2Key = "END" - Case vbKeyHome: KeyNum2Key = "HOME" - Case vbKeyLeft: KeyNum2Key = "←" '"LEFT ARROW" - Case vbKeyUp: KeyNum2Key = "↑" '"UP ARROW" - Case vbKeyRight: KeyNum2Key = "→" '"RIGHT ARROW" - Case vbKeyDown: KeyNum2Key = "↓" '"DOWN ARROW" - Case vbKeySelect: KeyNum2Key = "SELECT" - Case vbKeyPrint: KeyNum2Key = "PRINT SCREEN" - Case vbKeyExecute: KeyNum2Key = "EXECUTE" - Case vbKeySnapshot: KeyNum2Key = "SNAPSHOT" - Case vbKeyDelete: KeyNum2Key = "DELETE" - Case vbKeyHelp: KeyNum2Key = "HELP" - Case vbKeyNumlock: KeyNum2Key = "NUM LOCK" - Case vbKeyNumpad0: KeyNum2Key = "Num 0" - Case vbKeyNumpad1: KeyNum2Key = "Num 1" - Case vbKeyNumpad2: KeyNum2Key = "Num 2" - Case vbKeyNumpad3: KeyNum2Key = "Num 3" - Case vbKeyNumpad4: KeyNum2Key = "Num 4" - Case vbKeyNumpad5: KeyNum2Key = "Num 5" - Case vbKeyNumpad6: KeyNum2Key = "Num 6" - Case vbKeyNumpad7: KeyNum2Key = "Num 7" - Case vbKeyNumpad8: KeyNum2Key = "Num 8" - Case vbKeyNumpad9: KeyNum2Key = "Num 9" - Case vbKeyMultiply: KeyNum2Key = "MULTIPLICATIONSIGN(*)" - Case vbKeyAdd: KeyNum2Key = "PLUSSIGN(+)" - Case vbKeySeparator: KeyNum2Key = "ENTER" - Case vbKeySubtract: KeyNum2Key = "MINUSSIGN(-)" - Case vbKeyDecimal: KeyNum2Key = "DECIMALPOINT(.)" - Case vbKeyDivide: KeyNum2Key = "DIVISIONSIGN(/)" - Case vbKeyF1: KeyNum2Key = "F1" - Case vbKeyF2: KeyNum2Key = "F2" - Case vbKeyF3: KeyNum2Key = "F3" - Case vbKeyF4: KeyNum2Key = "F4" - Case vbKeyF5: KeyNum2Key = "F5" - Case vbKeyF6: KeyNum2Key = "F6" - Case vbKeyF7: KeyNum2Key = "F7" - Case vbKeyF8: KeyNum2Key = "F8" - Case vbKeyF9: KeyNum2Key = "F9" - Case vbKeyF10: KeyNum2Key = "F10" - Case vbKeyF11: KeyNum2Key = "F11" - Case vbKeyF12: KeyNum2Key = "F12" - Case 91: KeyNum2Key = "Win" - Case 93: KeyNum2Key = "Menu" - Case 160: KeyNum2Key = "左SHIFT" - Case 161: KeyNum2Key = "右SHIFT" - Case 162: KeyNum2Key = "左CTRL" - Case 163: KeyNum2Key = "右CTRL" - Case 164: KeyNum2Key = "左AIT" - Case 165: KeyNum2Key = "右AIT" - - Case 186: KeyNum2Key = ";" - Case 187: KeyNum2Key = "=" - Case 188: KeyNum2Key = "," - Case 189: KeyNum2Key = "-" - Case 190: KeyNum2Key = "." - Case 191: KeyNum2Key = "/" - Case 192: KeyNum2Key = "~" - - Case 219: KeyNum2Key = "[" - Case 220: KeyNum2Key = "\" - Case 221: KeyNum2Key = "]" - Case 222: KeyNum2Key = "'" - Case Else: KeyNum2Key = Chr(KeyNum) - End Select -End Function -'********************************************************************************************************** -'***过程名：MakeKeyLparam -'***功 能 ：制作按键扫描码 -'***输入值：(按键码 As long,按键模式 As Long) -'***输出值：按键扫描码 As String -'***说 明：用于游戏中的扫描码，不然有些游戏窗体收不到消息 -'********************************************************************************************************** -Private Function MakeKeyLparam(ByVal VirtualKey As Long, ByVal flag As Long) As Long - Dim S As String - Dim Firstbyte As String 'lparam参数的24-31位 - If flag = WM_KEYDOWN Then '如果是按下键 - Firstbyte = "00" - Else - Firstbyte = "C0" '如果是释放键 - End If - Dim Scancode As Long - '获得键的扫描码 - - 'Debug.Print "========" & VirtualKey & "=========" - Scancode = MapVirtualKey(VirtualKey, 0) - 'Debug.Print Scancode - Dim Secondbyte As String 'lparam参数的16-23位，即虚拟键扫描码 - Secondbyte = Right("00" & Hex(Scancode), 2) - 'Debug.Print Secondbyte - S = Firstbyte & Secondbyte & "0001" '0001为lparam参数的0-15位，即发送次数和其它扩展信息 - 'Debug.Print "&H" & s - MakeKeyLparam = Val("&H" & S) -End Function -'********************************************************************************************************** -'***过程名：hWndKeyDown -'***功 能 ：后台按下键 -'***输入值：(窗体句柄 As Long, 按键码 As Long, [按键模式 As KeyPressMode = Normal]) -'***输出值：Null -'***说 明：用于后台按下按键 -'********************************************************************************************************** -Public Sub hWndKeyDown(ByVal hwnd As Long, ByVal KeyCode As Long, Optional ByVal PressKeyMode As KeyPressMode = Normal) - Select Case PressKeyMode - Case Normal - PostMessage hwnd, WM_KEYDOWN, KeyCode, 0 '释放A键 - Case System - PostMessage hwnd, WM_KEYDOWN, KeyCode, 0 '按下A键 - Case GameMode - PostMessage hwnd, WM_KEYDOWN, KeyCode, MakeKeyLparam(KeyCode, WM_KEYDOWN) '按下A键 - End Select -End Sub -'********************************************************************************************************** -'***过程名：hWndKeyUp -'***功 能 ：后台释放键 -'***输入值：(窗体句柄 As Long, 按键码 As Long, [按键模式 As KeyPressMode = Normal]) -'***输出值：Null -'***说 明：用于后台释放按键 -'********************************************************************************************************** -Public Sub hWndKeyUp(ByVal hwnd As Long, ByVal KeyCode As Long, Optional ByVal PressKeyMode As KeyPressMode = Normal) - Select Case PressKeyMode - Case Normal - PostMessage hwnd, WM_KEYUP, KeyCode, 0 '释放A键 - Case System - PostMessage hwnd, WM_KEYUP, KeyCode, 0 '释放A键 - Case GameMode - PostMessage hwnd, WM_KEYUP, KeyCode, MakeKeyLparam(KeyCode, WM_KEYUP) '释放A键 - End Select -End Sub -'********************************************************************************************************** -'***过程名：hWndKeyPress -'***功 能 ：后台按键 -'***输入值：(窗体句柄 As Long, 按键码 As Long, [按键模式 As KeyPressMode = Normal]) -'***输出值：Null -'***说 明：用于后台按键 -'********************************************************************************************************** -Public Sub hWndKeyPress(ByVal hwnd As Long, ByVal KeyCode As Long, Optional ByVal PressKeyMode As KeyPressMode = Normal) - Select Case PressKeyMode - Case Normal - PostMessage hwnd, WM_CHAR, KeyCode, 0 '按A键 - Case System - PostMessage hwnd, WM_KEYDOWN, KeyCode, 0 - PostMessage hwnd, WM_KEYUP, KeyCode, 0 - Case GameMode - PostMessage hwnd, WM_KEYDOWN, KeyCode, MakeKeyLparam(KeyCode, WM_KEYDOWN) - PostMessage hwnd, WM_KEYUP, KeyCode, MakeKeyLparam(KeyCode, WM_KEYUP) - End Select -End Sub -'##########################################窗口句柄后台按键############################################# -'********************************************************************************************************** -'***过程名：GetMouseWindowhWnd() -'***功 能 ：获取鼠标所在窗体句柄 -'***输入值：Null -'***输出值：窗体句柄 As Long -'***说 明：用于获取窗体句柄 -'********************************************************************************************************** -Public Function GetMouseWindowhWnd() As Long - Dim Point As POINTAPI - GetCursorPos Point - GetMouseWindowhWnd = WindowFromPoint(Point.X, Point.Y) -End Function -'********************************************************************************************************** -'***过程名：GetClassName() -'***功 能 ：获取窗体类名 -'***输入值：(窗体句柄 As Long) -'***输出值：窗体类名 As String -'***说 明：用于获取窗体类名 -'********************************************************************************************************** -Public Function GetClassName(ByVal hwnd As Long) As String +'''===========================窗体标题=========================== +Public Function Frm_Title_Get(ByVal hWnd As Long) As String '得到窗体标题 Dim StrText As String * 256 Dim cch As Long - cch = GetClassNameh(hwnd, StrText, 256) - GetClassName = Left(StrText, cch) + cch = GetWindowText(hWnd, StrText, 256) + Frm_Title_Get = Left(StrText, cch) End Function -'********************************************************************************************************** -'***过程名：GetIconhWnd() -'***功 能 ：获取窗体图标句柄 -'***输入值：窗体句柄 As Long -'***输出值：窗体图标句柄 As Long -'***说 明：用于获取窗体图标句柄 -'********************************************************************************************************** -Public Function GetIconhWnd(ByVal hwnd As Long) As Long - GetIconhWnd = GetClassLong(hwnd, -14) +Public Sub Frm_Title_Set(ByVal hWnd As Long, ByVal TitleStr As String) '设置窗体标题 + SetWindowText hWnd, TitleStr +End Sub +'''===========================窗体类名=========================== +Public Function Frm_ClassName_Get(ByVal hWnd As Long) As String + Dim StrText As String * 256 + Dim cch As Long + cch = GetClassName(hWnd, StrText, 256) + Frm_ClassName_Get = Left(StrText, cch) End Function -'********************************************************************************************************** -'***过程名：GetWindowhWnd() -'***功 能 ：通过类名标题查找窗体 -'***输入值：(窗体标题 As String,窗体类名 As String) -'***输出值：找到的窗体的句柄 As Long -'***说 明：用于获取窗体句柄 -'********************************************************************************************************** -Public Function GetWindowhWnd(ByVal Title As String, ByVal Class As String) As Long - GetWindowhWnd = FindWindow(Class, Title) +'''===========================窗体图标句柄=========================== +Public Function Frm_GetIconhWnd(ByVal hWnd As Long) As Long + Frm_GetIconhWnd = GetClassLong(hWnd, -14) End Function -'********************************************************************************************************** -'***过程名：GethWndByTitle() -'***功 能 ：通过标题查找窗体 -'***输入值：(窗体标题 As String) -'***输出值：找到的窗体的句柄 As Long -'***说 明：用于获取窗体句柄 -'********************************************************************************************************** -Public Function GethWndByTitle(ByVal Title As String) As Long - GethWndByTitle = FindWindow(vbNullString, Title) +'''===========================通过标题查找句柄=========================== +Public Function Frm_GethWndByTitle(ByVal Title As String) As Long + Frm_GethWndByTitle = FindWindow(vbNullString, Title) End Function -'********************************************************************************************************** -'***过程名：GethWndByTitleEx() -'***功 能 ：通过标题查找窗体 -'***输入值：(窗体标题 As String) -'***输出值：找到的窗体的句柄As Long -'***说 明：用于获取窗体句柄 -'********************************************************************************************************** -'Public Function GethWndByTitleEx(ByVal Title As String) As Long -' GethWndByTitleEx = FindWindowEx(0, 0, vbNullString, Title) -'End Function -'********************************************************************************************************** -'***过程名：GethWndByClass() -'***功 能 ：通过类名查找窗体 -'***输入值：(窗体类名 As String) -'***输出值：找到的窗体的句柄 As Long -'***说 明：用于获取窗体句柄 -'********************************************************************************************************** -Public Function GethWndByClass(ByVal Class As String) As Long - GethWndByClass = FindWindow(Class, vbNullString) +'''===========================通过类名查找句柄=========================== +Public Function Frm_GethWndByClass(ByVal Class As String) As Long + Frm_GethWndByClass = FindWindow(Class, vbNullString) End Function -'********************************************************************************************************** -'***过程名：GethWndByClassEx() -'***功 能 ：通过类名查找窗体 -'***输入值：(窗体类名 As String) -'***输出值：找到的窗体的句柄As Long -'***说 明：用于获取窗体句柄 -'********************************************************************************************************** -Public Function GethWndByClassEx(ByVal Class As String) - Dim hwnd As Long - Dim AllhWnd As String - hwnd = FindWindowEx(0, 0, Class, vbNullString) - Do While hwnd <> 0 - AllhWnd = hwnd & "|" & AllhWnd - hwnd = FindWindowEx(0, 0, Class, vbNullString) - Loop - GethWndByClassEx = Split(AllhWnd, "|") +'''===========================通过标题查找句柄(扩展)=========================== +Public Function Frm_GethWndByTitleEx(ByVal Title As String) As Long + Frm_GethWndByTitleEx = FindWindowEx(0, 0, vbNullString, Title) End Function -Public Function FindClassEx(ByVal hwnd As Long, ByVal Class As String) - FindClassEx = FindWindowEx(0, hwnd, Class, vbNullString) +'''===========================加载真彩图标=========================== +Public Function Frm_RGBAIcon(ByVal hWnd As Long, ByVal hIcon As Long) As Long + Frm_RGBAIcon = SendMessage(hWnd, WM_SETICON, 0, hIcon) End Function -'********************************************************************************************************** -'***过程名：GethWndByClassEx() -'***功 能 ：窗口加载真彩图标 -'***输入值：(窗体句柄 As Long，图标句柄 As Long) -'***输出值：未知 -'***说 明：用于加载真彩图标 -'********************************************************************************************************** -'''===========================窗口加载真彩图标=========================== -Public Function RGBAIcon(ByVal hwnd As Long, ByVal hIcon As Long) As Long - RGBAIcon = SendMessage(hwnd, WM_SETICON, 0, hIcon) +'''===========================激活窗体=========================== +Public Function Frm_GetFedWnd() As Long '得到当前窗体句柄 + Frm_GetFedWnd = GetForegroundWindow End Function -'********************************************************************************************************** -'***过程名：Sleep() -'***功 能 ：延时 -'***输入值：(延时大小 As Long[毫秒]) -'***输出值：Null -'***说 明：用于延时 -'********************************************************************************************************** -Public Sub Sleep(n As Long) +Public Sub Frm_SetFedWnd(ByVal hWnd As Long) '设置句柄为激活窗体 + SetForegroundWindow hWnd +End Sub + +Public Sub Frm_ResizeGet(FormName As Form) + Dim Obj As Control + FormOldWidth = FormName.ScaleWidth + FormOldHeight = FormName.ScaleHeight + On Error Resume Next + For Each Obj In FormName + Obj.Tag = Obj.Left & " " & Obj.Top & " " & Obj.Width & " " & Obj.Height & " " + Next Obj + On Error GoTo 0 +End Sub + +Public Sub ResizeForm(FormName As Form) + Dim Pos(4) As Double + Dim I As Long, TempPos As Long, StartPos As Long + Dim Obj As Control + Dim ScaleX As Double, ScaleY As Double + ScaleX = FormName.ScaleWidth / FormOldWidth '保存窗体宽度缩放比例 + ScaleY = FormName.ScaleHeight / FormOldHeight '保存窗体高度缩放比例 + On Error Resume Next + For Each Obj In FormName + StartPos = 1 + For I = 0 To 4 '读取控件的原始位置与大小 + TempPos = InStr(StartPos, Obj.Tag, " ", vbTextCompare) + If TempPos > 0 Then + Pos(I) = Mid(Obj.Tag, StartPos, TempPos - StartPos) + StartPos = TempPos + 1 + Else + Pos(I) = 0 + End If '根据控件的原始位置及窗体改变大小的比例对控件重新定位与改变大小 + Obj.Move Pos(0) * ScaleX, Pos(1) * ScaleY, Pos(2) * ScaleX, Pos(3) * ScaleY + Next I + Next Obj + On Error GoTo 0 +End Sub + + +'''===========================延时函数=========================== +Private Sub Sleep(n As Long) Savetime = timeGetTime While timeGetTime < Savetime + n DoEvents Wend End Sub -'''===========================禁止改变控件大小=========================== -Private Sub UserControl_Resize() - UserControl.Parent.Controls(UserControl.Ambient.DisplayName).Visible = False '默认隐藏此控件 - UserControl.Height = 240 '默认高度 - UserControl.Width = 240 '默认宽度 -End Sub -'#############################################控件函数模块################################################# + diff --git a/HttpHelper.bas b/HttpHelper.bas new file mode 100644 index 0000000..ee63746 --- /dev/null +++ b/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 + + diff --git a/JsonUtils.bas b/JsonUtils.bas new file mode 100644 index 0000000..98257d0 --- /dev/null +++ b/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 diff --git a/System.bas b/System.bas new file mode 100644 index 0000000..3e07966 --- /dev/null +++ b/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