面积计算VBA代码myfreemind 问题

smpoy

能不能没有比例尺的限制啊

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. Dim  us1  As  Integer  '比例尺
14. us1  =  ThisDrawing.GetVariable("userr1")  '取得比例尺For  i  =  0  To  ThisDrawing.SelectionSets.Count  -  1
15. ThisDrawing.SelectionSets.Item(i).Clear
16. ThisDrawing.SelectionSets.Item(i).Delete
17. NextSet  sset  =  ThisDrawing.SelectionSets.Add("sarea")sset.SelectOnScreen
18. If  sset.Item(0).Closed  =  False  Then
19. MsgBox  "图形不闭合，请检查！"
20. Exit  Sub
21. End  If
22. sset.Item(0).GetBoundingBox  minpnt,  maxpntareains(0)  =  (minpnt(0)  +  maxpnt(0))  /  2
23. areains(1)  =  (minpnt(1)  +  maxpnt(1))  /  2
24. areains(2)  =  0Select  Case  us1
25. Case  500
26. txtarea  =  sset.Item(0).area  /  4Case  1000
27. txtarea  =  sset.Item(0).area
28. Case  2000
29. txtarea  =  sset.Item(0).area  *  2
30.   Case  Else
31. MsgBox  "你的比例尺不在可计算之列,请检查你的比例尺"
32. Exit  SubEnd  Selectms  =  Format(txtarea  /  666.6666,  "#0.000")
33. txtarea  =  Format(txtarea,  "#0.000")txtins  =  "S="  &  txtarea  &  "平方米="  &  ms  &  "亩"Set  txtobj  =  ThisDrawing.ModelSpace.AddText(txtins,  areains,  5)txtobj.Color  =  acGreen
34. '*******************************Dim  hatchobj  As  AcadHatch
35. Dim  pname  As  String  '阴影名称
36. Dim  pype  As  Long  '阴影类型
37. pname  =  "ANSI31"
38. ptype  =  0Set  hatchobj  =  ThisDrawing.ModelSpace.AddHatch(ptype,  pname,  True)
39. Dim  outloop(0  To  0)  As  AcadEntitySet  outloop(0)  =  sset.Item(0)hatchobj.AppendOuterLoop  (outloop)
40. hatchobj.Evaluate
41. err:
42. Exit  Sub
43. End  Sub

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 NextSet  sset  =  ThisDrawing.SelectionSets.Add("sarea")sset.SelectOnScreen If  sset.Item(0).Closed  =  False  Then MsgBox  "图形不闭合，请检查！" Exit  Sub End  If sset.Item(0).GetBoundingBox  minpnt,  maxpntareains(0)  =  (minpnt(0)  +  maxpnt(0))  /  2 areains(1)  =  (minpnt(1)  +  maxpnt(1))  /  2 areains(2)  =  0Select  Case  us1 Case  500 txtarea  =  sset.Item(0).area  /  4Case  1000 txtarea  =  sset.Item(0).area Case  2000 txtarea  =  sset.Item(0).area  *  2   Case  Else MsgBox  "你的比例尺不在可计算之列,请检查你的比例尺" Exit  SubEnd  Selectms  =  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  =  0Set  hatchobj  =  ThisDrawing.ModelSpace.AddHatch(ptype,  pname,  True) Dim  outloop(0  To  0)  As  AcadEntitySet  outloop(0)  =  sset.Item(0)hatchobj.AppendOuterLoop  (outloop) hatchobj.Evaluate err: Exit  Sub End  Sub

smpoy

为什么非要加比例尺呢。 Case 1000
txtarea = sset.Item(0).area
Case 2000
txtarea = sset.Item(0).area * 2
Case Else
'''MsgBox "你的比例尺不在可计算之列,请检查你的比例尺" txtarea = sset.Item(0).area
''Exit Sub end sub 是不是这样就行了啊

smpoy

能不能点他区域内就能得出面积啊。