VBA窗体画图

由于VBA拿掉了专门画图的函数，所以需要调用系统画图API

'下面代码复制到模块

Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long


Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long


Declare Function Arc Lib "gdi32" (ByVal hdc As Long, _
ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, _
ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 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 LineTo Lib "gdi32" (ByVal hdc As Long, _
ByVal x As Long, ByVal y As Long) As Long


Declare Function CancelDC Lib "gdi32" (ByVal hdc As Long) As Long


Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, _
ByVal nWidth As Long, ByVal crColor As Long) As Long


Const PS_DASH = 1

Const PS_DASHDOT = 3

Const PS_DASHDOTDOT = 4

Const PS_DOT = 2

Const PS_NULL = 5

Const PS_SOLID = 0


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

Type POINTAPI

        x As Long
        
        y As Long
        
End Type

'Arc参数 类型及说明

'  hdc     Long，一个显示场景的句柄

'  X1,Y1   Long，指定围绕椭圆的一个矩形的左上角位置

'  X2,Y2   Long，指定围绕椭圆的一个矩形的右下角位置

'  X3,Y3   Long，指定圆弧起点

'  X4,Y4   Long，指定圆弧终点

'下面代码复制到窗体

Private Sub Form_Load()

    Dim pt As POINTAPI

    Dim hPen As Long

    Dim hPenPrev As Long



    hPen = CreatePen(PS_DOT, 1, vbRed)

    Me.AutoRedraw = True

    hPenPrev = SelectObject(Me.hdc, hPen)

    MoveToEx Me.hdc, 10, 100, pt

    LineTo Me.hdc, 200, 100

    SelectObject Me.hdc, hPenPrev

    DeleteObject hPen

End Sub

Private Sub CommandButton1_Click()

    Dim hwnd As Long

    Dim hdc As Long

    Dim pt As POINTAPI

    Dim p0(0 To 1) '圆0圆心坐标

    Dim p1(0 To 1) '圆1圆心坐标

    Dim p3(0 To 1) '切线切点0坐标

    Dim p4(0 To 1) '切线切点1坐标

    Dim p5(0 To 7) '圆0坐标

    Dim p6(0 To 7) '圆1坐标

    Dim d0 '圆0直径

    Dim d1 '圆1直径

    Dim s0 As Double '圆心距离

    Dim dx, dy, dr

    Dim sin1 As Double '切点半径斜角正弦值

    Dim cos1 As Double '切点半径斜角余弦值



    p0(0) = 100: p0(1) = 200

    p1(0) = 200: p1(1) = 200

    d0 = 50

    d1 = 80



    dx = p1(0) - p0(0)

    dy = p1(1) - p0(1)

    dr = (d1 - d0) / 2

    s0 = Sqr(dx ^ 2 + dy ^ 2)

    cos1 = dx * dr / s0 ^ 2 - dy * Sqr(1 - (dr / s0) ^ 2) / s0

    sin1 = Sqr(1 - (cos1) ^ 2)



    p3(0) = p0(0) - d0 / 2 * cos1

    p3(1) = p0(1) - d0 / 2 * sin1



    p4(0) = p1(0) - d1 / 2 * cos1

    p4(1) = p1(1) - d1 / 2 * sin1



    p5(0) = p0(0) - d0 / 2

    p5(1) = p0(1) - d0 / 2

    p5(2) = p0(0) + d0 / 2

    p5(3) = p0(1) + d0 / 2

    p5(4) = p0(0) - d0 / 2

    p5(5) = p0(1) - d0 / 2

    p5(6) = p0(0) - d0 / 2

    p5(7) = p0(1) - d0 / 2



    p6(0) = p1(0) - d1 / 2

    p6(1) = p1(1) - d1 / 2

    p6(2) = p1(0) + d1 / 2

    p6(3) = p1(1) + d1 / 2

    p6(4) = p1(0) - d1 / 2

    p6(5) = p1(1) - d1 / 2

    p6(6) = p1(0) - d1 / 2

    p6(7) = p1(1) - d1 / 2



    hwnd = FindWindow(vbNullString, "UserForm1") '获得窗口句柄

    If hwnd = 0 Then

    Else

        hdc = GetDC(hwnd)

        Arc hdc, p5(0), p5(1), p5(2), p5(3), p5(4), p5(5), p5(6), p5(7)

        Arc hdc, p6(0), p6(1), p6(2), p6(3), p6(4), p6(5), p6(6), p6(7)

        MoveToEx hdc, p3(0), p3(1), pt

        LineTo hdc, p4(0), p4(1)

        CancelDC hdc

    End If

End Sub