Option Explicit
Public fl As Integer
Sub Flmjtj()
On Error Resume Next
Dim outtxt As String
Dim s(50) As Long
Dim zmj As Long
Dim zs As Integer
Dim i As Integer
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 Ftype As Variant
Dim FdataAs Variant
Dim entity As AcadEntity
Dim hatchobj As AcadHatch
Dim pname As String
Dim pype As Long
Dim outloop(0 To 0) As AcadEntity
Dim zminpnt(0 To 2) As Double
Dim zmaxpnt(0 To 2) As Double
Dim sclayer As String
Dim Fllayer As String
Dim out1 As String
Select Case fl
Case 0
Fllayer = "LD"
Case 1
Fllayer = "SY"
Case 2
Fllayer = "ALLTD"
End Select
Dim us1 As Integer
us1 = ThisDrawing.GetVariable("userr1")
sclayer = ThisDrawing.GetVariable("clayer")
If ThisDrawing.SelectionSets.Count > 0 Then
For i = 0 To ThisDrawing.SelectionSets.Count - 1
ThisDrawing.SelectionSets.Item(i).Clear
ThisDrawing.SelectionSets.Item(i).Delete
Next
End If
'**************
Dim gpCode(3) As Integer, dataValue(3) As Variant
'创建过滤器
'本例为过滤polyline or lwpolyline
'使用的是变体数组进行定义
'分组运算符
gpCode(0) = -4
dataValue(0) = "<or"
'polyline过滤器
gpCode(1) = 0
dataValue(1) = "PolyLINE"
'lwpolyline过滤器
gpCode(2) = 0
dataValue(2) = "LwPolyline"
'分组运算符
gpCode(3) = -4
dataValue(3) = "or>"
Ftype = gpCode
Fdata = dataValue
'**************
Set sset = ThisDrawing.SelectionSets.Add("smarea1")
'选择
sset.Select acSelectionSetAll, , , Ftype, Fdata
i = 1
For Each entity In sset
If entity.Layer = Fllayer Then
entity.GetBoundingBox minpnt, maxpnt
zminpnt(0) = minpnt(0) - 250
zminpnt(1) = minpnt(1) - 250
zminpnt(2) = 0
zmaxpnt(0) = maxpnt(0) + 250
zmaxpnt(1) = maxpnt(1) + 250
zmaxpnt(2) = 0
If entity.Closed = False Then
ThisDrawing.Application.ZoomWindow zminpnt, zmaxpnt
entity.Color = acRed
entity.Highlight True '高亮
MsgBox "当前视口图形不闭合，请检查！"
Exit Sub
End If
'判断比例尺
Select Case us1
Case 500
txtarea = entity.Area / 4
Case 1000
txtarea = entity.Area
Case 2000
txtarea = entity.Area * 4
Case Else
MsgBox "你的比例尺不在可计算之列,请检查你的比例尺"
Exit Sub
End Select
s(i) = txtarea
form1.TextBox1.Text = i
i = i + 1
End If
Next
zs = i
For i = 1 To zs
zmj = zmj + s(i)
Next
Select Case fl
Case 0
outtxt = "绿地总面积=" & Format(zmj, "#0.00") & "平方米" & "=" & Format(zmj / 666.66666, "####0.00") & "亩"
out1 = "******************************************" & vbCrLf & outtxt & vbCrLf & "******************************************"
Case 1
outtxt = "水域总面积=" & Format(zmj, "#0.00") & "平方米" & "=" & Format(zmj / 666.66666, "####0.00") & "亩"
out1 = "******************************************" & vbCrLf & outtxt & vbCrLf & "******************************************"
End Select
form1.Label1.Caption = out1
'Debug.Print out1
'Open "l:\flmj.txt" For Output As #1
'Print #1, out1
'Close #1
'MsgBox zmj
sset.Clear
sset.Delete
End Sub 非常谢谢myfreemind,这两天没上网,你的程序还没来得及细看,我是要统计各村组的各种土地利用情况,我也是给每个多边形加了属性,但村组之间分开还是要分别选.
页:
1
[2]