二调图封闭区域内的面积统计
Dim PlineObj As VariantDim point1 As Variant
Dim point2(0 To 2) As Double
Dim point3(0 To 2) As Double
Dim number As Integer
Dim T As Integer
Dim char As String '定义要获得的字符串
Dim dldm As String '定义地类代码
Dim sts As Double '定义水塘存储的面积变量
Close #1
Open "c:\二调地类@815.txt" For Append As #1
Close #1
Kill "c:\二调地类@815.txt"
Close #2
Open "c:\二调地类面积统计@815.txt" For Append As #2
Close #2
Kill "c:\二调地类面积统计@815.txt"
Set sset = ThisDrawing.SelectionSets.Add(str(Int(Timer))) '用秒数，选择集不会重复
sset.SelectOnScreen '提示用户选择
ZoomExtents
For Each element In sset '在选择集中进行循环
If element.ObjectName = "AcDbText" Then'对文字的处理
If Len(element.TextString) > 6 Then
T = 0
char = element.TextString
dldm = Right(char, 3)
point1 = element.InsertionPoint '得到块的插入点坐标
Dim spt As String
Dim s As Double
spt = point1(0) & "," & point1(1)
ThisDrawing.SendCommand Chr(3) & Chr(3) & "-boundary " & spt & " " & " "
ThisDrawing.SendCommand "draworder lastf "
ThisDrawing.SendCommand "_.area o last "
ThisDrawing.SendCommand Chr(3) & Chr(3)
If dldm = "114" Then '水塘sts
sts = ThisDrawing.GetVariable("AREA") + sts
T = 1
End If
If dldm = "013" Then '旱地hds
hds = ThisDrawing.GetVariable("AREA") + hds
T = 1
End If
If dldm = "011" Then '水稻sds
sds = ThisDrawing.GetVariable("AREA") + sds
T = 1
End If
If dldm = "012" Then '水浇地sjds
sjds = ThisDrawing.GetVariable("AREA") + sjds
T = 1
End If
If dldm = "021" Then '果园gys
gys = ThisDrawing.GetVariable("AREA") + gys
T = 1
End If
If dldm = "031" Then '有林地ylds
ylds = ThisDrawing.GetVariable("AREA") + ylds
T = 1
End If
If dldm = "033" Then '其它林地qtlds
qtlds = ThisDrawing.GetVariable("AREA") + qtlds
T = 1
End If
If dldm = "043" Then '其它草地qtcds
qtcds = ThisDrawing.GetVariable("AREA") + qtcds
T = 1
End If
If dldm = "102" Then '公路用地glyds
glyds = ThisDrawing.GetVariable("AREA") + glyds
T = 1
End If
If dldm = "203" Then '村庄czs
czs = ThisDrawing.GetVariable("AREA") + czs
T = 1
End If
If dldm = "202" Then '建制镇jzzs
jzzs = ThisDrawing.GetVariable("AREA") + jzzs
T = 1
End If
If dldm = "204" Then '采矿用地ckyds
ckyds = ThisDrawing.GetVariable("AREA") + ckyds
T = 1
End If
If dldm = "117" Then '沟渠gqs
gqs = ThisDrawing.GetVariable("AREA") + gqs
T = 1
End If
If dldm = "113" Then '湖泊水面hpsms
hpsms = ThisDrawing.GetVariable("AREA") + hpsms
T = 1
End If
If dldm = "205" Then '风景名胜fjmss
fjmss = ThisDrawing.GetVariable("AREA") + fjmss
T = 1
End If
If dldm = "122" Then '设施农用地sslyds
sslyds = ThisDrawing.GetVariable("AREA") + sslyds
T = 1
End If
If dldm = "118" Then '水工建筑sgjzs
sgjzs = ThisDrawing.GetVariable("AREA") + sgjzs
T = 1
End If
If dldm = "113" Then '水库水面sksms
sksms = ThisDrawing.GetVariable("AREA") + sksms
T = 1
End If
If dldm = "022" Then '茶园cys
cys = ThisDrawing.GetVariable("AREA") + cys
T = 1
End If
If T = 0 Then
Open "c:\二调地类@815.txt" For Append As #1
Print #1, dldm
Close #1
End If
End If
End If
'ThisDrawing.GetVariable.Delete
Next
Open "c:\二调地类面积统计@815.txt" For Append As #2
Print #2, "茶园"; cys; "水库水面:"; sksms; "水工建筑:"; sgjzs; "设施农用地:"; sslyds; "风景名胜:"; fjmss; "湖泊水面:"; hpsms; "沟渠:"; gqs; "采矿用地:"; ckyds; "建制镇:"; jzzs; "村庄:"; czs; "公路用地:"; glyds; "其它草地:"; qtcds; "其它林地:"; qtlds; "有林地:"; ylds; "果园:"; gys; "水浇地:"; sjds; "水稻:"; sds; "旱地:"; hds; "水塘:"; sts
Close #2
附例图,请高手们帮我看看。理论上好像没问题，但是实际操作时，整幅图选择时就会很慢，最后导致内存不足。是不是cad自带的查找封闭区域有bug呢、?请高手指点。zxj_76看到吗？ 现在发现VB的看不懂了 呵呵，好像不太热呀，自己先顶一下 高手开发一个关于这的LSP代码！ 程序中问题多：
1、文件没有打开之前，为什么用close；而文件打开之后没有任何操作又关闭；
2、选择集只用建一个即可，首先判断是否存在，如存在则删除后新建，否则新建即可；
3、boundary命令不一定能成功建立边界；
4、有些标注文字（如“1335||114”）不在正确的位置上，将导致面积统计错误；
5、那些if ... then ... end if改为如下形式较好
Dim amj As Double
amj = ThisDrawing.GetVariable("AREA")
Select Case dldm
Case "114"'水塘sts
sts = sts + amj: T = 1
Case "013"'旱地hds
hds = hds + amj: T = 1
Case "011"'水稻sds
sds = sds + amj: T = 1
Case "012"'水浇地sjds
sjds = sjds + amj: T = 1
Case "021"'果园gys
gys = gys + amj: T = 1
Case "031"'有林地ylds
ylds = ylds + amj: T = 1
Case "033"'其它林地qtlds
dtlds = qtlds + amj: T = 1
Case "043" '其它草地qtcds
qtcds = qtcds + amj: T = 1
.......... ....
End Select
6、没有统计的面积与入文件；
.... 捉摸了几天，影响boundary出错的主要原因是屏幕显视，boundary命令执行时封闭区域必须要完整显视在屏幕内，否则会出错。但是屏幕显视区域也不能太小，如果太小也容易会出错，另外还导致死机（屏幕区域小了就导致每次分析的数据量增大）。这次把程序调整了一下。主要思路是分类和指定屏幕选择的大小，比如１１４水塘，这些面积都较小，所以可以把屏幕显视调小，遇到大的河流和村庄等大面积的则要适当增加。
但是统计数据还是加入一些人工干预，只能减少工作量，还没有达到一个命令就能完事的那种程度。
哎，总而言之，理论上按程序写的是能通过，但是实际上boundary有很多漏洞。不知道是开发者故意留的还是怎么的。
如果想能得到更满意的结果，估计要彻底改变思路。
楼上的谢谢了，你给我指出了很多问题，一看就是高手。以后多多指教呀。
Dim oAJlayer As AcadLayer
Dim layercollection As AcadLayers
Dim PlineObj As Variant
Dim point1 As Variant
Dim point2(0 To 2) As Double
Dim point3(0 To 2) As Double
Dim dldm As String '定义地类代码
Dim dlmj As Double '定义水塘存储的面积变量
Dim getchar As String
Dim a As Integer
dlmj = 0: dlmj1 = 0: a = 0
Close #1
Open "c:\二调地类@815.txt" For Append As #1
Close #1
Kill "c:\二调地类@815.txt"
Close #2
Open "c:\二调地类面积统计@815.txt" For Append As #2
Close #2
Kill "c:\二调地类面积统计@815.txt"
getchar = ThisDrawing.Utility.GetString(3, "请输入要统计的地类代号：")
a = ThisDrawing.Utility.GetInteger("请输入视窗大小：")
Set sset = ThisDrawing.SelectionSets.Add(str(Int(Timer))) '用秒数，选择集不会重复
Dim ft1(0) As Integer
Dim fd1(0) As Variant
ft1(0) = 8
fd1(0) = "ZDH1"
sset.Select acSelectionSetAll, , , ft1, fd1
Set layercollection = ThisDrawing.Layers
Set oAJlayer = layercollection.Add(getchar & "地类统计")
ThisDrawing.ActiveLayer = oAJlayer '设置当前图层
ThisDrawing.ActiveLayer.color = acGreen '设置当前图层的颜色
For Each element In sset '在选择集中进行循环
If element.ObjectName = "AcDbText" Then '对文字的处理
dldm = Right(element.TextString, 3)
If dldm = getchar Then
point1 = element.InsertionPoint '得到块的插入点坐标
Dim spt As String
Dim spt1(0 To 2) As Double
Dim spt2(0 To 2) As Double
Dim s As Double
spt = point1(0) & "," & point1(1)
spt1(0) = point1(0) - a
spt1(1) = point1(1) + a
spt1(2) = 0
spt2(0) = point1(0) + a
spt2(1) = point1(1) - a
spt2(2) = 0
ZoomWindow spt1, spt2
'ZoomExtents
ThisDrawing.SendCommand Chr(3) & Chr(3) & "-boundary " & spt & " " & " "
ThisDrawing.SendCommand "draworder lastf "
ThisDrawing.SendCommand "_.area o last "
ThisDrawing.SendCommand Chr(3) & Chr(3)
dlmj = ThisDrawing.GetVariable("AREA") + dlmj
element.color = acRed
End If
End If
Next
Open "c:\二调地类面积统计@815.txt" For Append As #2
Print #2, getchar; ":"; dlmj; "合:"; dlmj * 0.0015; "亩"
Close #2 例图，忘了说了，暂时这个程序还没有考虑到文字不在方框内的那种情况。是手工挪的。这个程序如果能如想的那样搞好的话，再搞下一步吧，这个例图已经完全没有问题了。114输入40可通过。
页:
[1]