面积计算程序原代码!
Sub sarea() '计算多边形面积程序On Error GoTo err
Dim areaobj As AcadLWPolyline
Dim sset As AcadSelectionSet
Dim minpnt As Variant
Dim maxpnt As Variant
Dim areains(0 To 2) As Double '
Dim txtarea As String
Dim txtins As String
Dim ms As String
Dim txtobj As AcadText
Dim us1 As Integer '比例尺
us1 = ThisDrawing.GetVariable("userr1") '取得比例尺
For i = 0 To ThisDrawing.SelectionSets.Count - 1
ThisDrawing.SelectionSets.Item(i).Clear
ThisDrawing.SelectionSets.Item(i).Delete
Next
Set sset = ThisDrawing.SelectionSets.Add("sarea")
sset.SelectOnScreen
If sset.Item(0).Closed = False Then
MsgBox "图形不闭合，请检查！"
Exit Sub
End If
sset.Item(0).GetBoundingBox minpnt, maxpnt
areains(0) = (minpnt(0) + maxpnt(0)) / 2
areains(1) = (minpnt(1) + maxpnt(1)) / 2
areains(2) = 0
Select Case us1
Case 500
txtarea = sset.Item(0).area / 4
Case 1000
txtarea = sset.Item(0).area
Case 2000
txtarea = sset.Item(0).area * 2
Case Else
MsgBox "你的比例尺不在可计算之列,请检查你的比例尺"
Exit Sub
End Select
ms = Format(txtarea / 666.6666, "#0.000")
txtarea = Format(txtarea, "#0.000")
txtins = "S=" & txtarea & "平方米=" & ms & "亩"
Set txtobj = ThisDrawing.ModelSpace.AddText(txtins, areains, 5)
txtobj.Color = acGreen
'*******************************
Dim hatchobj As AcadHatch
Dim pname As String '阴影名称
Dim pype As Long '阴影类型
pname = "ANSI31"
ptype = 0
Set hatchobj = ThisDrawing.ModelSpace.AddHatch(ptype, pname, True)
Dim outloop(0 To 0) As AcadEntity
Set outloop(0) = sset.Item(0)
hatchobj.AppendOuterLoop (outloop)
hatchobj.Evaluate
err:
Exit Sub
End Sub
为什么不用cad的查询命令？现成的呀，有时只不过要把封闭区域变成面域而已！ 非常感谢myfreemind老师，对于你的慷慨我很是感动，再次感谢。希望日后还能多多指点。
只是我不懂VBA，看来回去要研究一下了。 不谢，一起提高！
是的，可以实现！
目的是为了学习程序！ 实在是感谢 very good 这是个好东西！送花一朵！我研究研究！ 刚才忘记了！你怎么又变成蒙面侠了？ chb801发表于2004-1-15 19:02:00static/image/common/back.gif刚才忘记了！你怎么又变成蒙面侠了？
升级了，呵呵
页:
[1]
2