ctclsc 发表于 2005-4-3 09:17:00

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

要求：1将标注中的直线部分改为箭头（leader）


2文字对正为圆心


3通过stretch命令将标注拉伸时，箭头延长线仍然通过圆心


谢谢！！！


Sub 件号()<BR>RETRY:<BR>                       Dim P1 As Variant, P2 As Variant<BR>                       Dim textobject(0) As AcadObject: <FONT color=#f70968>Dim line1 As AcadLine</FONT>: Dim Cirobj As AcadCircle<BR>                       Dim ppt(0 To 2) As Double:       Dim Numbers1 As String: Dim Inserpt(0 To 2) As Double<BR>                       <BR>                               On Error Resume Next<BR>                               P1 = ThisDrawing.Utility.GetPoint(, "请指定件号起点：")<BR>                                                               If Err &lt;&gt; 0 Then<BR>                                                                                                                       Err.Clear<BR>                                                                                                                       ThisDrawing.Utility.Prompt " 没有指定件号起点,退出"<BR>                                                                                                                       Exit Sub<BR>                                                                       End If<BR>                               P2 = ThisDrawing.Utility.GetPoint(, "请指定件号放置点：")<BR>                                                       If Err &lt;&gt; 0 Then<BR>                                                                                                                       Err.Clear<BR>                                                                                                                       ThisDrawing.Utility.Prompt " 没有指定件号放置点,退出"<BR>                                                                                                                       Exit Sub<BR>                                                                       End If<BR>       <FONT color=#f70968>Set line1 = ThisDrawing.ModelSpace.AddLine(P1, P2)</FONT><BR>       TextHeight = ThisDrawing.GetVariable("dimscale") * 3 '文字高度为标注比例x3<BR>       ppt(0) = P2(0) + 0.7 * TextHeight: ppt(1) = P2(1) - 0.5 * TextHeight: ppt(2) = P2(2)<BR>       Set Cirobj = ThisDrawing.ModelSpace.AddCircle(P2, GetVariable("dimscale") * 3.5) '件号直径为标注比例x7<BR>                       P2 = Cirobj.IntersectWith(line1, acExtendNone) '求交点<BR>                       line1.EndPoint = P2               '剪切引线<BR>                                       <BR>                       Numbers1 = ThisDrawing.Utility.GetString(0, vbCrLf &amp; "&lt;&lt;结构设计科件号标注&gt;&gt;" &amp; vbCrLf &amp; "请输入件号值:")<BR>                       If Numbers1 = "" Then Numbers1 = Nums<BR>                       If Len(Numbers1) = 2 Then<BR>                                       Inserpt(0) = ppt(0) - 1.45 * TextHeight: Inserpt(1) = ppt(1) + 0.01 * TextHeight: Inserpt(2) = ppt(2)<BR>                       End If<BR>                       If Len(Numbers1) = 1 Then<BR>                               Inserpt(0) = ppt(0) - 1.01 * TextHeight: Inserpt(1) = ppt(1) + 0.01 * TextHeight: Inserpt(2) = ppt(2)<BR>                       End If<BR>                       If Len(Numbers1) = 3 Then<BR>                               Inserpt(0) = ppt(0) - 1.75 * TextHeight: Inserpt(1) = ppt(1) + 0.01 * TextHeight: Inserpt(2) = ppt(2)<BR>                       End If<BR>                       <BR>                       Set textobject(0) = ThisDrawing.ModelSpace.AddText(Numbers1, Inserpt, TextHeight)<BR>                       <BR>                       Nums = Numbers1 '使提示与上一件号关联<BR>                       Nums = Nums + 1<BR>Dim Group2 As AcadGroup<BR>Dim objgroup(0 To 2) As AcadEntity<BR>Set objgroup(0) = line1<BR>Set objgroup(1) = Cirobj<BR>Set objgroup(2) = textobject(0)<BR>        Set Group1 = ThisDrawing.Groups.Add("*")<BR>        Group1.AppendItems objgroup


GoTo RETRY<BR>End Sub<BR>

mccad 发表于 2005-4-4 21:30:00

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

ctclsc 发表于 2005-4-5 18:17:00

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

雪山飞狐_lzh 发表于 2005-4-5 20:27:00

这里有一个简单例子


<A href="http://bbs.mjtd.com/forum.php?mod=viewthread&tid=29620" target="_blank" >http://bbs.mjtd.com/forum.php?mod=viewthread&tid=29620</A>
页: [1]
查看完整版本: 请明经的CAD高手帮忙修改！！！