明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 6887|回复: 16

面积计算程序原代码!

  [复制链接]
发表于 2003-7-9 23:46 | 显示全部楼层 |阅读模式
  1. Sub sarea() '计算多边形面积程序
  2. On Error GoTo err
  3. Dim areaobj As AcadLWPolyline
  4. Dim sset As AcadSelectionSet
  5. Dim minpnt As Variant
  6. Dim maxpnt As Variant
  7. Dim areains(0 To 2) As Double '
  8. Dim txtarea As String
  9. Dim txtins As String
  10. Dim ms As String
  11. Dim txtobj As AcadText


  12. Dim us1 As Integer '比例尺
  13. us1 = ThisDrawing.GetVariable("userr1") '取得比例尺

  14. For i = 0 To ThisDrawing.SelectionSets.Count - 1
  15. ThisDrawing.SelectionSets.Item(i).Clear
  16. ThisDrawing.SelectionSets.Item(i).Delete
  17. Next

  18. Set sset = ThisDrawing.SelectionSets.Add("sarea")

  19. sset.SelectOnScreen
  20. If sset.Item(0).Closed = False Then
  21. MsgBox "图形不闭合,请检查!"
  22. Exit Sub
  23. End If


  24. sset.Item(0).GetBoundingBox minpnt, maxpnt

  25. areains(0) = (minpnt(0) + maxpnt(0)) / 2
  26. areains(1) = (minpnt(1) + maxpnt(1)) / 2
  27. areains(2) = 0

  28. Select Case us1
  29. Case 500
  30. txtarea = sset.Item(0).area / 4

  31. Case 1000
  32. txtarea = sset.Item(0).area
  33. Case 2000
  34. txtarea = sset.Item(0).area * 2
  35. Case Else
  36. MsgBox "你的比例尺不在可计算之列,请检查你的比例尺"
  37. Exit Sub

  38. End Select

  39. ms = Format(txtarea / 666.6666, "#0.000")
  40. txtarea = Format(txtarea, "#0.000")

  41. txtins = "S=" & txtarea & "平方米=" & ms & "亩"

  42. Set txtobj = ThisDrawing.ModelSpace.AddText(txtins, areains, 5)

  43. txtobj.Color = acGreen
  44. '*******************************

  45. Dim hatchobj As AcadHatch
  46. Dim pname As String '阴影名称
  47. Dim pype As Long '阴影类型
  48. pname = "ANSI31"
  49. ptype = 0

  50. Set hatchobj = ThisDrawing.ModelSpace.AddHatch(ptype, pname, True)
  51. Dim outloop(0 To 0) As AcadEntity

  52. Set outloop(0) = sset.Item(0)

  53. hatchobj.AppendOuterLoop (outloop)
  54. hatchobj.Evaluate


  55. err:
  56. Exit Sub
  57. End Sub

点评

太给力了,。,请问能体现加减乘除计算规则吗  发表于 2011-12-28 22:21
发表于 2003-7-10 09:56 | 显示全部楼层
为什么不用cad的查询命令?现成的呀,有时只不过要把封闭区域变成面域而已!
发表于 2003-7-10 12:38 | 显示全部楼层
非常感谢myfreemind老师,对于你的慷慨我很是感动,再次感谢。希望日后还能多多指点。
只是我不懂VBA,看来回去要研究一下了。
 楼主| 发表于 2003-7-10 23:15 | 显示全部楼层
不谢,一起提高!
 楼主| 发表于 2003-7-10 23:17 | 显示全部楼层

是的,可以实现!

目的是为了学习程序!
发表于 2003-12-17 16:48 | 显示全部楼层
实在是感谢
发表于 2003-12-28 23:43 | 显示全部楼层
very good
发表于 2004-1-15 19:01 | 显示全部楼层
这是个好东西!送花一朵!

我研究研究!
发表于 2004-1-15 19:02 | 显示全部楼层
刚才忘记了!你怎么又变成蒙面侠了?
 楼主| 发表于 2004-1-15 19:45 | 显示全部楼层
chb801发表于2004-1-15 19:02:00刚才忘记了!你怎么又变成蒙面侠了?


升级了,呵呵
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 17:23 , Processed in 0.304919 second(s), 29 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表