[求助]谁有画圆点的vba代码？
能实现autocad中的donut命令功能的。我记得有人在这儿发过一个，但刚才找了很长时间都没有找到。哪位手上有的，帮忙发一次。谢谢。 一种是使用SendCommand发送画圆环的命令，另一种是使用多段线，通过设置它的线宽来代替。 我写了一个： Sub fg()
'这个小程序可连续画圆点
Dim pt As Variant
Dim r As Double
Dim pl As AcadLWPolyline
Dim ptt(3) As Double
MsgBox ("如要结束输入过程，在提示输入实心点的圆心时按ESC键或Enter键")
On Error GoTo bbb
aaa: pt = ThisDrawing.Utility.GetPoint(, "请输入实心点的圆心：")
r = ThisDrawing.Utility.GetDistance(pt, "请输入实心点的半径：")
ptt(0) = pt(0)
ptt(1) = pt(1) - r / 2
ptt(2) = pt(0)
ptt(3) = pt(1) + r / 2
Set pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptt)
pl.Closed = True
pl.SetWidth 0, r, r
pl.SetWidth 1, r, r
pl.SetBulge 0, 1
pl.SetBulge 1, 1
GoTo aaa
bbb:
End Sub 谢谢楼上二位指点，我主要是在程序中用，所以写了个函数Function drawDonut(D1 As Double, D2 As Double, Pt1 As Variant) As AcadLWPolyline
Dim LW As Double
LW = (D1 - D2) / 2
Dim lwPlineObj As AcadLWPolyline
Dim points1(0 To 5) As Double
points1(0) = Pt1(0) - (D1 - LW) / 2
points1(1) = Pt1(1)
points1(2) = Pt1(0) + (D1 - LW) / 2
points1(3) = Pt1(1)
points1(4) = points1(0)
points1(5) = points1(1)
Set lwPlineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points1)
lwPlineObj.SetBulge 0, 1
lwPlineObj.SetBulge 1, 1
lwPlineObj.SetWidth 0, LW, LW
lwPlineObj.SetWidth 1, LW, LW
Set drawDonut = lwPlineObj
End Function
页:
[1]