画圆后标注直径有时无法选中圆

sunny_8848

请教大家一个问题，excel vba绘制一个圆，标注直径时，我采用的是用输入圆上一点的方法选择圆，有时会出错，提示需要单个圆，有时可以成功。请问有什么办法解决这个问题吗

mikewolf2k

"采用的是用输入圆上一点"——哪个点？确定在圆上？

sunny_8848

mikewolf2k 发表于 2021-3-11 09:39
"采用的是用输入圆上一点"——哪个点？确定在圆上？

确定是在圆上，是右象限点。而且事先已经关闭捕捉功能(不知道怎么关闭极轴追踪)，甚至也考虑了放大窗口，还是有时报错。如果采用其他标注类型实现，看起来有点别扭

flypig

我的想法是遍历CAD中的所有图元，如果是需要的圆，则直接给该对象进行标注，为了确保标注的圆是自己需要的，可以在画圆的时候利用setxdata方法给这个圆添加一个标识，通过对比确认

sunny_8848

谢谢解答。可是只会一点简单的eⅹcel vbα，能帮忙给个代码吗

mokson

这个圆是否在冻结的图层上？还有，它是与在同一个平面上？

sunny_8848

不是在冻结的图层上，也是在一个平面上。现在的问题是有时可以成功有时报错提示需要选择单个圆，一直找不到原因

yshf

2. Public Sub 画圆标注直径()
   
3.     Dim AcAdApp As Object
   
4.     Dim ThisDrawing As Object
   
5.    
   
6.     On Error Resume Next
   
7.    
   
8.     Set AcAdApp = GetObject(, "AutoCAD.Application")
   
9.     If Err Then
   
10.        MsgBox "请打开AutoCAD，再执行程序!", vbInformation
    
11.        Exit Sub
    
12.     End If
    
13.    
    
14.     Set ThisDrawing = AcAdApp.ActiveDocument
    
15.    
    
16.    
    
17.     Dim circleobj As Object
    
18.     Dim centerpoint(0 To 2) As Double
    
19.     Dim radius As Double
    
20.     Dim returnPnt As Variant
    
21.    
    
22. 
    
23.     returnPnt = ThisDrawing.Utility.GetPoint(, "请指定圆心点: ")
    
24.     centerpoint(0) = returnPnt(0): centerpoint(1) = returnPnt(1): centerpoint(2) = returnPnt(2)
    
25.     radius = ThisDrawing.Utility.GetDistance(returnPnt, "请输入半径R＝: ")
    
26. 
    
27.       
    
28.     Set circleobj = ThisDrawing.ModelSpace.AddCircle(centerpoint, radius)
    
29. 
    
30.     Dim dimobj As Object
    
31.     Dim chordpoint(0 To 2) As Double
    
32.     Dim farchordpoint(0 To 2) As Double
    
33.     Dim leaderlength As Double
    
34.     Dim Angle As Double
    
35.    
    
36.     Angle = Atn(1#) '标注时与图上X轴正向的夹角，设为沿45°方向标注
    
37.     chordpoint(0) = centerpoint(0) + radius * Cos(Angle)
    
38.     chordpoint(1) = centerpoint(1) + radius * Sin(Angle)
    
39.     chordpoint(2) = centerpoint(2)
    
40.     farchordpoint(0) = centerpoint(0) - radius * Cos(Angle)
    
41.     farchordpoint(1) = centerpoint(1) - radius * Sin(Angle)
    
42.     farchordpoint(2) = centerpoint(2)
    
43.     leaderlength = 1#
    
44.     Set dimobj = ThisDrawing.ModelSpace.AddDimDiametric(chordpoint, farchordpoint, leaderlength)
    
45. 
    
46. End Sub

Public Sub 画圆标注直径()<br />     Dim AcAdApp As Object<br />     Dim ThisDrawing As Object<br />     <br />     On Error Resume Next<br />     <br />     Set AcAdApp = GetObject(, "AutoCAD.Application")<br />     If Err Then<br />        MsgBox "请打开AutoCAD，再执行程序!", vbInformation<br />        Exit Sub<br />     End If<br />     <br />     Set ThisDrawing = AcAdApp.ActiveDocument<br />     <br />    <br />     Dim circleobj As Object<br />     Dim centerpoint(0 To 2) As Double<br />     Dim radius As Double<br />     Dim returnPnt As Variant<br />    <br /> <br />     returnPnt = ThisDrawing.Utility.GetPoint(, "请指定圆心点: ")<br />     centerpoint(0) = returnPnt(0): centerpoint(1) = returnPnt(1): centerpoint(2) = returnPnt(2)<br />     radius = ThisDrawing.Utility.GetDistance(returnPnt, "请输入半径R＝: ")<br /> <br />       <br />     Set circleobj = ThisDrawing.ModelSpace.AddCircle(centerpoint, radius)<br /> <br />     Dim dimobj As Object<br />     Dim chordpoint(0 To 2) As Double<br />     Dim farchordpoint(0 To 2) As Double<br />     Dim leaderlength As Double<br />     Dim Angle As Double<br />     <br />     Angle = Atn(1#) '标注时与图上X轴正向的夹角，设为沿45°方向标注<br />     chordpoint(0) = centerpoint(0) + radius * Cos(Angle)<br />     chordpoint(1) = centerpoint(1) + radius * Sin(Angle)<br />     chordpoint(2) = centerpoint(2)<br />     farchordpoint(0) = centerpoint(0) - radius * Cos(Angle)<br />     farchordpoint(1) = centerpoint(1) - radius * Sin(Angle)<br />     farchordpoint(2) = centerpoint(2)<br />     leaderlength = 1#<br />     Set dimobj = ThisDrawing.ModelSpace.AddDimDiametric(chordpoint, farchordpoint, leaderlength)<br /> <br /> End Sub

sunny_8848

yshf 发表于 2021-3-12 14:02

感谢帮忙，可以方便标注直径了。要怎么修改代码才能改成  30-φ20配钻  这样的标注形式，圆心点和半径依据单元格数据，这样就可以实现只需更改单元格数据，绘图时不需要人工介入。整个图纸中就这个直径标注特殊点，是比例图中画的，无法采用修改文字内容的方式。

yshf

2. Public Sub 画圆标注直径()
   
3.     Dim AcAdApp As Object
   
4.     Dim ThisDrawing As Object
   
5.    
   
6.     On Error Resume Next
   
7.    
   
8.     Set AcAdApp = GetObject(, "AutoCAD.Application")
   
9.     If Err Then
   
10.        MsgBox "请打开AutoCAD，再执行程序!", vbInformation
    
11.        Exit Sub
    
12.     End If
    
13.    
    
14.     Set ThisDrawing = AcAdApp.ActiveDocument
    
15.    
    
16.     Dim circleobj As Object
    
17.     Dim centerpoint(0 To 2) As Double
    
18.     Dim radius As Double
    
19.     Dim returnPnt As Variant
    
20.    
    
21.     AppActivate AcAdApp.Caption  '将控制权转交给CAD
    
22.    
    
23.     returnPnt = ThisDrawing.Utility.GetPoint(, "请指定圆心点: ")
    
24.     centerpoint(0) = returnPnt(0): centerpoint(1) = returnPnt(1): centerpoint(2) = returnPnt(2)
    
25.     radius = ThisDrawing.Utility.GetDistance(returnPnt, "请输入半径R＝: ")
    
26.       
    
27.     Set circleobj = ThisDrawing.ModelSpace.AddCircle(centerpoint, radius)
    
28. 
    
29.     Dim dimobj As Object
    
30.     Dim chordpoint(0 To 2) As Double
    
31.     Dim farchordpoint(0 To 2) As Double
    
32.     Dim leaderlength As Double
    
33.     Dim Angle As Double
    
34.    
    
35.     Angle = Atn(1#) '标注时与图上X轴正向的夹角，设为沿45°方向标角
    
36.     chordpoint(0) = centerpoint(0) + radius * Cos(Angle)
    
37.     chordpoint(1) = centerpoint(1) + radius * Sin(Angle)
    
38.     chordpoint(2) = centerpoint(2)
    
39.     farchordpoint(0) = centerpoint(0) - radius * Cos(Angle)
    
40.     farchordpoint(1) = centerpoint(1) - radius * Sin(Angle)
    
41.     farchordpoint(2) = centerpoint(2)
    
42.     leaderlength = 1#
    
43.     Set dimobj = ThisDrawing.ModelSpace.AddDimDiametric(chordpoint, farchordpoint, leaderlength)
    
44.    
    
45.     Dim Qzzfc As String
    
46.     Qzzfc = "30-" & "φ"
    
47.     dimobj.TextPrefix = Qzzfc  '标注增加前缀字符
    
48. End Sub

Public Sub 画圆标注直径()<br />     Dim AcAdApp As Object<br />     Dim ThisDrawing As Object<br />     <br />     On Error Resume Next<br />     <br />     Set AcAdApp = GetObject(, "AutoCAD.Application")<br />     If Err Then<br />        MsgBox "请打开AutoCAD，再执行程序!", vbInformation<br />        Exit Sub<br />     End If<br />     <br />     Set ThisDrawing = AcAdApp.ActiveDocument<br />     <br />     Dim circleobj As Object<br />     Dim centerpoint(0 To 2) As Double<br />     Dim radius As Double<br />     Dim returnPnt As Variant<br />     <br />     AppActivate AcAdApp.Caption  '将控制权转交给CAD<br />    <br />     returnPnt = ThisDrawing.Utility.GetPoint(, "请指定圆心点: ")<br />     centerpoint(0) = returnPnt(0): centerpoint(1) = returnPnt(1): centerpoint(2) = returnPnt(2)<br />     radius = ThisDrawing.Utility.GetDistance(returnPnt, "请输入半径R＝: ")<br />       <br />     Set circleobj = ThisDrawing.ModelSpace.AddCircle(centerpoint, radius)<br /> <br />     Dim dimobj As Object<br />     Dim chordpoint(0 To 2) As Double<br />     Dim farchordpoint(0 To 2) As Double<br />     Dim leaderlength As Double<br />     Dim Angle As Double<br />     <br />     Angle = Atn(1#) '标注时与图上X轴正向的夹角，设为沿45°方向标角<br />     chordpoint(0) = centerpoint(0) + radius * Cos(Angle)<br />     chordpoint(1) = centerpoint(1) + radius * Sin(Angle)<br />     chordpoint(2) = centerpoint(2)<br />     farchordpoint(0) = centerpoint(0) - radius * Cos(Angle)<br />     farchordpoint(1) = centerpoint(1) - radius * Sin(Angle)<br />     farchordpoint(2) = centerpoint(2)<br />     leaderlength = 1#<br />     Set dimobj = ThisDrawing.ModelSpace.AddDimDiametric(chordpoint, farchordpoint, leaderlength)<br />     <br />     Dim Qzzfc As String<br />     Qzzfc = "30-" & "φ"<br />     dimobj.TextPrefix = Qzzfc  '标注增加前缀字符<br /> End Sub