用VBA编程，画一条曲线，如用三个点，怎么画？ - VBA/VB/ActiveX/API 编程技术 - AutoCAD论坛 - 明经CAD社区 - 第2页 - Powered by Discuz! Archiver

社区 › VBA/VB/ActiveX/API 编程技术 › 用VBA编程，画一条曲线，如用三个点，怎么画？

zfbj 发表于 2004-5-16 16:45:00

<P class=MsoNormal style="MARGIN: 0cm 0cm 0pt">三点法（起点、第二点和终点）创建圆弧，首先计算出圆弧的圆心和半径，然后根据圆心、起点和终点，创建圆弧对象，其实现代码为：

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2>Public Function AddArc3Pt(ByVal ptSt As Variant, ByVal ptSc As Variant, ByVal ptEn As Variant) As AcadArc</FONT>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> Dim objArc As AcadArc</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> Dim ptCen As Variant</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> Dim radius As Double</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> ptCen = GetCenOf3Pt(ptSt, ptSc, ptEn, radius)</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><SPAN style="mso-spacerun: yes"><FONT size=2> </FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> Set objArc = AddArcCSEP(ptCen, ptSt, ptEn)</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> objArc.color = acGreen</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> objArc.Update</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><SPAN style="mso-spacerun: yes"><FONT size=2> </FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> Set AddArc3Pt = objArc</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2>End Function</FONT>

<P class=MsoNormal style="MARGIN: 0cm 0cm 0pt"><FONT face="Times New Roman">GetCenOf3Pt</FONT>是自定义的函数，能够根据三点计算出圆心和半径，其实现代码为：

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2>Public Function GetCenOf3Pt(pt1 As Variant, pt2 As Variant, pt3 As Variant, _</FONT>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> ByRef radius As Double) As Variant</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><SPAN style="mso-spacerun: yes"><FONT size=2> </FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> Dim xysm, xyse, xy As Double</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> Dim ptCen(2) As Double</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><SPAN style="mso-spacerun: yes"><FONT size=2> </FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> xy = pt1(0) ^ 2 + pt1(1) ^ 2</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> xyse = xy - pt3(0) ^ 2 - pt3(1) ^ 2</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> xysm = xy - pt2(0) ^ 2 - pt2(1) ^ 2</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> xy = (pt1(0) - pt2(0)) * (pt1(1) - pt3(1)) - (pt1(0) - pt3(0)) * (pt1(1) - pt2(1))</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><SPAN style="mso-spacerun: yes"><FONT size=2> </FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> '</SPAN>判断参数有效性</FONT>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> If Abs(xy) < 0.000001 Then</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> MsgBox "</SPAN>所输入的参数无法创建圆形！"</FONT>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> Exit Function</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> End If</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><SPAN style="mso-spacerun: yes"><FONT size=2> </FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> '</SPAN>获得圆心和半径</FONT>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> ptCen(0) = (xysm * (pt1(1) - pt3(1)) - xyse * (pt1(1) - pt2(1))) / (2 * xy)</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> ptCen(1) = (xyse * (pt1(0) - pt2(0)) - xysm * (pt1(0) - pt3(0))) / (2 * xy)</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> ptCen(2) = 0</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> radius = Sqr((pt1(0) - ptCen(0)) * (pt1(0) - ptCen(0)) + (pt1(1) - ptCen(1)) * (pt1(1) - ptCen(1)))</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><SPAN style="mso-spacerun: yes"><FONT size=2> </FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> If radius < 0.000001 Then</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> MsgBox "</SPAN>半径过小！"</FONT>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> Exit Function</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> End If</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><SPAN style="mso-spacerun: yes"><FONT size=2> </FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> '</SPAN>函数返回圆心的位置，而半径则在参数中通过引用方式返回</FONT>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2><SPAN style="mso-spacerun: yes"> GetCenOf3Pt = ptCen</FONT></SPAN>

<P class=a2 style="MARGIN: 0cm 0cm 0pt"><FONT size=2>End Function</FONT>

<P class=MsoNormal style="MARGIN: 0cm 0cm 0pt">需要注意的是，<FONT face="Times New Roman">radius</FONT>参数是按地址传递的，因此也是函数的返回值。

<P class=MsoNormal style="MARGIN: 0cm 0cm 0pt">

<P class=MsoNormal style="MARGIN: 0cm 0cm 0pt">

<P class=MsoNormal style="MARGIN: 0cm 0cm 0pt">摘自《AutoCAD VBA精彩实例教程》第2章相关内容。

nxy_918 发表于 2004-5-17 09:46:00

这里有现成的

<A href="http://www.vba.cn/function/list.asp?id=339&ordertype=byletter" target="_blank" >http://www.vba.cn/function/list.asp?id=339&ordertype=byletter</A>

页: 1 [2]

查看完整版本: 用VBA编程，画一条曲线，如用三个点，怎么画？