一次性建立多个层，自定义函数通不过，大家帮忙解决一下

brainstorm

(defun zgx-mklayer (layname color ltype linewid / lst1 lst2)
  (if (and (not (tblobjname "ltype" ltype))
    (not (command "_.-linetype" "_load" ltype "acad.lin" "")
    )
    (not (tblobjname "ltype" ltype))
      )     ;and
    (setq ltype "CONTINUOUS")
  )
  (setq lst1 (list 0 100 100 2 62 6 70 370)
 lst2 (list "layer"       "AcDbSymbolTableRecord"
     "AcDbLayerTableRecord"
     layname       color
     ltype       0
     linewid
    )
  )
  (setq lst2 (mapcar 'cons lst1 lst2))
  (entmake lst2)
)

兰州人

VBA建立的图层。

2. Function Maked3DModelLayer(cadApp As AcadApplication, EntArr As Variant, EntColorArr As Variant) As Variant
3.   Dim LayerArray, LayerColorArray
4.   Dim oLayer As AcadLayer
5.   For Each oLayer In cadApp.ActiveDocument.Layers
6.     If InStr(oLayer.Name, "中心线") > 0 Then
7.       Exit Function
8.     End If
9.   Next oLayer
10.   LayerArray = Array("粗实线", "虚线", "细实线", "中心线", "点划线", "尺寸线", "文本", "明细表材料表", "件号", "标题栏")
11.   Maked3DModelLayer = LayerArray
12.   LayerColorArray = Array(1, 255, 3, 4, 4, 6, 2, 131, 124, 4)
13.   Dim TestLayer As AcadLayer
14.   For ii = 0 To UBound(LayerArray)
15.     Set TestLayer = cadApp.ActiveDocument.Layers.Add(LayerArray(ii))
16.     TestLayer.Color = LayerColorArray(ii)
17.   Next ii
18.   For ii = 0 To UBound(EntArr)
19.     Set TestLayer = cadApp.ActiveDocument.Layers.Add(EntArr(ii))
20.     TestLayer.Color = EntColorArr(ii)
21.   Next ii
22.   With cadApp.ActiveDocument
23.     .Linetypes.Load "ACAD_ISO03W100", "acad.lin"
24.     .Linetypes.Load "ACAD_ISO04W100", "acad.lin"
25.     .Linetypes.Load "ACAD_ISO05W100", "acad.lin"
26.     .Layers("中心线").Linetype = "ACAD_ISO04W100"
27.     .Layers("虚线").Linetype = "ACAD_ISO03W100"
28.     .Layers("点划线").Linetype = "ACAD_ISO05W100"
29.     '.SendCommand "ltscale" & vbCr & 10 & vbCr
30.   End With
31. End Function
32. '''

Function Maked3DModelLayer(cadApp As AcadApplication, EntArr As Variant, EntColorArr As Variant) As Variant   Dim LayerArray, LayerColorArray   Dim oLayer As AcadLayer   For Each oLayer In cadApp.ActiveDocument.Layers     If InStr(oLayer.Name, "中心线") > 0 Then       Exit Function     End If   Next oLayer   LayerArray = Array("粗实线", "虚线", "细实线", "中心线", "点划线", "尺寸线", "文本", "明细表材料表", "件号", "标题栏")   Maked3DModelLayer = LayerArray   LayerColorArray = Array(1, 255, 3, 4, 4, 6, 2, 131, 124, 4)   Dim TestLayer As AcadLayer   For ii = 0 To UBound(LayerArray)     Set TestLayer = cadApp.ActiveDocument.Layers.Add(LayerArray(ii))     TestLayer.Color = LayerColorArray(ii)   Next ii   For ii = 0 To UBound(EntArr)     Set TestLayer = cadApp.ActiveDocument.Layers.Add(EntArr(ii))     TestLayer.Color = EntColorArr(ii)   Next ii   With cadApp.ActiveDocument     .Linetypes.Load "ACAD_ISO03W100", "acad.lin"     .Linetypes.Load "ACAD_ISO04W100", "acad.lin"     .Linetypes.Load "ACAD_ISO05W100", "acad.lin"     .Layers("中心线").Linetype = "ACAD_ISO04W100"     .Layers("虚线").Linetype = "ACAD_ISO03W100"     .Layers("点划线").Linetype = "ACAD_ISO05W100"     '.SendCommand "ltscale" & vbCr & 10 & vbCr   End With End Function '''

killer9806

龙龙仔版主的mapcar用法太强.学习

Ljdickey

思路都很好，学习了

blueshake

大家给的程序都非常好。谢谢。

zhengchuan

学习啦

skg123

xyp1964 发表于 2009-9-2 13:14

很棒，不知能不能 在修改一下， 每个层有对应想线型，比如中心线层，就自动加载 虚线。

功夫佬

xyp1964 发表于 2009-9-2 13:14

在程序里面能加LWDEFAULT变量（线宽）

/fendou结构绘图