northwolves[狼行天下] 的专栏

无知无惧,无欲无敌。

应用API函数在用户窗体中画圆

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long                    '
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long


Sub MyCircle(MyObject As Object, pX As Long, pY As Long, pR As Long, lcColor As Long, lcFill As Long)
'MyObject 指定圆所在的对象
'
'pX 圆心在对象体上X轴
'
'pY 圆心在对象体上Y轴
'
'pR 圆的半径
'
'lcColor 圆的轮廓颜色
'
'lcFill 圆的填充色

Dim hdc As Long, hpen As Long, hcolor As Long
hdc = GetDC(FindWindow(vbNullString, MyObject.Caption))
hpen = CreatePen(0, 1, lcColor)
hcolor = CreateSolidBrush(lcFill)
SelectObject hdc, hpen
SelectObject hdc, hcolor
Ellipse hdc, pX - pR, pY - pR, pX + pR, pY + pR
DeleteObject hpen
DeleteObject hcolor
End Sub
'

Private Sub UserForm_Click()
MyCircle UserForm1, 100, 100, 50, vbRed, vbBlue
End Sub

阅读更多
上一篇VBA增加sheet,重名时自动命名
下一篇在VBA中获取“我的文档”的目录路径
想对作者说点什么? 我来说一句

采用API函数的两个画圆程序,

2010年01月20日 1.84MB 下载

用Ellipse画圆

2010年07月22日 1.09MB 下载

没有更多推荐了,返回首页

关闭
关闭