二调图封闭区域内的面积统计

chffsmc

Dim PlineObj As Variant
           
           Dim 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 last  f "
  
              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

chffsmc

附例图,请高手们帮我看看。理论上好像没问题，但是实际操作时，整幅图选择时就会很慢，最后导致内存不足。是不是cad自带的查找封闭区域有bug呢、?请高手指点。zxj_76看到吗？

gzxl

现在发现VB的看不懂了

chffsmc

呵呵，好像不太热呀，自己先顶一下

cuyongping

高手开发一个关于这的LSP代码！

yshf

程序中问题多：
    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、没有统计的面积与入文件；
  ....

chffsmc

捉摸了几天，影响boundary出错的主要原因是屏幕显视，boundary命令执行时封闭区域必须要完整显视在屏幕内，否则会出错。但是屏幕显视区域也不能太小，如果太小也容易会出错，另外还导致死机（屏幕区域小了就导致每次分析的数据量增大）。这次把程序调整了一下。主要思路是分类和指定屏幕选择的大小，比如１１４水塘，这些面积都较小，所以可以把屏幕显视调小，遇到大的河流和村庄等大面积的则要适当增加。
但是统计数据还是加入一些人工干预，只能减少工作量，还没有达到一个命令就能完事的那种程度。
哎，总而言之，理论上按程序写的是能通过，但是实际上boundary有很多漏洞。不知道是开发者故意留的还是怎么的。
如果想能得到更满意的结果，估计要彻底改变思路。
楼上的谢谢了，你给我指出了很多问题，一看就是高手。以后多多指教呀。

chffsmc

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 last  f "
  
                          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

chffsmc

例图，忘了说了，暂时这个程序还没有考虑到文字不在方框内的那种情况。是手工挪的。这个程序如果能如想的那样搞好的话，再搞下一步吧，这个例图已经完全没有问题了。114输入40可通过。