面积计算程序原代码!

myfreemind

2. Sub sarea() '计算多边形面积程序
   
3. On Error GoTo err
   
4. Dim areaobj As AcadLWPolyline
   
5. Dim sset As AcadSelectionSet
   
6. Dim minpnt As Variant
   
7. Dim maxpnt As Variant
   
8. Dim areains(0 To 2) As Double '
   
9. Dim txtarea As String
   
10. Dim txtins As String
    
11. Dim ms As String
    
12. Dim txtobj As AcadText
    
13. 
    
14. 
    
15. Dim us1 As Integer '比例尺
    
16. us1 = ThisDrawing.GetVariable("userr1") '取得比例尺
    
17. 
    
18. For i = 0 To ThisDrawing.SelectionSets.Count - 1
    
19. ThisDrawing.SelectionSets.Item(i).Clear
    
20. ThisDrawing.SelectionSets.Item(i).Delete
    
21. Next
    
22. 
    
23. Set sset = ThisDrawing.SelectionSets.Add("sarea")
    
24. 
    
25. sset.SelectOnScreen
    
26. If sset.Item(0).Closed = False Then
    
27. MsgBox "图形不闭合，请检查！"
    
28. Exit Sub
    
29. End If
    
30. 
    
31. 
    
32. sset.Item(0).GetBoundingBox minpnt, maxpnt
    
33. 
    
34. areains(0) = (minpnt(0) + maxpnt(0)) / 2
    
35. areains(1) = (minpnt(1) + maxpnt(1)) / 2
    
36. areains(2) = 0
    
37. 
    
38. Select Case us1
    
39. Case 500
    
40. txtarea = sset.Item(0).area / 4
    
41. 
    
42. Case 1000
    
43. txtarea = sset.Item(0).area
    
44. Case 2000
    
45. txtarea = sset.Item(0).area * 2
    
46. Case Else
    
47. MsgBox "你的比例尺不在可计算之列,请检查你的比例尺"
    
48. Exit Sub
    
49. 
    
50. End Select
    
51. 
    
52. ms = Format(txtarea / 666.6666, "#0.000")
    
53. txtarea = Format(txtarea, "#0.000")
    
54. 
    
55. txtins = "S=" & txtarea & "平方米=" & ms & "亩"
    
56. 
    
57. Set txtobj = ThisDrawing.ModelSpace.AddText(txtins, areains, 5)
    
58. 
    
59. txtobj.Color = acGreen
    
60. '*******************************
    
61. 
    
62. Dim hatchobj As AcadHatch
    
63. Dim pname As String '阴影名称
    
64. Dim pype As Long '阴影类型
    
65. pname = "ANSI31"
    
66. ptype = 0
    
67. 
    
68. Set hatchobj = ThisDrawing.ModelSpace.AddHatch(ptype, pname, True)
    
69. Dim outloop(0 To 0) As AcadEntity
    
70. 
    
71. Set outloop(0) = sset.Item(0)
    
72. 
    
73. hatchobj.AppendOuterLoop (outloop)
    
74. hatchobj.Evaluate
    
75. 
    
76. 
    
77. err:
    
78. Exit Sub
    
79. End Sub
    

Sub sarea() '计算多边形面积程序<br /> On Error GoTo err<br /> Dim areaobj As AcadLWPolyline<br /> Dim sset As AcadSelectionSet<br /> Dim minpnt As Variant<br /> Dim maxpnt As Variant<br /> Dim areains(0 To 2) As Double '<br /> Dim txtarea As String<br /> Dim txtins As String<br /> Dim ms As String<br /> Dim txtobj As AcadText<br /> <br /> <br /> Dim us1 As Integer '比例尺<br /> us1 = ThisDrawing.GetVariable("userr1") '取得比例尺<br /> <br /> For i = 0 To ThisDrawing.SelectionSets.Count - 1<br /> ThisDrawing.SelectionSets.Item(i).Clear<br /> ThisDrawing.SelectionSets.Item(i).Delete<br /> Next<br /> <br /> Set sset = ThisDrawing.SelectionSets.Add("sarea")<br /> <br /> sset.SelectOnScreen<br /> If sset.Item(0).Closed = False Then<br /> MsgBox "图形不闭合，请检查！"<br /> Exit Sub<br /> End If<br /> <br /> <br /> sset.Item(0).GetBoundingBox minpnt, maxpnt<br /> <br /> areains(0) = (minpnt(0) + maxpnt(0)) / 2<br /> areains(1) = (minpnt(1) + maxpnt(1)) / 2<br /> areains(2) = 0<br /> <br /> Select Case us1<br /> Case 500<br /> txtarea = sset.Item(0).area / 4<br /> <br /> Case 1000<br /> txtarea = sset.Item(0).area<br /> Case 2000<br /> txtarea = sset.Item(0).area * 2<br /> Case Else<br /> MsgBox "你的比例尺不在可计算之列,请检查你的比例尺"<br /> Exit Sub<br /> <br /> End Select<br /> <br /> ms = Format(txtarea / 666.6666, "#0.000")<br /> txtarea = Format(txtarea, "#0.000")<br /> <br /> txtins = "S=" & txtarea & "平方米=" & ms & "亩"<br /> <br /> Set txtobj = ThisDrawing.ModelSpace.AddText(txtins, areains, 5)<br /> <br /> txtobj.Color = acGreen<br /> '*******************************<br /> <br /> Dim hatchobj As AcadHatch<br /> Dim pname As String '阴影名称<br /> Dim pype As Long '阴影类型<br /> pname = "ANSI31"<br /> ptype = 0<br /> <br /> Set hatchobj = ThisDrawing.ModelSpace.AddHatch(ptype, pname, True)<br /> Dim outloop(0 To 0) As AcadEntity<br /> <br /> Set outloop(0) = sset.Item(0)<br /> <br /> hatchobj.AppendOuterLoop (outloop)<br /> hatchobj.Evaluate<br /> <br /> <br /> err:<br /> Exit Sub<br /> End Sub<br />

xazhji

为什么不用cad的查询命令？现成的呀，有时只不过要把封闭区域变成面域而已！

lihongyu2467

非常感谢myfreemind老师，对于你的慷慨我很是感动，再次感谢。希望日后还能多多指点。
只是我不懂VBA，看来回去要研究一下了。

myfreemind

不谢，一起提高！

myfreemind

目的是为了学习程序！

movie2003

实在是感谢

lixy

very good

chb801

这是个好东西！送花一朵！

我研究研究！

chb801

刚才忘记了！你怎么又变成蒙面侠了？

myfreemind

chb801发表于2004-1-15 19:02:00刚才忘记了！你怎么又变成蒙面侠了？

升级了，呵呵