寻找一个口齿不清的人
是否有lisp在每个层中绘制一条线并添加带有层名称的文本？附上一张显示我请求的图片
可以在vba甚至vb中实现。如果可以接受的话。
如果你特别想要lisp，那么你必须等待其他人。
干杯 两者都可以
该文件可以是ocx吗？我试图避免加载宏
thanx LCE 试试这个。。。
Code in post below
拔出连接的拉链。
在acad类型中-vbarun
然后输入“directory\DrawLays.dvb！DrawLays”
其中directory是您将dvb提取到的目录
如果你有任何问题，请告诉我。
我还没有添加任何错误处理，所以如果你取消，它将给出一个错误。
干杯 Arch_Eric
我没弄明白
它是AutoCAD命令还是什么 我把代码搞砸了。。。这是修订版。。。
(defun c:layerlegend (/ osm ortho clayer celtype cecolor start-point line-length text-height *error*)
(defun *error* (msg)
(setvar "osmode" osm)
(setvar "orthomode" ortho)
(setvar "clayer" clayer)
(setvar "celtype" celtype)
(setvar "cecolor" cecolor)
(princ msg)
)
(defun mfp (pt pa) (list (+ (car pt) (car pa)) (+ (cadr pt) (cadr pa)) (+ (caddr pt) (caddr pa))))
(setq osm (getvar "osmode"))
(setq ortho (getvar "orthomode"))
(setq clayer (getvar "clayer"))
(setq celtype (getvar "celtype"))
(setq cecolor (getvar "cecolor"))
(setq start-point (getpoint "\nSelect point to start legend: "))
(setvar "orthomode" 1)
(setq line-length (getdist start-point "\nEnter length of line or click end point: "))
(setq text-height (cdr (assoc 40 (tblsearch "style" (getvar "textstyle")))))
(setvar "osmode" 0)
(setvar "clayer" (cdr (assoc 2 (tblnext "Layer" T))))
(setvar "celtype" "ByLayer")
(setvar "cecolor" "ByLayer")
(command "_line" start-point (mfp start-point (list line-length 0 0)) "")
(command "-text" (mfp start-point (list 0 1 0)) "0" (getvar "clayer"))
(while (setq layer (tblnext "Layer"))
(setvar "clayer" (cdr (assoc 2 layer)))
(setq start-point (mfp start-point (list 0 (- 0 (+ text-height 4)) 0)))
(command "_line" start-point (mfp start-point (list line-length 0 0)) "")
(command "-text" (mfp start-point (list 0 1 0)) "0" (getvar "clayer"))
)
(setvar "osmode" osm)
(setvar "orthomode" ortho)
(setvar "clayer" clayer)
(setvar "celtype" celtype)
(setvar "cecolor" cecolor)
) 代码假设样式中有默认的文字高度。 见附件。
错误处理添加了一些其他调整。 Thanx LCE先生，这就是我锁定的原因。
Arch_Eric一开始很抱歉，我的母语是阿拉伯语
Lisp程序的第二个thanx
lisp可以，但它仅对当前层有效，而不是对所有层有效
页:
[1]
2