分享一个鼠标按下就能画线的绘图窗体VBA

大家好这里是晚间有雨伴人眠。之前咱们聊过怎么创建自定义对话框窗口也聊过怎么让窗口显示在屏幕正中间。今天再分享一个新玩法——在窗体上画线绘图。这个功能说大不大但用对了场景还挺实用的。比如你可以把它做成一个简易的批注工具在表格数据上画圈标记或者做一个签名板让用户在窗体上手写签名甚至只是给演示文稿加个临时的标注图层都行。效果很简单鼠标左键按住拖动就能在窗体上画出一条连续的黑色线条松开就停止绘制。先看效果再说实现。一、核心思路在Windows里画线用的是GDI图形设备接口。这套接口里有两个最基础的函数MoveToEx 把“画笔”移动到某个坐标LineTo 从当前位置画一条线到目标坐标所以整个绘图的逻辑就是鼠标按下 → 记录起始位置 → 鼠标移动 → 不断从上一个位置画到当前位置 → 鼠标松开 → 停止绘制说白了就是一个连续画线的过程和你在Windows自带的画图软件里用铅笔工具画画是完全一样的道理。二、代码解析完整代码你直接复制就能用这里我挑几个关键点简单说一下方便你理解原理。1. 窗体事件的配合代码里用了三个鼠标事件UserForm_MouseDown 左键按下时设置一个“正在绘制”标记UserForm_MouseUp 左键松开时清除这个标记UserForm_MouseMove 鼠标移动时如果标记为真就执行画线这三个事件一配合就实现了“按下画、松开停”的效果。2. 坐标转换这里有个细节需要注意 GetCursorPos 获取的是鼠标在屏幕上的坐标但画线需要的是在窗体客户区内的坐标所以必须用 ScreenToClient 做一次转换否则画出来的位置就全偏移了。代码里是这样处理的GetCursorPos prpt 获取屏幕坐标 ScreenToClient Uf.Form, prpt 转换成窗体坐标3. 画笔的创建与释放在窗体初始化时创建画笔Uf.Penr CreatePen(PS_SOLID, 1, RGB(0, 0, 0))这里创建了黑色、1像素宽的实线画笔。想要换颜色或粗细改这里就行RGB(0, 0, 0) 改成 RGB(255,0,0) 就是红色中间那个1改成3就是3像素宽窗体关闭时记得释放画笔和设备上下文避免内存泄漏DeleteObject Uf.Penr ReleaseDC Uf.Form, Uf.Fhdc三、可以玩的花样这个基础版本还可以继续扩展给你几个思路换颜色加几个按钮点击后修改画笔颜色调整粗细加一个滚动条控制画笔宽度清空画布加一个“清除”按钮重绘窗体画直线/矩形把自由画线改成从起点到终点的规则图形这些都是在这个基础上顺理成章的扩展有兴趣的话可以自己动手试试。四、完整代码新建一个UserForm把下面的代码全部粘贴进去直接运行就能看到效果。晚间有雨伴人眠202607161122 #If VBA7 And Win64 Then Private Declare PtrSafe Function LineTo Lib gdi32 (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long) As Long Private Declare PtrSafe Function MoveToEx Lib gdi32 (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) 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 DeleteObject Lib gdi32 (ByVal hObject 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 FindWindowA Lib user32 (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function GetCursorPos Lib user32 (lpPoint As POINTAPI) As Long Private Declare PtrSafe Function ScreenToClient Lib user32 (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long #Else Private Declare Function LineTo Lib gdi32 Alias LineTo (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long Private Declare Function MoveToEx Lib gdi32 Alias MoveToEx (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) 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 DeleteObject Lib gdi32 Alias DeleteObject (ByVal hObject As Long) As Long Private Declare Function GetDC Lib user32 Alias GetDC (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib user32 Alias ReleaseDC (ByVal hwnd As Long, ByVal hdc As Long) As Long Private Declare Function FindWindowA Lib user32 Alias FindWindowA (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetCursorPos Lib user32 Alias GetCursorPos (lpPoint As POINTAPI) As Long Private Declare Function ScreenToClient Lib user32 Alias ScreenToClient (ByVal hwnd As Long, lpPoint As POINTAPI) As Long #End If #If VBA7 And Win64 Then Private Type POINTAPI X As Long Y As Long End Type Private Type UserForm1Type Form As LongPtr Fhdc As LongPtr Penr As LongPtr GotoLine(1) As Boolean End Type #Else Private Type POINTAPI X As Long Y As Long End Type Private Type UserForm1Type Form As Long Fhdc As Long Penr As Long GotoLine(1) As Boolean End Type #End If Private Const PS_SOLID 0 Private Uf As UserForm1Type Private Sub UserForm_Initialize() Uf.Form FindWindowA(IIf(Application.Version 9, ThunderXFrame, ThunderDFrame), Me.Caption) Uf.Penr CreatePen(PS_SOLID, 1, RGB(0, 0, 0)) Uf.Fhdc GetDC(Uf.Form) End Sub Private Sub UserForm_Terminate() DeleteObject Uf.Penr ReleaseDC Uf.Form, Uf.Fhdc Dim EmptyUf As UserForm1Type: Uf EmptyUf End Sub Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button 1 Then Uf.GotoLine(0) True: Uf.GotoLine(1) True End Sub Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button 1 Then Uf.GotoLine(0) False End Sub Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Uf.GotoLine(0) Then Dim prpt As POINTAPI GetCursorPos prpt ScreenToClient Uf.Form, prpt If Uf.GotoLine(1) Then MoveToEx Uf.Fhdc, prpt.X, prpt.Y, prpt Uf.GotoLine(1) False Else LineTo Uf.Fhdc, prpt.X, prpt.Y End If End If End Sub五、写到最后GDI绘图是Windows编程里非常基础的一块VBA通过API调用也能玩起来。它的学习曲线不算陡但掌握了之后能做的事情比想象中多得多——从简单的画线画图到自定义控件的外观都能派上用场。代码不长但“按下拖动画线”这个交互是很多绘图工具的基石。如果你刚好需要一个轻量级的标注或签名功能这份代码改改就能用。你平时在VBA里有没有遇到过需要在窗体上画图的需求或者想在这份代码基础上增加什么功能欢迎在评论区聊聊。