分享一个鼠标按下就能画线的绘图窗体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里有没有遇到过需要在窗体上画图的需求或者想在这份代码基础上增加什么功能欢迎在评论区聊聊。

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

相关推荐

OpenClaw 合规公开数据采集入门：合法边界、数据源选型与反爬规避实操指南

使用 C# 将 HTML 转 Word 或者 Word 转 HTML

EMB3531-RK3399工控机救砖！进maskrom模式

更多资讯

电工证盗用真实经历揭秘：学历不高怕报不上名？教你如何避坑

宿豫区电工证复审报名费多少钱，真实经历告诉你别被中介坑

保山电工证在哪办上岗必备的全流程详解

特种设备安装维修工上岗必备：实操考试心里没底怕挂科？全流程避坑指南

石家庄特种工领取补贴别走弯路这份郑州报考避坑指南送给你

泰州考电工证有黄牛吗值不值得考？看懂这些再决定

今日更新

高压电工证哪里可以挂多久拿证全攻略：实操考试心里没底怕挂科别慌

电工证的理论题目在哪考，外省证怎么转过来

工地太忙根本没时间复习考试，职业学校的电工证值不值得考？

本周精选

安监局电工证分数查询怎么查才能知道含金量高不高

新疆电工作业干活累吗良心建议助你避开考不过的坑

中牟县电工证怎么报名外省证能转吗

本月热门

面向复杂光照与角度的宠物面部识别鲁棒性增强策略

基于DRV8818与STM32的双极步进电机驱动方案实战解析

DRV8818PWPR+PIC18F45K80双极步进电机控制方案实战

读完文章，想聊聊您的网站？