让对话框窗口在鼠标单击时出现醒目标记
1. 效果演示晚间正在做一个完整的CSDN合集针对对话框#32770专门教学如何完善各项功能、如何优化使用体验等内容让大家在写自己的窗口项目时能够有所借鉴。2. 功能介绍鼠标左键按下时出现醒目标记松开时标记消失。3. 实现过程这个功能的本质是在对话框窗口上画圆和擦除操作方法是在鼠标左键按下时画一个圆又在左键松开时擦除圆。仅仅知道在什么时间干什么事还不够因为我们还不清楚怎么在对话框窗口上进行绘制操作。我们先来了解一个叫做hdc绘制环境的工具你可以把它理解为“画板”。其实窗口本身就像是一个画板只不过屏幕上的窗口很多画板也就很多。与画板配套的有很多画画工具比如画笔、画刷和橡皮擦等。在画板上画画也就是在hdc绘制环境中进行绘制绘制的顺序是先找到画板拿起需要的画画工具画画拿起原来的画画工具放回画板。接下来我们按照这个画画顺序来逐步讲解3.1 先找到画板我们使用GetDC函数获取对话框窗口的hdc绘制环境获取对话框绘制环境 Ud.DialogHdc GetDC(Ud.Dialog)3.2 拿起需要的画画工具画画工具需要用户先创建再拿起。我们先使用CreatePen函数创建一个1像素宽的实线画笔然后使用SelectObject函数在Ud.DialogHdc绘制环境中拿起这个画笔。接着我们再使用GetStockObject函数获取系统空画刷然后也在Ud.DialogHdc绘制环境中拿起这个画刷。创建并拿起画笔 Ud.Temp(0) CreatePen(PS_SOLID, 1, RGB(0, 0, 0)) Ud.Temp(1) SelectObject(Ud.DialogHdc, Ud.Temp(0)) 创建并拿起空画刷 Ud.Temp(2) GetStockObject(NULL_BRUSH) Ud.Temp(3) SelectObject(Ud.DialogHdc, Ud.Temp(2))“拿起”操作本身是分两步先放下现有的工具再拿起新的工具。在代码中这样理解SelectObject函数在拿起Ud.Temp(0)之前会先放下Ud.Temp(1)。3.3 画画确定鼠标左键单击位置的坐标我们在这里是拦截的WM_LBUTTONDOWN消息这个消息在发送时参数lParam带有坐标信息我们只需要将其提取出来就行从lParam低位获取鼠标x坐标 Ud.DiglogClick.x CLng(lParam) And HFFFF 从lParam高位获取鼠标y坐标 Ud.DiglogClick.y (CLng(lParam) And HFFFF0000) / H10000在鼠标左键按下的地方画一个黑色轮廓的圆我们来使用Ellipse函数进行画圆它的参数要求我们知道两个坐标一个是左上角坐标另一个是右下角坐标。用这两个坐标围成一个矩形以矩形中点为圆心的内切圆就是Ellipse函数画出的圆。绘制圆有边框、无背景 Ellipse Ud.DialogHdc, Ud.DiglogClick.x - 10, Ud.DiglogClick.y - 10, Ud.DiglogClick.x 10, Ud.DiglogClick.y 10在鼠标左键松开时擦除刚刚绘制的轮廓圆这里要用InvalidateRect函数指定一个即将要重绘的矩形区域。重绘擦除之前的醒目标记 Dim lprc As RECT lprc.Left Ud.DiglogClick.x - 10 lprc.Top Ud.DiglogClick.y - 10 lprc.Right Ud.DiglogClick.x 10 lprc.Bottom Ud.DiglogClick.y 10 InvalidateRect Ud.Dialog, lprc, True3.4 拿起原来的画画工具在画画结束之后由于不再需要使用这个1像素宽的实线画笔Ud.Temp(0)和空画刷Ud.Temp(2)了我们就要放下它们重新拿起之前的工具比如重新拿起之前的画笔Ud.Temp(1)以及重新拿起模前的画刷Ud.Temp(3)。以此让对话框窗口的绘制环境在用户绘制完之后始终保持原始模样。选中之前的画笔和画刷 SelectObject Ud.DialogHdc, Ud.Temp(1) SelectObject Ud.DialogHdc, Ud.Temp(3)此外我们还需要把不需要的画笔销毁掉释放内存。而使用GetStockObject函数获取的对象句柄不需要手动销毁。销毁临时画笔 DeleteObject Ud.Temp(0)3.5 放回画板在所有步骤都结束之后我们需要把当前在用的画板放回去也就是释放hdc绘制环境。释放绘制环境 ReleaseDC Ud.Dialog, Ud.DialogHdc4. 完整源码建议大家在了解实现原理之后亲自动手编写代码实操这样才能提升自身能力。代码适配32与64位系统代码不区分WPS或EXCEL 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 GetDC Lib user32 (ByVal hwnd As LongPtr) As LongPtr Private Declare PtrSafe Function ReleaseDC Lib user32 (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long Private Declare PtrSafe Function CreatePen Lib gdi32 (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As LongPtr Private Declare PtrSafe Function GetStockObject Lib gdi32 (ByVal nIndex As Long) As LongPtr Private Declare PtrSafe Function SelectObject Lib gdi32 (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr Private Declare PtrSafe Function Ellipse Lib gdi32 (ByVal hdc As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare PtrSafe Function DeleteObject Lib gdi32 (ByVal hObject As LongPtr) As Long Private Declare PtrSafe Function InvalidateRect Lib user32 (ByVal hwnd As LongPtr, lpRect As RECT, ByVal bErase As Long) As Long #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 GetDC Lib user32 (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib user32 (ByVal hwnd As Long, ByVal hdc As Long) As Long Private Declare Function CreatePen Lib gdi32 Alias CreatePen (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long Private Declare Function GetStockObject Lib gdi32 Alias GetStockObject (ByVal nIndex As Long) As Long Private Declare Function SelectObject Lib gdi32 Alias SelectObject (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function Ellipse Lib gdi32 (ByVal hdc As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function DeleteObject Lib gdi32 Alias DeleteObject (ByVal hObject As Long) As Long Private Declare Function InvalidateRect Lib user32 Alias InvalidateRect (ByVal hwnd As Long, lpRect As RECT, ByVal bErase As Long) As Long #End If #If VBA7 And Win64 Then Private Type POINTAPI x As Long y As Long End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type #Else Private Type POINTAPI x As Long y As Long End Type Private Type RECT Left As Long Top As Long Right As Long Bottom 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 DialogHdc As LongPtr DiglogClick As POINTAPI Editor As LongPtr EditorState As LongPtr Temp(3) As LongPtr End Type #Else Private Const Nuptr As Long 0 Private Ud As UserDialogType Private Type UserDialogType Dialog As Long DialogProc As Long DialogHdc As Long DiglogClick As POINTAPI Editor As Long EditorState As Long Temp(3) As Long 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 WM_LBUTTONDOWN H201 Private Const WM_LBUTTONUP H202 Private Const PS_SOLID 0 Private Const NULL_BRUSH 5 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) 获取对话框绘制环境 Ud.DialogHdc GetDC(Ud.Dialog) 设置对话框子类化 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 释放绘制环境 ReleaseDC Ud.Dialog, Ud.DialogHdc 销毁窗口 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_LBUTTONDOWN 从lParam低位获取鼠标x坐标 Ud.DiglogClick.x CLng(lParam) And HFFFF 从lParam高位获取鼠标y坐标 Ud.DiglogClick.y (CLng(lParam) And HFFFF0000) / H10000 创建并拿起画笔 Ud.Temp(0) CreatePen(PS_SOLID, 1, RGB(0, 0, 0)) Ud.Temp(1) SelectObject(Ud.DialogHdc, Ud.Temp(0)) 创建并拿起空画刷 Ud.Temp(2) GetStockObject(NULL_BRUSH) Ud.Temp(3) SelectObject(Ud.DialogHdc, Ud.Temp(2)) 绘制圆有边框、无背景 Ellipse Ud.DialogHdc, Ud.DiglogClick.x - 10, Ud.DiglogClick.y - 10, Ud.DiglogClick.x 10, Ud.DiglogClick.y 10 选中之前的画笔和画刷 SelectObject Ud.DialogHdc, Ud.Temp(1) SelectObject Ud.DialogHdc, Ud.Temp(3) 销毁临时画笔 DeleteObject Ud.Temp(0) Case WM_LBUTTONUP 重绘擦除之前的醒目标记 Dim lprc As RECT lprc.Left Ud.DiglogClick.x - 10 lprc.Top Ud.DiglogClick.y - 10 lprc.Right Ud.DiglogClick.x 10 lprc.Bottom Ud.DiglogClick.y 10 InvalidateRect Ud.Dialog, lprc, True End Select 调用默认通知处理 WindowProcUdDialog CallWindowProcA(Ud.DialogProc, hwnd, msg, wParam, lParam) End Function5. 相关合集关于#32770对话框窗口的专项开发计划
)
