[求助]四边形或者六变形的面积式子

chman 发表于 2004-11-17 20:50:00

On Error GoTo ErrHandle Dim pnt Dim picked As Boolean Dim px() As Double Dim py() As Double Dim i, k As Integer Dim pcenter() As Double Dim insertdistance() As Double Me.Hide Do While 1 pnt = ThisDrawing.Utility.GetPoint ThisDrawing.SendCommand "-boundary" & vbCr & "a" & vbCr & "b" & vbCr & "e" & vbCr & vbCr & pnt(0) & "," & pnt(1) & vbCr & vbCr Set pr = ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1) Dim retCoord As Variant retCoord = pr.Coordinates k = (UBound(retCoord) + 1) / 2 '记录新绘制pline顶点个数 MsgBox "这是一个" & k & "边形" ReDim px(UBound(retCoord)) As Double ReDim py(UBound(retCoord)) As Double For i = 0 To UBound(retCoord) Step 2 px(i / 2) = retCoord(i) py(i / 2) = retCoord(i + 1) Next i ReDim insertdistance(k) As Double For i = 0 To k - 2 '用点选的方法获得点坐标，然后判断图形形状，计算形状面积,累加所有点选图形面积计算式。结果如图所示： A*B + C*D + E*F insertdistance(i) = Sqr((px(i) - px(i + 1)) * (px(i) - px(i + 1)) + (py(i) - py(i + 1)) * (py(i) - py(i + 1))) Next i '因为我只要求出四边形和六边形，并且还差一个判断，所有的角度是直角 If k = 4 Then ssss = insertdistance(0) & "*" & insertdistance(1) Else '还有一种情况是六边形 ssss = insertdistance(0) & "*" & insertdistance(1) & "+" & insertdistance(3) & "*" & insertdistance(4) '此处得到了是面积的式子，而且要求每次点击六边形或者四边行要把前面得到的式子再追加上来。…………………………………………………… End If MsgBox ssss '这里其实应该显示的结果如图所示 picked = True Loop ErrHandle: Me.Show 头疼的地方就在省略号的地方，我不知道如何将第一次选择图形所得到的公式继续追加起来，而且六边形的形状有四种，我的程序中只要考虑这四种情况，如何解决求面积公式，真是不知道如何是好，请多多指教，谢谢

雪山飞狐_lzh 发表于 2004-11-17 20:55:00

前几天的贴子就有，是求多边形的

chman 发表于 2004-11-17 23:27:00

本帖最后由作者于 2004-11-18 0:01:35 编辑

求多边形的公式的那个是用
Σ，数学方法求面积。。

现在问题是我想做到连续点击若干个长方形，或者是上面所示的六边形，输出的是公式，而不是最后面积的值

上面程序中我用ssss求出来的不是面积实数值，而是公式。

另外请问如何统计我开始点击了多少次。

雪山飞狐_lzh 发表于 2004-11-18 14:41:00

你要公式，他们贴的也是公式，不懂你的意思

chman 发表于 2004-11-18 20:44:00

On Error GoTo ErrHandle Dim pnt Dim picked As Boolean Dim px() As Double Dim py() As Double Dim i, k As Integer Dim pcenter() As Double Dim insertdistance() As Double Me.Hide Do While 1 pnt = ThisDrawing.Utility.GetPoint ThisDrawing.SendCommand "-boundary" & vbCr & "a" & vbCr & "b" & vbCr & "e" & vbCr & vbCr & pnt(0) & "," & pnt(1) & vbCr & vbCr Set pr = ThisDrawing.ModelSpace(ThisDrawing.ModelSpace.Count - 1) Dim retCoord As Variant retCoord = pr.Coordinates k = (UBound(retCoord) + 1) / 2 ReDim px(UBound(retCoord)) As Double ReDim py(UBound(retCoord)) As Double For i = 0 To UBound(retCoord) Step 2 px(i / 2) = retCoord(i) py(i / 2) = retCoord(i + 1) Next i ReDim insertdistance(k) As Double For i = 0 To k - 2 '用点选的方法获得点坐标，然后判断图形形状，计算形状面积,累加所有点选图形面积计算式。结果如图所示： A*B + C*D + E*F insertdistance(i) = Sqr((px(i) - px(i + 1)) * (px(i) - px(i + 1)) + (py(i) - py(i + 1)) * (py(i) - py(i + 1)))

ReDim pcenter(k) As Double ReDim insertdistance(k) As Double For i = 0 To k - 2 '此处要解决最后一个点和起始点的距离测定问题 pcenter(i) = (px(i) + px(i + 1)) / 2 pcenter(i + 1) = (py(i) + py(i + 1)) / 2 + 0.2 insertdistance(i) = Sqr((px(i) - px(i + 1)) * (px(i) - px(i + 1)) + (py(i) - py(i + 1)) * (py(i) - py(i + 1))) ThisDrawing.ModelSpace.AddText insertdistance(i), pcenter, 0.65%%%%%%%%%%当此语句存在时，程序就会出错，

 Next i If k = 4 Then '这是四边形的情况 ssss = insertdistance(0) & "*" & insertdistance(1) Else '还有一种情况是六边形 ssss = insertdistance(0) & "*" & insertdistance(1) & "+" & insertdistance(3) & "*" & insertdistance(4) '此处得到了是面积的式子，而且要求每次点击六边形或者四边行要把前面得到的式子再追加上来。…………………………………………………… End If MsgBox ssss '这里其实应该显示的结果如图所示 picked = True Loop ErrHandle: Me.Show

flytoday 发表于 2012-5-9 03:35:26

这种滴论坛没一种一定是特高难度哈哈

页: [1]

明经CAD社区's Archiver

[求助]四边形或者六变形的面积式子