[求助]谁有画圆点的vba代码？

subtlation

能实现AutoCAD中的donut命令功能的。


我记得有人在这儿发过一个，但刚才找了很长时间都没有找到。哪位手上有的，帮忙发一次。谢谢。

efan2000

一种是使用SendCommand发送画圆环的命令，另一种是使用多段线，通过设置它的线宽来代替。

ahlzl

我写了一个：

2. Sub fg()
3. '这个小程序可连续画圆点
4. Dim pt As Variant
5. Dim r As Double
6. Dim pl As AcadLWPolyline
7. Dim ptt(3) As Double
8. MsgBox ("如要结束输入过程，在提示输入实心点的圆心时按ESC键或Enter键")
9. On Error GoTo bbb
10. aaa: pt = ThisDrawing.Utility.GetPoint(, "请输入实心点的圆心：")
11. r = ThisDrawing.Utility.GetDistance(pt, "请输入实心点的半径：")
12. ptt(0) = pt(0)
13. ptt(1) = pt(1) - r / 2
14. ptt(2) = pt(0)
15. ptt(3) = pt(1) + r / 2
16. Set pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptt)
17. pl.Closed = True
18. pl.SetWidth 0, r, r
19. pl.SetWidth 1, r, r
20. pl.SetBulge 0, 1
21. pl.SetBulge 1, 1
22. GoTo aaa
23. bbb:
24. End Sub

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

subtlation

谢谢楼上二位指点，我主要是在程序中用，所以写了个函数

2.   Function drawDonut(D1 As Double, D2 As Double, Pt1 As Variant) As AcadLWPolyline
3.    Dim LW As Double
4.    LW = (D1 - D2) / 2
5.    Dim lwPlineObj As AcadLWPolyline
6.    Dim points1(0 To 5) As Double
7.   
8.    points1(0) = Pt1(0) - (D1 - LW) / 2
9.    points1(1) = Pt1(1)
10.    points1(2) = Pt1(0) + (D1 - LW) / 2
11.    points1(3) = Pt1(1)
12.    points1(4) = points1(0)
13.    points1(5) = points1(1)
14.    Set lwPlineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points1)
15.    lwPlineObj.SetBulge 0, 1
16.    lwPlineObj.SetBulge 1, 1
17.    lwPlineObj.SetWidth 0, LW, LW
18.    lwPlineObj.SetWidth 1, LW, LW
19.    Set drawDonut = lwPlineObj
20. End Function

  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