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

chman

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

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

chman

求多边形的公式的那个是用
< class=MsoNormal style="MARGIN: 0cm 0cm 0pt">Σ，数学方法求面积。。



< class=MsoNormal style="MARGIN: 0cm 0cm 0pt">现在问题是我想做到连续点击若干个长方形，或者是上面所示的六边形，输出的是公式，而不是最后面积的值



< class=MsoNormal style="MARGIN: 0cm 0cm 0pt">上面程序中我用ssss求出来的不是面积实数值，而是公式。


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

雪山飞狐_lzh

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

chman

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

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