画圆后标注直径有时无法选中圆
请教大家一个问题，excel vba绘制一个圆，标注直径时，我采用的是用输入圆上一点的方法选择圆，有时会出错，提示需要单个圆，有时可以成功。请问有什么办法解决这个问题吗"采用的是用输入圆上一点"——哪个点？确定在圆上？ 本帖最后由 sunny_8848 于 2021-3-11 16:30 编辑
mikewolf2k 发表于 2021-3-11 09:39
"采用的是用输入圆上一点"——哪个点？确定在圆上？
确定是在圆上，是右象限点。而且事先已经关闭捕捉功能(不知道怎么关闭极轴追踪)，甚至也考虑了放大窗口，还是有时报错。如果采用其他标注类型实现，看起来有点别扭 我的想法是遍历CAD中的所有图元，如果是需要的圆，则直接给该对象进行标注，为了确保标注的圆是自己需要的，可以在画圆的时候利用setxdata方法给这个圆添加一个标识，通过对比确认 本帖最后由 sunny_8848 于 2021-3-12 11:03 编辑
谢谢解答。可是只会一点简单的eⅹcel vbα，能帮忙给个代码吗 这个圆是否在冻结的图层上？还有，它是与在同一个平面上？ 不是在冻结的图层上，也是在一个平面上。现在的问题是有时可以成功有时报错提示需要选择单个圆，一直找不到原因 Public Sub 画圆标注直径()
Dim AcAdApp As Object
Dim ThisDrawing As Object
On Error Resume Next
Set AcAdApp = GetObject(, "AutoCAD.Application")
If Err Then
MsgBox "请打开AutoCAD，再执行程序!", vbInformation
Exit Sub
End If
Set ThisDrawing = AcAdApp.ActiveDocument
Dim circleobj As Object
Dim centerpoint(0 To 2) As Double
Dim radius As Double
Dim returnPnt As Variant
returnPnt = ThisDrawing.Utility.GetPoint(, "请指定圆心点: ")
centerpoint(0) = returnPnt(0): centerpoint(1) = returnPnt(1): centerpoint(2) = returnPnt(2)
radius = ThisDrawing.Utility.GetDistance(returnPnt, "请输入半径R＝: ")
Set circleobj = ThisDrawing.ModelSpace.AddCircle(centerpoint, radius)
Dim dimobj As Object
Dim chordpoint(0 To 2) As Double
Dim farchordpoint(0 To 2) As Double
Dim leaderlength As Double
Dim Angle As Double
Angle = Atn(1#) '标注时与图上X轴正向的夹角，设为沿45°方向标注
chordpoint(0) = centerpoint(0) + radius * Cos(Angle)
chordpoint(1) = centerpoint(1) + radius * Sin(Angle)
chordpoint(2) = centerpoint(2)
farchordpoint(0) = centerpoint(0) - radius * Cos(Angle)
farchordpoint(1) = centerpoint(1) - radius * Sin(Angle)
farchordpoint(2) = centerpoint(2)
leaderlength = 1#
Set dimobj = ThisDrawing.ModelSpace.AddDimDiametric(chordpoint, farchordpoint, leaderlength)
End Sub 本帖最后由 sunny_8848 于 2021-3-12 19:38 编辑
yshf 发表于 2021-3-12 14:02
感谢帮忙，可以方便标注直径了。要怎么修改代码才能改成30-φ20配钻这样的标注形式，圆心点和半径依据单元格数据，这样就可以实现只需更改单元格数据，绘图时不需要人工介入。整个图纸中就这个直径标注特殊点，是比例图中画的，无法采用修改文字内容的方式。 Public Sub 画圆标注直径()
Dim AcAdApp As Object
Dim ThisDrawing As Object
On Error Resume Next
Set AcAdApp = GetObject(, "AutoCAD.Application")
If Err Then
MsgBox "请打开AutoCAD，再执行程序!", vbInformation
Exit Sub
End If
Set ThisDrawing = AcAdApp.ActiveDocument
Dim circleobj As Object
Dim centerpoint(0 To 2) As Double
Dim radius As Double
Dim returnPnt As Variant
AppActivate AcAdApp.Caption'将控制权转交给CAD
returnPnt = ThisDrawing.Utility.GetPoint(, "请指定圆心点: ")
centerpoint(0) = returnPnt(0): centerpoint(1) = returnPnt(1): centerpoint(2) = returnPnt(2)
radius = ThisDrawing.Utility.GetDistance(returnPnt, "请输入半径R＝: ")
Set circleobj = ThisDrawing.ModelSpace.AddCircle(centerpoint, radius)
Dim dimobj As Object
Dim chordpoint(0 To 2) As Double
Dim farchordpoint(0 To 2) As Double
Dim leaderlength As Double
Dim Angle As Double
Angle = Atn(1#) '标注时与图上X轴正向的夹角，设为沿45°方向标角
chordpoint(0) = centerpoint(0) + radius * Cos(Angle)
chordpoint(1) = centerpoint(1) + radius * Sin(Angle)
chordpoint(2) = centerpoint(2)
farchordpoint(0) = centerpoint(0) - radius * Cos(Angle)
farchordpoint(1) = centerpoint(1) - radius * Sin(Angle)
farchordpoint(2) = centerpoint(2)
leaderlength = 1#
Set dimobj = ThisDrawing.ModelSpace.AddDimDiametric(chordpoint, farchordpoint, leaderlength)
Dim Qzzfc As String
Qzzfc = "30-" & "φ"
dimobj.TextPrefix = Qzzfc'标注增加前缀字符
End Sub
页:
[1]
2