[求助]：cad某个图层单独存为dxf

kileng

想在vba中实现某个图层单独另存为dxf

雪山飞狐(lzh)

ThisDrawing.Export 方法

2. Sub t6()
   
3. On Error Resume Next
   
4. Dim ft(0) As Integer, fd(0)
   
5. Dim ss As AcadSelectionSet
   
6. ThisDrawing.SelectionSets("CURRENT").Delete
   
7. Set ss = ThisDrawing.ActiveSelectionSet
   
8. ft(0) = 8: fd(0) = "0"
   
9. ss.Select acSelectionSetAll, , , ft, fd
   
10. ThisDrawing.Export "c:\1", "DXF", ss
    
11. ss.Clear
    
12. ss.Delete
    
13. End Sub

Sub t6()<br /> On Error Resume Next<br /> Dim ft(0) As Integer, fd(0)<br /> Dim ss As AcadSelectionSet<br /> ThisDrawing.SelectionSets("CURRENT").Delete<br /> Set ss = ThisDrawing.ActiveSelectionSet<br /> ft(0) = 8: fd(0) = "0"<br /> ss.Select acSelectionSetAll, , , ft, fd<br /> ThisDrawing.Export "c:\1", "DXF", ss<br /> ss.Clear<br /> ss.Delete<br /> End Sub

kileng

最初由 kileng 发布
[B]想在vba中实现某个图层单独另存为dxf [/B]

楼主怎么指定保存的图层啊？
我存出的结果是所有图层，呀呀的！·￥·！

雪山飞狐(lzh)

把fd(0) = "0"换成你想保存的图层

kileng

最初由 kileng 发布
[B]

楼主怎么指定保存的图层啊？
我存出的结果是所有图层，呀呀的！·￥·！ [/B]

我这样的：
  ft(0) = 8: fd(0) = "45"

但是保存的还是全部的图层？！

自由的鱼

是全部图层都输出了！

雪山飞狐(lzh)

对于DXF格式Export方法忽略选择集
只有先输出为Dwg格式，再转DXF
Sub t6()
On Error Resume Next
Dim ft(0) As Integer, fd(0)
Dim ss As AcadSelectionSet
Dim objDbx As AxDbDocument
Set ss = ThisDrawing.SelectionSets.Add("*TlsTest*")
ft(0) = 8: fd(0) = "0"
ss.Select acSelectionSetAll, , , ft, fd
MsgBox ss.Count
ThisDrawing.Wblock "c:\1.dwg", ss
ss.Clear
ss.Delete
Set objDbx = Application.GetInterfaceObject("ObjectDBX.AxDbDocument.16")
objDbx.Open "c:\1.dwg"
objDbx.DxfOut "c:\4.dxf"
End Sub

自由的鱼

曲折一些，呵呵
Sub t6()
On Error Resume Next
Dim layerobj As AcadLayer
Set layerobj = ThisDrawing.Layers.Item("1")
layerobj.Lock = True
ThisDrawing.SendCommand "e" & vbCr & "all" & vbCr & vbCr

Dim ft(0) As Integer, fd(0)
Dim ss As AcadSelectionSet
ThisDrawing.SelectionSets("CURRENT").Delete
Set ss = ThisDrawing.ActiveSelectionSet
ft(0) = 8: fd(0) = "1"
ss.Select acSelectionSetAll, , , ft, fd
ThisDrawing.Export "l:\1", "DXF", ss
ss.Clear
ss.Delete
ThisDrawing.SendCommand "u" & vbCr
End Sub

雪山飞狐(lzh)

鱼兄，你生成的图形的层1也是锁定的，这怎么解释？或者说你自己有什么手段解决？

自由的鱼

加一行解锁！
Sub t6()
On Error Resume Next
Dim layerobj As AcadLayer
Set layerobj = ThisDrawing.Layers.Item("1")
layerobj.Lock = True
ThisDrawing.SendCommand "e" & vbCr & "all" & vbCr & vbCr
layerobj.Lock = False
Dim ft(0) As Integer, fd(0)
Dim ss As AcadSelectionSet
ThisDrawing.SelectionSets("CURRENT").Delete
Set ss = ThisDrawing.ActiveSelectionSet
ft(0) = 8: fd(0) = "1"
ss.Select acSelectionSetAll, , , ft, fd
ThisDrawing.Export "l:\1", "DXF", ss
ss.Clear
ss.Delete

End Sub

mengyuge

图形是半个圆与一个多断线起点与末点相同所围城的图形，想把这个图形创建成区域然后填充怎么办？

WHGF

可以这样:
File ->Save As...->选择输出DXF文件类型及文件名->
   在Save As Options窗口中->选Dxf Options ->  其它事情由用户选择.....