502647092/VBFunctionBas
1
0
Fork 0
mirror of https://e.coding.net/circlecloud/VBFunctionBas.git synced 2024-10-31 22:38:50 +00:00
Code Releases Activity
master
VBFunctionBas/Frm_Tools.bas
502647092 b4d8728830 update... 
Signed-off-by: 502647092 <jtb1@163.com>
2016-01-24 22:48:49 +08:00

1076 lines
52 KiB
QBasic
Raw Permalink Blame History

This file contains ambiguous Unicode characters

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

Attribute VB_Name = "Frm_Tools"
'#######################################用户控件说明#########################################
'名称:窗体控件
'功能:实现窗体透明，移动，靠边隐藏等功能
'最后更新日期:2014年6月5日
'创建人: 喵♂呜
'单位:上海市定海水电工程安装有限公司
''====================================用户控件使用说明=======================================
'窗体靠边自动隐藏: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])
'#######################################用户控件说明#########################################
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 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 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 Const FRM_NOZEROER = &H4
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_NOCOPYBITS = &H100
Private Const FRM_NOOWNERZORDER = &H200
Private Const FRM_NOSENDCHANGING = &H400
'========================全屏窗口移动============================
Private Declare Function ReleaseCapture Lib "user32" () 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 '获取窗体位置
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
End Type
Private IsInFrm As Boolean '检测窗体与鼠标状态。防止窗体闪烁
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 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"
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 As Form, Rng As Long) As Long
Dim FRng As Long
Dim w As Long
Dim h As Long
w = Frm.ScaleX(Frm.Width, vbTwips, vbPixels)
h = Frm.ScaleY(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 As Form, Rng As Long) As Long
Dim FRng As Long
Dim w As Long
Dim h As Long
w = Frm.ScaleX(Frm.Width, vbTwips, vbPixels)
h = Frm.ScaleY(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 = 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
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)
'Mode = True '显示窗体
'Mode = False '隐藏窗体
If Daily > 5 Then Daily = 5 '防止参数过大，导致显示异常缓慢
If Daily <= 0 Then Daily = 0.1
Daily = Daily * 10
Dim Tpti As Integer
If Mode = True Then
Do Until Tpti > Range
Tpti = Tpti + AddTpt
Sleep Daily
Tpt hWnd, Tpti
Loop
Else
Tpti = Range
Do Until Tpti < 0
Tpti = Tpti - AddTpt
Sleep Daily
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)
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
Sleep 10
Frm.Width = i
Frm.Refresh
Next
For i = 20 To h Step Daily
Sleep 10
Frm.Height = i
Frm.Refresh
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)
If Mode Then
SetWindowPos hWnd, FRM_TOP, 0, 0, 0, 0, FRM_TOPMOST '置顶
Else
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
'End Sub
'
'Private Sub Tim_Timer()
' Dim info
' info = Split(Tim.Tag)
' Auto_Hide_Load Val(info(0)), Val(info(1)), Val(info(2))
'End Sub
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
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
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
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 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(FormName As Form) 'Optional FormName As Form = UserControl.Parent)
On Error Resume Next
Dim Pos() As String
Dim obj As Control
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
Dim StrText As String * 256
Dim cch As Long
cch = GetClassNameh(hWnd, StrText, 256)
GetClassName = Left(StrText, cch)
End Function
'**********************************************************************************************************
'***过程名：GetIconhWnd()
'***功 能 ：获取窗体图标句柄
'***输入值：窗体句柄 As Long
'***输出值：窗体图标句柄 As Long
'***说 明：用于获取窗体图标句柄
'**********************************************************************************************************
Public Function GetIconhWnd(ByVal hWnd As Long) As Long
GetIconhWnd = GetClassLong(hWnd, -14)
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)
End Function
'**********************************************************************************************************
'***过程名：GethWndByTitle()
'***功 能 ：通过标题查找窗体
'***输入值：(窗体标题 As String)
'***输出值：找到的窗体的句柄 As Long
'***说 明：用于获取窗体句柄
'**********************************************************************************************************
Public Function GethWndByTitle(ByVal Title As String) As Long
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)
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, "|")
End Function
Public Function FindClassEx(ByVal hWnd As Long, ByVal Class As String)
FindClassEx = FindWindowEx(0, hWnd, Class, vbNullString)
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)
End Function
'**********************************************************************************************************
'***过程名：Sleep()
'***功 能 ：延时
'***输入值：(延时大小 As Long[毫秒])
'***输出值：Null
'***说 明：用于延时
'**********************************************************************************************************
Public Sub Sleep(n As Long)
Savetime = timeGetTime
While timeGetTime < Savetime + n
DoEvents
Wend
End Sub
'#############################################控件函数模块#################################################
View Git Blame Copy Permalink