[原创]：VBA练习:画三角形及其中线的程序

麻雀

试着编了一个，请指教：

Sub test()
    Dim pnt1, pnt2, pnt3 As Variant
    Dim entLine1 As AcadLine, entLine2 As AcadLine, entLine3 As AcadLine

    '输入三顶点
  pnt1 = ThisDrawing.Utility.GetPoint(, "输入第一个顶点：")
    pnt2 = ThisDrawing.Utility.GetPoint(, "输入第二个顶点：")
    pnt3 = ThisDrawing.Utility.GetPoint(, "输入第三个顶点：")

    '画三角形
  Set entLine1 = ThisDrawing.ModelSpace.AddLine(pnt1, pnt2)
    Set entLine2 = ThisDrawing.ModelSpace.AddLine(pnt2, pnt3)
    Set entLine3 = ThisDrawing.ModelSpace.AddLine(pnt3, pnt1)

    '画中线
  Call LineFromPtoMidL(pnt1, entLine2)
    Call LineFromPtoMidL(pnt2, entLine3)
    Call LineFromPtoMidL(pnt3, entLine1)
   
End Sub

Function LineFromPtoMidL(pnt As Variant, entLine As AcadLine) As AcadLine
    Dim pntMid(2) As Double
    Dim pntStart, pntEnd As Variant
    Dim i As Integer
    pntStart = entLine.StartPoint
    pntEnd = entLine.EndPoint
    For i = 0 To 2
        pntMid(i) = (pntStart(i) + pntEnd(i)) / 2
    Next
    Set LineFromPtoMidL = ThisDrawing.ModelSpace.AddLine(pnt, pntMid)
End Function

雪山飞狐(lzh)

提点意见
1、没有出错处理（三点成一线的判断）
2、如果画线像AutoCAD命令一样有橡皮筋，画第二条时第一条直线已画出（相当于Line命令效果）就更完美了
申明一点：
如果可以完成我的要求或比我的要求做得更好，可以得到加币

maplesu

哈哈！
这个是不是长不大斑主的入门练习题呀！
可是那个似乎是要求画角平分线。
看看我做的，是角平分线的，有lzh741206斑主要求的判断三点是否在一直线上。


根据lzh741206斑主的提示修改完毕！[/COLOR]


[PHP]
Sub test()

Dim pt1, pt2, pt3 As Variant
Dim Line1 As AcadLine, Line2 As AcadLine, Line3 As AcadLine
Dim a1, a2, a3, da1, da2 As Double


'取得顶点，画三角形
pt1 = ThisDrawing.Utility.GetPoint(, "输入第一个顶点：")
pt2 = ThisDrawing.Utility.GetPoint(pt1, "输入第二个顶点：")
Set Line1 = ThisDrawing.ModelSpace.AddLine(pt1, pt2)
pt3 = ThisDrawing.Utility.GetPoint(pt2, "输入第三个顶点：")
a1 = ThisDrawing.Utility.AngleFromXAxis(pt1, pt2)
a2 = ThisDrawing.Utility.AngleFromXAxis(pt1, pt3)
a3 = ThisDrawing.Utility.AngleFromXAxis(pt3, pt1)
da1 = Abs(a1 - a2)
da2 = Abs(a1 - a3)
While da1 < 0.00001 Or da2 < 0.00001
pt3 = ThisDrawing.Utility.GetPoint(pt2, "错误：三点在同一直线上！！\n输入第三个顶点：")
a2 = ThisDrawing.Utility.AngleFromXAxis(pt1, pt3)
a3 = ThisDrawing.Utility.AngleFromXAxis(pt3, pt1)
da1 = Abs(a1 - a2)
da2 = Abs(a1 - a3)
Wend

Set Line2 = ThisDrawing.ModelSpace.AddLine(pt2, pt3)
Set Line3 = ThisDrawing.ModelSpace.AddLine(pt3, pt1)

'画角平分线
Call LineFromBisector(pt1, Line2)
Call LineFromBisector(pt2, Line3)
Call LineFromBisector(pt3, Line1)

End Sub

Function LineFromBisector(pt As Variant, Line As AcadLine) As AcadLine

Dim retangle1, retangle2, a As Double
Dim ps, pe, pt2, jd As Variant
ps = Line.StartPoint
pe = Line.EndPoint
retangle1 = ThisDrawing.Utility.AngleFromXAxis(pt, ps)
retangle2 = ThisDrawing.Utility.AngleFromXAxis(pt, pe)
a = (retangle1 + retangle2) / 2
pt2 = ThisDrawing.Utility.PolarPoint(pt, a, 10)
Set LineFromBisector = ThisDrawing.ModelSpace.AddLine(pt, pt2)
jd = Line.IntersectWith(LineFromBisector, acExtendBoth)
LineFromBisector.EndPoint = jd
End Function

[/PHP]

雪山飞狐(lzh)

先给你加上，LineFromBisector子函数还有待改进

maplesu

对于LineFromBisector子程序
在那方面需要改进，请lzh741206斑竹给个建议！

雪山飞狐(lzh)

Set linetemp = ThisDrawing.ModelSpace.AddLine(pt, pt2)
jd = Line.IntersectWith(linetemp, acExtendBoth)
linetemp.Erase
Set LineFromBisector = ThisDrawing.ModelSpace.AddLine(pt, jd)
这里，VBA里直接更改直线的EndPoint属性就可以了，不需擦去重生成

maplesu

谢谢！lzh741206版主！
由于才开始学习vba所以现在还只会话，不太会改对象的属性，
这个我先试试看！

哈哈，我搞定了，原来直接把端点赋值就可以了！
我把
linetemp.Erase
Set LineFromBisector = ThisDrawing.ModelSpace.AddLine(pt, jd)
给改为了
linetemp.EndPoint = jd

就可以了！