社区 › VB › 画圆后标注直径有时无法选中圆

sunny_8848 发表于 2021-3-11 08:34:00

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

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

mikewolf2k 发表于 2021-3-11 09:39:00

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

sunny_8848 发表于 2021-3-11 16:18:00

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

flypig 发表于 2021-3-11 18:34:00

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

sunny_8848 发表于 2021-3-11 18:55:00

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

mokson 发表于 2021-3-12 10:45:00

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

sunny_8848 发表于 2021-3-12 10:53:00

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

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

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 16:37:00

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

yshf 发表于 2021-3-12 19:50:00

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

查看完整版本: 画圆后标注直径有时无法选中圆