;; Drawing Cutter, by Lee McDonnell 24.04.2009
(defun c:DwgCut (/ file path ss miPt maPt iSs i Nme fname)
(vl-load-com)
(setq doc (vla-get-ActiveDocument
(vlax-get-acad-object))
file (getfiled "Select Location for New Files" (if $def $def "") "dwg" 1))
(if (not (setq $def file)) (exit))
(setq path (vl-filename-directory file))
(if (setq ss (ssget "X" '((0 . "INSERT") (2 . "BORDER") (66 . 1))))
(foreach Obj (mapcar 'vlax-ename->vla-object
(mapcar 'cadr (ssnamex ss)))
(vla-getBoundingBox Obj 'miPt 'maPt)
(setq winLst (mapcar (function
(lambda (x) (vlax-safearray->list x))) (list miPt maPt))
iSs (ssget "_C" (car winLst) (cadr winLst)) i 2)
(foreach att (vlax-safearray->list
(vlax-variant-value
(vla-GetAttributes Obj)))
(if (eq "NAME" (vla-get-TagString att))
(setq Nme (vla-get-TextString att))))
(if (member (strcat Nme ".dwg") (vl-directory-files path "*.dwg" 1))
(progn
(setq Nme (strcat Nme (chr 40) (itoa i) (chr 41)) i (1+ i))
(while (member (strcat Nme ".dwg") (vl-directory-files path "*.dwg" 1))
(setq Nme (strcat
(substr Nme 1
(- (strlen Nme) 3)) (chr 40) (itoa i) (chr 41)) i (1+ i)))))
(setq fname (strcat path "\\" Nme ".dwg"))
(vla-wBlock doc fname (vla-get-ActiveSelectionSet doc)))
(princ "\n<!> No Borders Found <!>"))
(princ))
如果您不打算这样做，我们需要一些定义因子，将dwg名称与图形中的所有其他文本分隔开来，比如可能位于其自己的图层上。
如果要使用属性概念，则必须复制标题栏并将图形名称输入到每个图纸的属性中。
上面的代码比需要的稍长，因为我已经合并了您可能有多个重复图形名称的情况。上述代码假设属性标记名为“name”，但如有必要，可以对其进行更改。 如果要在绘图框中使用文字，请确保标题文字都位于其自己的图层上，并且可以使用以下选项：
;; Drawing Cutter V3, by Lee McDonnell 27.04.2009
(defun c:DwgCut (/ file path ss miPt maPt iSs i Nme fname)
(vl-load-com)
(setq doc (vla-get-ActiveDocument
(vlax-get-acad-object))
file (getfiled "Select Location for New Files" (if $def $def "") "dwg" 1))
(if (not (setq $def file)) (exit))
(setq path (vl-filename-directory file))
(if (setq ss (ssget "X" '((0 . "INSERT") (2 . "BORDER"))))
(foreach Obj (mapcar 'vlax-ename->vla-object
(mapcar 'cadr (ssnamex ss)))
(vla-getBoundingBox Obj 'miPt 'maPt)
(setq winLst (mapcar (function
(lambda (x) (vlax-safearray->list x))) (list miPt maPt))
iSs (ssget "_C" (car winLst) (cadr winLst)) i 2)
(foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex iSs)))
(if (eq "TitleText" (cdr (assoc 8 (entget ent))))
(setq Nme (cdr (assoc 1 (entget ent))))))
(if (member (strcat Nme ".dwg") (vl-directory-files path "*.dwg" 1))
(progn
(setq Nme (strcat Nme (chr 40) (itoa i) (chr 41)) i (1+ i))
(while (member (strcat Nme ".dwg") (vl-directory-files path "*.dwg" 1))
(setq Nme (strcat
(substr Nme 1
(- (strlen Nme) 3)) (chr 40) (itoa i) (chr 41)) i (1+ i)))))
(setq fname (strcat path "\\" Nme ".dwg"))
(vla-wBlock doc fname (vla-get-ActiveSelectionSet doc)))
(princ "\n<!> No Borders Found <!>"))
(princ))
我在LISP中称为“TitleText”的图形名称文本的图层名称，但可以更改为任何您喜欢的名称。 我不认为属性方法是适合我的情况的最佳途径。我经常更改名字，我真的不想为每张纸输入标题。我目前正在处理的文件包只有100多张，但有几张是350多张。。。这是大量输入，也是出错的好机会。
我喜欢把标题放在一个单独的层上。我可以很快很容易地做到这一点。
顺便说一句，你太棒了！非常感谢！
和我之前的帖子一样，这一层设置为“TitleText”，但如果你想更改，请告诉我
谢谢 实际上，这稍微好一点-它允许标题文本层上的其他实体可能会影响命名：
;; Drawing Cutter V3, by Lee McDonnell 27.04.2009
(defun c:DwgCut (/ file path ss miPt maPt iSs i Nme fname)
(vl-load-com)
(setq doc (vla-get-ActiveDocument
(vlax-get-acad-object))
file (getfiled "Select Location for New Files" (if $def $def "") "dwg" 1))
(if (not (setq $def file)) (exit))
(setq path (vl-filename-directory file))
(if (setq ss (ssget "X" '((0 . "INSERT") (2 . "BORDER"))))
(foreach Obj (mapcar 'vlax-ename->vla-object
(mapcar 'cadr (ssnamex ss)))
(vla-getBoundingBox Obj 'miPt 'maPt)
(setq winLst (mapcar (function
(lambda (x) (vlax-safearray->list x))) (list miPt maPt))
iSs (ssget "_C" (car winLst) (cadr winLst)) i 2)
(foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex iSs)))
(if (and (eq "TitleText" (cdr (assoc 8 (entget ent))))
(member (cdr (assoc 0 (entget ent))) '("TEXT" "MTEXT")))
(setq Nme (cdr (assoc 1 (entget ent))))))
(if (member (strcat Nme ".dwg") (vl-directory-files path "*.dwg" 1))
(progn
(setq Nme (strcat Nme (chr 40) (itoa i) (chr 41)) i (1+ i))
(while (member (strcat Nme ".dwg") (vl-directory-files path "*.dwg" 1))
(setq Nme (strcat
(substr Nme 1
(- (strlen Nme) 3)) (chr 40) (itoa i) (chr 41)) i (1+ i)))))
(setq fname (strcat path "\\" Nme ".dwg"))
(vla-wBlock doc fname (vla-get-ActiveSelectionSet doc)))
(princ "\n<!> No Borders Found <!>"))
(princ))
为了帮助您，这里有一种快速方法可以将所有文本放置在正确的图层上：
(defun c:lm (/ ent)
(vl-load-com)
(or (tblsearch "LAYER" "TitleText")
(vla-add (vla-get-layers
(vla-get-ActiveDocument
(vlax-get-acad-object))) "TitleText"))
(while (and (setq ent (car (entsel "\nSelect Title Text: ")))
(member (cdr (assoc 0 (entget ent))) '("TEXT" "MTEXT")))
(vla-put-layer (vlax-ename->vla-object ent) "TitleText"))
(princ))
你太棒了！这完全奏效了！
好的，我保证这是最后一个问题…
我现在通常要做的是运行这个标记LISP，我们使用它来标记每个图形的日期、首字母缩写等。唯一的问题是，标记LISP要求边框的右下角位于0,0。你知道如何在原点插入新图形吗？此外，是否可以在DwgCut LISP中包含标记LISP，这样我就不必单独打开每个图形？如果没有，不用担心，你刚刚创造的将节省我和我的许多同事太多时间！
以下是标记Lisp：
（定义c：标记（/CE AP CL DN CD MX HR MN LM LX DX TH DS MO YR TM TX）
（setq CE（getvar“CMDECHO”））
（setvar“CMDECHO”0）
（setvar“limcheck”0）
（setq AP“AM”
CL（getvar“CLAYER”）
DN（getvar“DWGNAME”）
CD（rtos（getvar“CDATE”）2 4）
MX（atoi（substr CD 5 2））
HR（atoi（substr CD 10 2））
MN（substr CD 12 2）
LM（getvar“LIMMIN”）
LX（getvar“LIMMAX”）
DX（距离LM LX）
TH（rtos（/DX 200）2 2）
DS（极性LM（/pi 200）（/DX-300））
MO（第n个MX’（无“一月”“二月”“三月”“四月”“五月”“六月”
“7月”“8月”“9月”“10月”“11月”“12月”）
)
（如果（>=HR 12）（setq AP“PM”））
（如果（>=HR 13）（setq HR（itoa（-HR 12）））（setq HR（itoa HR）））
（setq YR（strcat“日期：“MO”“（substr CD 7 2）”，“（substr CD 1 4）））
（setq TM（strcat“DRFT:KLK”文件：“DN”“YR”时间：“HR”：“MN”“AP））
（command.LAYER“T”“DATESTAMP”“）
（命令.LAYER“N”DATESTAMP“C”2“DATESTAMP”S“DATESTAMP”）
（setq TX（ssget“X”（列表（cons 8“DATESTAMP”）））
（命令“.ERASE”TX“”
; .STYLE“”SIMPLEX“”0“”1“”0“”N“”N“”N“
.TEXT“DS TH”90“TM
.LAYER“S”CL
)
（setvar“CMDECHO”CE）
（打印）
（打印TM）
（普林斯）
（命令“zoom”“e”）
) 我很高兴能帮到你-我会看看你的标签Lisp程序，看看我能做些什么 只有几个问题-
所有的边框大小都一样吗？
你能上传一份有日期戳的边境样品吗？
干杯
李 只是提醒一下。。。。使用时：
（ssget“_C”（car winLst）（cadr winLst））i 2）
所有对象都需要在屏幕上可见，否则它们将不会被选中。
可能会在循环中添加类似的内容：
（vla ZoomWindows（vlax get acad对象）
（vlax-3d-point（car winlst））
（vlax-3d-point（cadr winlst））
)
罗恩
页:
1
[2]