让对话框窗口在鼠标单击时出现醒目标记

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, True

3.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.DialogHdc

4. 完整源码

建议大家在了解实现原理之后，亲自动手编写代码实操，这样才能提升自身能力。

• 代码适配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 Function

 5. 相关合集

关于#32770对话框窗口的专项开发计划