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
4.成果展示
由上图可知,我们已将所有图层合并到总图中。