请明经的CAD高手帮忙修改！！！

ctclsc

要求：1将标注中的直线部分改为箭头（leader） 2文字对正为圆心 3通过stretch命令将标注拉伸时，箭头延长线仍然通过圆心 谢谢！！！ Sub 件号()
RETRY:
Dim P1 As Variant, P2 As Variant
Dim textobject(0) As AcadObject: Dim line1 As AcadLine: Dim Cirobj As AcadCircle
Dim ppt(0 To 2) As Double: Dim Numbers1 As String: Dim Inserpt(0 To 2) As Double

On Error Resume Next
P1 = ThisDrawing.Utility.GetPoint(, "请指定件号起点：")
If Err <> 0 Then
Err.Clear
ThisDrawing.Utility.Prompt " 没有指定件号起点,退出"
Exit Sub
End If
P2 = ThisDrawing.Utility.GetPoint(, "请指定件号放置点：")
If Err <> 0 Then
Err.Clear
ThisDrawing.Utility.Prompt " 没有指定件号放置点,退出"
Exit Sub
End If
Set line1 = ThisDrawing.ModelSpace.AddLine(P1, P2)
TextHeight = ThisDrawing.GetVariable("dimscale") * 3 '文字高度为标注比例x3
ppt(0) = P2(0) + 0.7 * TextHeight: ppt(1) = P2(1) - 0.5 * TextHeight: ppt(2) = P2(2)
Set Cirobj = ThisDrawing.ModelSpace.AddCircle(P2, GetVariable("dimscale") * 3.5) '件号直径为标注比例x7
P2 = Cirobj.IntersectWith(line1, acExtendNone) '求交点
line1.EndPoint = P2 '剪切引线

Numbers1 = ThisDrawing.Utility.GetString(0, vbCrLf & "<<结构设计科件号标注>>" & vbCrLf & "请输入件号值:")
If Numbers1 = "" Then Numbers1 = Nums
If Len(Numbers1) = 2 Then
Inserpt(0) = ppt(0) - 1.45 * TextHeight: Inserpt(1) = ppt(1) + 0.01 * TextHeight: Inserpt(2) = ppt(2)
End If
If Len(Numbers1) = 1 Then
Inserpt(0) = ppt(0) - 1.01 * TextHeight: Inserpt(1) = ppt(1) + 0.01 * TextHeight: Inserpt(2) = ppt(2)
End If
If Len(Numbers1) = 3 Then
Inserpt(0) = ppt(0) - 1.75 * TextHeight: Inserpt(1) = ppt(1) + 0.01 * TextHeight: Inserpt(2) = ppt(2)
End If

Set textobject(0) = ThisDrawing.ModelSpace.AddText(Numbers1, Inserpt, TextHeight)

Nums = Numbers1 '使提示与上一件号关联
Nums = Nums + 1
Dim Group2 As AcadGroup
Dim objgroup(0 To 2) As AcadEntity
Set objgroup(0) = line1
Set objgroup(1) = Cirobj
Set objgroup(2) = textobject(0)
Set Group1 = ThisDrawing.Groups.Add("*")
Group1.AppendItems objgroup GoTo RETRY
End Sub

mccad

1.变成箭头直接用AddLeader就可以，但注意其坐标的格式。
2.点2可直接去掉圆半径，而不需要画后再改坐标。
3.文字对齐圆心可以在写完文字后，把其对齐方式改成中心，再移动到圆心上。
4在拉伸后还需要箭头通过圆心，这一点只有通过事件来驱动了。

ctclsc

请2楼将修改后的给我好吗

雪山飞狐_lzh

这里有一个简单例子 http://bbs.mjtd.com/forum.php?mod=viewthread&tid=29620