目录1.效果演示2.功能介绍3.实现过程3.1.鼠标滑过客户区时窗口变不透明3.2.鼠标滑出客户区时变透明3.3.鼠标滑过非客户区时变不透明3.4.鼠标滑出非客户区时变透明4.完整源码5.相关合集1.效果演示晚间正在做一个完整的公众号合集针对对话框#32770专门教学如何完善各项功能、如何优化使用体验等内容让大家在写自己的窗口项目时能够有所借鉴。2.功能介绍鼠标滑出时窗口变透明鼠标滑过时变不透明。3.实现过程如何检测鼠标在某个窗口上停留或离开本篇文章是用TrackMouseEvent函数解决此问题的同时拓展出了“让对话框窗口在鼠标滑出时变透明”功能以便让对话框窗口在视觉上有更明显的焦点效果。注意本文还涉及子类化技术和窗口消息WM_NCHITTEST的应用。如果你正在研究相关内容不妨继续看下去3.1.鼠标滑过客户区时窗口变不透明使用过VBA窗体UserForm的小伙伴基本都知道这个WM_MOUSEMOVE鼠标移动是窗口客户区的移动通知它会随着鼠标移动不停的产生。但本文的透明化需求是一次性的当鼠标在窗口内移动时只需要设置一次不透明效果就行当鼠标移动到窗口外再设置一次透明化效果。因此我们可以先创建一个全局变量Ud.IsMouseMove用于记录鼠标是否在窗口内。Ud.IsMouseMove的类型为Boolean返回True代表鼠标在窗口内False则在窗口外。所以我们仅在首个WM_MOUSEMOVE通知中设置窗口不透明效果先判断全局变量Ud.IsMouseMove仅当值为False时才执行代码随后将其立即变为True这样以后的每一个WM_MOUSEMOVE通知都不会再重复执行。3.2.鼠标滑出客户区时变透明在添加鼠标跟踪后若鼠标离开客户区就会产生WM_MOUSELEAVE通知。此时要注意鼠标从窗口的灰色空白区域移动至窗口标题栏和边框甚至窗口以外的地方等都算离开客户区。此时在添加WM_NCHITTEST消息进行判断时我们可以这样做仅当判断结果表明鼠标离开位置是在窗口以外的地方时才将窗口变透明。这里的WM_NCHITTEST消息返回值等于HTNOWHERE和HTBORDER就行。3.3.鼠标滑过非客户区时变不透明这里与WM_MOUSEMOVE通知处理类似仅在首个WM_NCMOUSEMOVE通知中设置窗口不透明效果。3.4.鼠标滑出非客户区时变透明在添加鼠标跟踪后若鼠标离开非客户区就会产生WM_NCMOUSELEAVE通知。此时要注意鼠标从窗口的非客户区移动至灰色空白区域客户区和窗口以外的地方都算离开非客户区。此时在添加WM_NCHITTEST消息进行判断时我们可以这样做仅当判断结果表明鼠标离开位置不是客户区时才将窗口变透明。这里的WM_NCHITTEST消息返回值只要不是HTCLIENT就行。4.完整源码建议大家在了解实现原理之后亲自动手编写代码实操这样才能提升自身能力。代码适配32与64位系统代码不区分WPS或EXCEL VBA环境你只需要复制代码到一个新模块中就能运行VBA晚间有雨伴人眠202608011619 原创代码转载或二创请标明来源 #If VBA7 And Win64 Then Private Declare PtrSafe Function IsWindow Lib user32 (ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function ShowWindow Lib user32 (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long Private Declare PtrSafe Function FindWindowA Lib user32 (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function CreateWindowExA Lib user32 (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal HwndParent As LongPtr, ByVal hMenu As LongPtr, ByVal Hinstance As LongPtr, lpParam As Any) As LongPtr Private Declare PtrSafe Function SetWindowLongA Lib user32 Alias SetWindowLongPtrA (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr Private Declare PtrSafe Function SetFocus Lib user32 (ByVal hwnd As LongPtr) As LongPtr Private Declare PtrSafe Function CallWindowProcA Lib user32 (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr Private Declare PtrSafe Function DestroyWindow Lib user32 (ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function GetWindowLongA Lib user32 Alias GetWindowLongPtrA (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr Private Declare PtrSafe Function SetLayeredWindowAttributes Lib user32 (ByVal hwnd As LongPtr, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Private Declare PtrSafe Function TrackMouseEvent Lib user32 (ByRef lpEventTrack As TrackMouseEventType) As Long Private Declare PtrSafe Function GetCursorPos Lib user32 (lpPoint As POINTAPI) As Long Private Declare PtrSafe Function SendMessageA Lib user32 (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr #Else Private Declare Function IsWindow Lib user32 (ByVal hwnd As Long) As Long Private Declare Function ShowWindow Lib user32 (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function FindWindowA Lib user32 (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function CreateWindowExA Lib user32 (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal HwndParent As Long, ByVal hMenu As Long, ByVal Hinstance As Long, lpParam As Any) As Long Private Declare Function SetWindowLongA Lib user32 (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function SetFocus Lib user32 (ByVal hwnd As Long) As Long Private Declare Function CallWindowProcA Lib user32 (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function DestroyWindow Lib user32 (ByVal hwnd As Long) As Long Private Declare Function GetWindowLongA Lib user32 Alias GetWindowLongPtrA (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetLayeredWindowAttributes Lib user32 Alias SetLayeredWindowAttributes (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long Private Declare Function TrackMouseEvent Lib user32 (ByRef lpEventTrack As TrackMouseEventType) As Long Private Declare Function GetCursorPos Lib user32 Alias GetCursorPos (lpPoint As POINTAPI) As Long Private Declare Function SendMessageA Lib user32 Alias SendMessageA (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long #End If #If VBA7 And Win64 Then Private Type POINTAPI x As Long y As Long End Type Private Type TrackMouseEventType cbSize As Long dwFlags As Long hwndTrack As LongPtr dwHoverTime As Long End Type #Else Private Type POINTAPI x As Long y As Long End Type Private Type TrackMouseEventType cbSize As Long dwFlags As Long hwndTrack As Long dwHoverTime As Long End Type #End If #If VBA7 And Win64 Then Private Const Nuptr As LongPtr 0 Private Ud As UserDialogType Private Type UserDialogType Dialog As LongPtr DialogProc As LongPtr Editor As LongPtr EditorState As LongPtr IsMouseMove As Boolean End Type #Else Private Const Nuptr As Long 0 Private Ud As UserDialogType Private Type UserDialogType Dialog As Long DialogProc As Long Editor As Long EditorState As Long IsMouseMove As Boolean End Type #End If Private Const SW_SHOW 5 Private Const SW_HIDE 0 Private Const WS_VISIBLE H10000000 Private Const WS_POPUP H80000000 Private Const WS_SYSMENU H80000 Private Const WS_CAPTION HC00000 Private Const WS_EX_DLGMODALFRAME H1 Private Const GWL_WNDPROC -4 Private Const WM_CLOSE H10 Private Const WM_DESTROY H2 Private Const GWL_EXSTYLE -20 Private Const WS_EX_LAYERED H80000 Private Const LWA_ALPHA H2 Private Const WM_MOUSEMOVE H200 Private Const WM_MOUSELEAVE H2A3 Private Const WM_NCMOUSEMOVE HA0 Private Const WM_NCMOUSELEAVE H2A2 Private Const WM_NCHITTEST H84 Private Const HTNOWHERE 0 Private Const HTCLIENT 1 Private Const HTBORDER 18 Private Const TME_LEAVE H2 Private Const TME_NONCLIENT H10 Public Sub CreateUserDialog() 对话框窗口若已存在则直接显示 If IsWindow(Ud.Dialog) Then ShowWindow Ud.Dialog, SW_SHOW: Exit Sub 获取编辑器句柄并隐藏 Ud.Editor FindWindowA(wndclass_desked_gsk, vbNullString) Ud.EditorState ShowWindow(Ud.Editor, SW_HIDE) 指定对话框初始样式 Dim StyleS: StyleS WS_VISIBLE Or WS_POPUP Or WS_SYSMENU Or WS_CAPTION Dim StyleE: StyleE WS_EX_DLGMODALFRAME 创建对话框主窗口 Ud.Dialog CreateWindowExA(StyleE, #32770, UserDialog, StyleS, 15, 50, 300, 200, Nuptr, Nuptr, Nuptr, Nuptr) 设置分层窗口 SetWindowLongA Ud.Dialog, GWL_EXSTYLE, GetWindowLongA(Ud.Dialog, GWL_EXSTYLE) Or WS_EX_LAYERED SetLayeredWindowAttributes Ud.Dialog, 0, 255, LWA_ALPHA 设置对话框子类化 Ud.DialogProc SetWindowLongA(Ud.Dialog, GWL_WNDPROC, AddressOf WindowProcUdDialog) 设置焦点 SetFocus Ud.Dialog End Sub #If VBA7 And Win64 Then Private Function WindowProcUdDialog(ByVal hwnd As LongPtr, ByVal msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr #Else Private Function WindowProcUdDialog(ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long #End If Select Case msg 窗口即将关闭时 Case WM_CLOSE 销毁窗口 DestroyWindow Ud.Dialog 用户已处理 WindowProcUdDialog Nuptr Exit Function 窗口销毁后 Case WM_DESTROY 取消子类化 SetWindowLongA Ud.Dialog, GWL_WNDPROC, Ud.DialogProc 还原编辑器的显示状态 If Ud.EditorState Then ShowWindow Ud.Editor, SW_SHOW 清理内存 Dim EmptyUd As UserDialogType: Ud EmptyUd 用户已处理 WindowProcUdDialog Nuptr Exit Function 客户区鼠标滑过通知 Case WM_MOUSEMOVE 首次滑过时执行 If Ud.IsMouseMove False Then 鼠标滑过标识 Ud.IsMouseMove True 设置不透明窗口 SetLayeredWindowAttributes Ud.Dialog, 0, 255, LWA_ALPHA 跟踪鼠标 StartTrackMouse Ud.Dialog, TME_LEAVE End If 客户区鼠标滑出通知 Case WM_MOUSELEAVE 首次滑出时执行 If Ud.IsMouseMove True Then 鼠标滑出标识 Ud.IsMouseMove False 获取鼠标坐标 Dim mlpt As POINTAPI GetCursorPos mlpt 当鼠标在屏幕背景时 Select Case CLng(SendMessageA(Ud.Dialog, WM_NCHITTEST, Nuptr, ByVal MAKELPARAM(mlpt.x, mlpt.y))) Case HTNOWHERE, HTBORDER 设置透明窗口 SetLayeredWindowAttributes Ud.Dialog, 0, 100, LWA_ALPHA End Select 用户已处理 WindowProcUdDialog Nuptr Exit Function End If 非客户区鼠标滑过通知 Case WM_NCMOUSEMOVE 首次滑过时执行 If Ud.IsMouseMove False Then 鼠标滑过标识 Ud.IsMouseMove True 设置不透明窗口 SetLayeredWindowAttributes Ud.Dialog, 0, 255, LWA_ALPHA 跟踪鼠标 StartTrackMouse Ud.Dialog, TME_NONCLIENT Or TME_LEAVE End If 非客户区鼠标滑出通知 Case WM_NCMOUSELEAVE 首次滑出时执行 If Ud.IsMouseMove True Then 鼠标滑出标识 Ud.IsMouseMove False 获取鼠标坐标 Dim nlpt As POINTAPI GetCursorPos mlpt 当鼠标不在客户区时 If CLng(SendMessageA(Ud.Dialog, WM_NCHITTEST, Nuptr, ByVal MAKELPARAM(nlpt.x, nlpt.y))) HTCLIENT Then 设置透明窗口 SetLayeredWindowAttributes Ud.Dialog, 0, 100, LWA_ALPHA End If 用户已处理 WindowProcUdDialog Nuptr Exit Function End If End Select 调用默认通知处理 WindowProcUdDialog CallWindowProcA(Ud.DialogProc, hwnd, msg, wParam, lParam) End Function #If VBA7 And Win64 Then Private Function MAKELPARAM(ByVal Low As Long, ByVal High As Long) As Long #Else Private Function MAKELPARAM(ByVal Low As Long, ByVal High As Long) As Long #End If 高低位整合 MAKELPARAM (High * 65536) Or (Low And HFFFF) End Function #If VBA7 And Win64 Then Private Function StartTrackMouse(ByVal hwnd As LongPtr, ByVal flag As Long) #Else Private Function StartTrackMouse(ByVal hwnd As Long, ByVal flag As Long) #End If 开始跟踪鼠标 Dim Tmet As TrackMouseEventType Tmet.cbSize LenB(Tmet) Tmet.dwFlags flag Tmet.dwHoverTime 10 Tmet.hwndTrack hwnd StartTrackMouse TrackMouseEvent(Tmet) End Function5.相关合集关于#32770对话框窗口的专项开发计划
