345 lines
14 KiB
QBasic
345 lines
14 KiB
QBasic
Attribute VB_Name = "Frm_Tools"
|
||
'#######################################模块说明#########################################
|
||
|
||
'名称:窗体工具
|
||
|
||
'功能:实现VB窗体透明，移动，靠边隐藏等功能
|
||
|
||
'最后更新日期:2014年5月14日
|
||
|
||
'创建人:蒋天蓓
|
||
|
||
'单位:上海市定海水电工程安装有限公司
|
||
|
||
''====================================模块使用说明=======================================
|
||
'****************************************************
|
||
'窗体透明：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
|
||
''================================保持窗体控件原有大小比例=========================================
|
||
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 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 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_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 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 '获取窗体位置
|
||
Left As Long
|
||
Top As Long
|
||
Right As Long
|
||
Bottom As Long
|
||
End Type
|
||
Private Type POINTAPI '获取鼠标位置
|
||
x As Long
|
||
y As Long
|
||
End Type
|
||
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 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 GWL_EXSTYLE = (-20)
|
||
Private Const LWA_ALPHA = &H2
|
||
Private Const LWA_COLORKEY = &H1
|
||
|
||
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
|
||
Private Savetime As Double
|
||
''#####################################################模块代码#####################################################
|
||
'''========================窗体透明============================
|
||
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
|
||
Dim rtn As Long
|
||
rtn = GetWindowLong(hWnd, GWL_EXSTYLE) '取得窗体句柄
|
||
rtn = rtn Or WS_EX_LAYERED
|
||
SetWindowLong hWnd, GWL_EXSTYLE, rtn
|
||
SetLayeredWindowAttributes hWnd, TransColor, range * 2.55, LWA_ALPHA '设置窗体透明度
|
||
End Sub
|
||
'''========================窗体透明延时显示============================
|
||
Public Sub Frm_Daily_Tpt(ByVal Mode As Boolean, ByVal hWnd As Long, ByVal range As Integer, Daily As Long)
|
||
'Mode = True '显示窗体
|
||
'Mode = False '隐藏窗体
|
||
Daily = Daily * 10
|
||
Dim Tpti
|
||
If Mode = True Then
|
||
Do Until Tpti > range
|
||
Tpti = Tpti + 1
|
||
Sleep Daily
|
||
Frm_Tpt hWnd, Tpti
|
||
Loop
|
||
Else
|
||
Tpti = range
|
||
Do Until Tpti < 0
|
||
Tpti = Tpti - 1
|
||
Sleep Daily
|
||
Frm_Tpt hWnd, Tpti
|
||
Loop
|
||
End If
|
||
End Sub
|
||
'''========================窗体大小延时显示============================
|
||
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
|
||
Sleep 10
|
||
frm.Width = I
|
||
frm.Show
|
||
Next
|
||
|
||
For I = 20 To h Step Daily
|
||
Sleep 10
|
||
frm.Height = I
|
||
frm.Show
|
||
Next
|
||
|
||
End Sub
|
||
''================================窗口置顶函数=========================================
|
||
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
|
||
Else
|
||
SetWindowPos hWnd, FRM_NORMAL, 0, 0, 0, 0, FRM_TOPMOST
|
||
End If
|
||
End Sub
|
||
|
||
Public Sub Frm_Show(ByVal hWnd As Long)
|
||
SetWindowPos hWnd, 0, 0, 0, 0, 0, FRM_SHOWWINDOW Or FRM_TOPMOST
|
||
End Sub
|
||
|
||
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
|
||
|
||
End If
|
||
Else
|
||
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
|
||
End Sub
|
||
'''========================窗体靠边自动吸附============================
|
||
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
|
||
'========================全屏窗口移动============================
|
||
Public Sub Frm_Move(ByVal hWnd As Long)
|
||
ReleaseCapture
|
||
SendMessage hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
|
||
End Sub
|
||
'''===========================窗体标题===========================
|
||
Public Function Frm_Title_Get(ByVal hWnd As Long) As String '得到窗体标题
|
||
Dim StrText As String * 256
|
||
Dim cch As Long
|
||
cch = GetWindowText(hWnd, StrText, 256)
|
||
Frm_Title_Get = Left(StrText, cch)
|
||
End Function
|
||
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
|
||
'''===========================窗体图标句柄===========================
|
||
Public Function Frm_GetIconhWnd(ByVal hWnd As Long) As Long
|
||
Frm_GetIconhWnd = GetClassLong(hWnd, -14)
|
||
End Function
|
||
'''===========================通过标题查找句柄===========================
|
||
Public Function Frm_GethWndByTitle(ByVal Title As String) As Long
|
||
Frm_GethWndByTitle = FindWindow(vbNullString, Title)
|
||
End Function
|
||
'''===========================通过类名查找句柄===========================
|
||
Public Function Frm_GethWndByClass(ByVal Class As String) As Long
|
||
Frm_GethWndByClass = FindWindow(Class, vbNullString)
|
||
End Function
|
||
'''===========================通过标题查找句柄(扩展)===========================
|
||
Public Function Frm_GethWndByTitleEx(ByVal Title As String) As Long
|
||
Frm_GethWndByTitleEx = FindWindowEx(0, 0, vbNullString, Title)
|
||
End Function
|
||
|
||
'''===========================加载真彩图标===========================
|
||
Public Function Frm_RGBAIcon(ByVal hWnd As Long, ByVal hIcon As Long) As Long
|
||
Frm_RGBAIcon = SendMessage(hWnd, WM_SETICON, 0, hIcon)
|
||
End Function
|
||
'''===========================激活窗体===========================
|
||
Public Function Frm_GetFedWnd() As Long '得到当前窗体句柄
|
||
Frm_GetFedWnd = GetForegroundWindow
|
||
End Function
|
||
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
|
||
|
||
|