[分享]：DWG文件按图层分解输出

wkai

将DWG中的每一个图层输出为一个单独的文件。
[PHP](defun c:tt ( / pa la-lst ss fn)
  (defun tablelist (s / d r)
    (while
      (setq d (tblnext s (null d)))
       (setq r (cons (cdr (assoc 2 d)) r))
    )
  )
  (setq pa (getfiled "文件输出到" "" "dwg" 1))
  (setq pa (substr pa 1 (- (strlen pa) 4)))
  (setq la-lst (tablelist "layer"))
  (foreach n la-lst
    (setq ss (ssget "x" (list (cons 8 n))))
    (if        ss
      (if (findfile (setq fn (strcat pa "_" n ".dwg")))
        (command "-wblock" fn "y" "" "0,0,0" ss "" "oops")
        (command "-wblock" fn "" "0,0,0" ss "" "oops")
      )
    )
  )
)[/PHP]

andyhua5240

测试了一下，不错，能用也好用！
做了个附件，给像我一样不会LSP的网友！
命令：TT

aeo

注意图层，不能为锁定
pickstyle要关上.

自由的鱼

Sub Wblockonlayer()
Dim Layer As AcadLayer
Dim i As Integer
Dim Layername As String
Dim Ftype(0) As Integer
Dim Fdata(0) As Variant
Dim sset As AcadSelectionSet
For i = 0 To ThisDrawing.SelectionSets.Count - 1
    ThisDrawing.SelectionSets.Item(i).Clear
    ThisDrawing.SelectionSets.Item(i).Delete
Next

Set sset = ThisDrawing.SelectionSets.Add("Layersel")
For i = 0 To ThisDrawing.Layers.Count - 1
    Layername = ThisDrawing.Layers.Item(i).Name
    Ftype(0) = 8
    Fdata(0) = Layername
sset.Select acSelectionSetAll, , , Ftype, Fdata
If sset.Count > 0 Then
ThisDrawing.Wblock "l:\" & Layername & ".dwg", sset
End If

Next

End Sub

chstart

Command: tt Unknown command "-WBLOCK".  Press F1 for help.
Unknown command "D:\DOCUMENTS AND SETTINGS\裙房11.12-1_地下室轮廓.DWG".  Press F1 for help.
Unknown command "TT".  Press F1 for help.
Unknown command "0,0,0".  Press F1 for help.
<Selection set: 1>

Command: *Cancel


怎么都是出错？r14里能用吗？