vba编程实现合并多个dwg（指定图层并增加属性字段）转shp方案概述

1、项目需求

如图所示，甲方提供多宗CAD格式宗地图，任务为把所有dwg图形中jzd图层提取出来合并为一个总shp文件，shp文件中每一宗地要显示测图号属性。

1.2

2. 解决问题思路

打开图形可看到，每个dwg文件内都有一个jzd图层，图层内包含范围线和文字，根据用户要求我们只需要范围线，不需要提取界址点号、界址点距离等文字。

这一任务可借助vba编程解决。首先在dwg格式文件夹内新建一个空的dwg文件（以下称总文件），然后通过遍历文件夹内dwg文件，通过选择集的方式选择jzd图层中不包含文字的实体要素，选择集内容赋给一个新建数组，在总文件中新建一个block块，块名为包含jzd图层的dwg格式文件的文件名前8个字段，之后把新建数组通过copyobjects方法复制到图块中，在总图中插入块。针对所有dwg文件都采用以上办法获取所需信息，可采用do loop循环语句解决。

3.vba代码解决问题

Sub test()
Dim sel As AcadSelectionSet
Dim ljwj As String, lj As String
Dim ftype(0 To 10) As Integer, fdata(0 To 10) As Variant
ftype(0) = -4: fdata(0) = "<AND"
ftype(1) = 8: fdata(1) = "JZD"
ftype(2) = -4: fdata(2) = "<AND"
ftype(3) = -4: fdata(3) = "<NOT"
ftype(4) = 0: fdata(4) = "text"
ftype(5) = -4: fdata(5) = "NOT>"

ftype(6) = -4: fdata(6) = "<NOT"
ftype(7) = 0: fdata(7) = "mtext"
ftype(8) = -4: fdata(8) = "NOT>"
ftype(9) = -4: fdata(9) = "AND>"
ftype(10) = -4: fdata(10) = "AND>"
Dim obj As AcadObject
lj = ThisDrawing.Path
ljwj = Dir(lj & "\*.dwg")
 Dim myzong As AcadDocument
 Dim lay As AcadLayer
 For Each lay In ThisDrawing.Layers
   If lay.Name = "JZD" Then
   Set JZD = ThisDrawing.Layers("JZD")
   ThisDrawing.ActiveLayer = JZD
   JZD.color = acRed
   Exit For
   End If
    Next lay
    If ThisDrawing.ActiveLayer.Name <> "JZD" Then
    Set JZD = ThisDrawing.Layers.Add("JZD")
    ThisDrawing.ActiveLayer = JZD
    JZD.color = acRed
    End If
 Set myzong = ActiveDocument
 
 zong = ThisDrawing.Name
Do While ljwj <> ""
   
    If ljwj <> zong Then
    
     Set mydqwj = Documents.Open(lj & "\" & ljwj)
     Do While ThisDrawing.SelectionSets.Count > 0
     ThisDrawing.SelectionSets.Item(0).Delete
     Loop
    Set sel = ThisDrawing.SelectionSets.Add("mysel")
    
    sel.Select acSelectionSetAll, , , ftype, fdata
         If sel.Count > 0 Then
            Dim arr() As Object
            ReDim arr(sel.Count - 1)
            Dim newarr() As Object
            ReDim newarr(sel.Count - 1)
             For i = 0 To sel.Count - 1
            Set arr(i) = sel.Item(i)
             Next i
      
       
            dqwj = lj & "\" & ljwj
      Dim myblock As AcadBlock: Dim ptbase(2) As Double: ptbase(0) = 0: ptbase(1) = 0: ptbase(2) = 0:
      Dim blockname As String:
      blockname = Left(ljwj, 10)
      Set myblock = myzong.Blocks.Add(ptbase, blockname)
'            mydqwj.CopyObjects arr, myzong.ModelSpace, newarr
            mydqwj.CopyObjects arr, myblock
            Set insblock = myzong.ModelSpace.InsertBlock(ptbase, blockname, 1, 1, 1, 0)
            End If
             mydqwj.Close
            Erase arr
            Erase newarr
            sel.Delete
           
        End If
        ljwj = Dir
Loop

  ThisDrawing.Regen acActiveViewport
  Zoomextents
  ThisDrawing.Save
End Sub