使用 VBA 在屏幕上画线

如果你想使用 VBA 在屏幕的任意位置画线，可以使用 LineTo 函数。LineTo 函数使用当前笔从当前位置到指定位置绘制一条线。如果 LineTo 成功，结束位置将成为下一个当前位置。

LineTo 函数语法

LineTo(
  [in] HDC hdc,
  [in] int x,
  [in] int y
);

LineTo 函数参数

LineTo 函数的参数如下表所示：

参数	说明
[in] hdc	设备上下文的句柄。
[in] x	指定线条终点的 x 坐标（以逻辑单位为单位）。
[in] y	指定线条终点的 y 坐标（以逻辑单位为单位）。

示例一

以下示例用 LineTo 函数在屏幕当前位置（GetDC(0) 获取整个屏幕的句柄，它的当前位置是屏幕的左上角。）和指定点画一条线。

#If VBA7 And Win64 Then
    Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Declare PtrSafe Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal nXEnd As Long, ByVal nYEnd As Long) As Long
#Else
    Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal nXEnd As Long, ByVal nYEnd As Long) As Long
#End If

Sub LineToDemo()
    ' https://oacourse.com/excel/draw-an-ellipse-on-the-screen-using-vba/
    Dim hdc As Long
    ' 获取主屏幕的句柄
    hdc = GetDC(0)
    ' 在屏幕当前位置(这里是屏幕左上角)和指定位置画线
    LineTo hdc, 200, 200
    ' 释放句柄
    ReleaseDC 0, hdc
End Sub

示例二

如果要改变线的起始位置，可以使用 MoveToEx 函数，设置一个起始位置的坐标。MoveToEx 函数将当前位置更新为指定点，并选择性地返回上一个位置。

MoveToEx 函数的语法如下：

MoveToEx(
  [in]  HDC     hdc,
  [in]  int     x,
  [in]  int     y,
  [out] LPPOINT lppt
);

MoveToEx 函数的参数如下表所示：

参数	说明
[in] hdc	设备上下文的句柄。
[in] x	指定新位置的 x 坐标（以逻辑单元为单位）。
[in] y	指定新位置的 y 坐标（以逻辑单元为单位）。
[in] lppt	指向接收先前当前位置的 POINT 结构的指针。如果此参数为 NULL 指针，则不返回上一个位置。

其中 POINT 结构用于表示二维平面坐标系中的一个点，包含两个整数值 X 和 Y，分别代表该点在水平方向和垂直方向上的坐标值。定义语法如下：

typedef struct tagPOINT {
  LONG x;
  LONG y;
} POINT, *PPOINT, *NPPOINT, *LPPOINT;

使用 POINT 结构来创建一个坐标点的示例：

' 声明 POINT 结构体
Type POINT
    X As Long
    Y As Long
End Type

' 创建一个坐标点
Sub CreatePoint()
    ' 将 pt 声明为 POINT 类型的变量
    Dim pt As POINT
    pt.X = 10
    pt.Y = 20
    
    ' 输出坐标点的坐标值
    Debug.Print "X: " & pt.X & ", Y: " & pt.Y
End Sub

以下示例使用 MoveToEx 函数将当前位置更改为 (100, 100) ，再使用 LineTo 函数以新起始点画一个长方形：

#If VBA7 And Win64 Then
    Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Declare PtrSafe Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal nXEnd As Long, ByVal nYEnd As Long) As Long
    Declare PtrSafe Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
#Else
    Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal nXEnd As Long, ByVal nYEnd As Long) As Long
    Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
#End If

' 声明 POINT 结构体
Type POINTAPI
    X As Long
    Y As Long
End Type
Sub DrawRectangle()
    Dim hdc As Long
    ' 将 pt 声明为 POINT 类型的变量
    Dim pt As POINTAPI
    hdc = GetDC(0)
    ' 设置新起始点（100,100）
    MoveToEx hdc, 100, 100, pt
    ' 画线
    LineTo hdc, 100, 300
    LineTo hdc, 400, 300
    LineTo hdc, 400, 100
    LineTo hdc, 100, 100
    ' 释放句柄
    ReleaseDC 0, hdc
End Sub

示例三

如果想要调整所画线的线型、大小、颜色等，首先使用 CreatePen 函数创建一个画笔样式，设置它的线型、大小、颜色。

CreatePen 函数的语法如下：

CreatePen(
  [in] int      iStyle,
  [in] int      cWidth,
  [in] COLORREF color
);

其中 iStyle 参数为所用画笔类型，cWidth 参数为线的大小，color 参数为线的颜色。

其中线型有以下几种类型：

常量	值	说明
PS_SOLID	0	实线画笔。
PS_DASH	1	短横线画笔。
PS_DOT	2	点画笔。
PS_DASHDOT	3	短横线和点交替出现的画笔。
PS_DASHDOTDOT	4	一个短横线和两个点交替出现的画笔。
PS_NULL	5	空画笔，用于关闭绘图操作。
PS_INSIDEFRAME	6	空心画笔，画笔位于图形边界内部。

如果 cWidth 为零，则无论如何，笔都是单个像素宽的。

color 参数可以使用 VBA 颜色常量或者使用 RGB 函数。

创建好画笔样式后，再使用 SelectObject 函数将该画笔对象选入设备上下文中，然后使用 MoveToEx 和 LineTo 函数绘制需要的线。最后，使用 ReleaseDC 函数释放设备上下文，并使用 DeleteObject 函数删除画笔对象。

以下示例在指定位置画一个红叉：

#If VBA7 And Win64 Then
    Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Declare PtrSafe Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal nXEnd As Long, ByVal nYEnd As Long) As Long
    Declare PtrSafe Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
    Declare PtrSafe Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
    Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
#Else
    Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
    Declare Function LineTo Lib "gdi32" (ByVal hDC As Long, ByVal nXEnd As Long, ByVal nYEnd As Long) As Long
    Declare Function MoveToEx Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
    Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
    Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
    Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
#End If
' 声明 POINT 结构体
Type POINTAPI
    x As Long
    y As Long
End Type

Sub DrawLines()
    Dim hdc As Long
    ' 将 pt 声明为 POINT 类型的变量
    Dim pt As POINTAPI
    
    ' 获取设备上下文
    hdc = GetDC(0)
    Dim hPen As Long
    ' 创建画笔对象：点画笔，线宽为3，红色
    hPen = CreatePen(PS_DOT, 3, vbRed)
    ' 将画笔对象选入设备上下文
    SelectObject hdc, hPen
    
    ' 绘制线条
    MoveToEx hdc, 100, 100, pt
    LineTo hdc, 200, 200
    MoveToEx hdc, 200, 100, pt
    LineTo hdc, 100, 200
    
    ' 释放设备上下文和画笔对象
    ReleaseDC 0, hdc
    DeleteObject hPen
End Sub