dwg图型输出为lisp文件
可以用来画符号之类东西。结合需要修改后，可以用来搞参数化绘图。注意：生成的lisp文件代码是不含量文字样式、标注样式的，如果含有这个，需要先改进程序或修改代码文件。
源码如下：
(defun c:tt(/ basicpoint codeorder fileheadstring filename fileobject i k kdxf listnonstringcodes memberp nonstrl notneedcodes obdxf
obename objections replacestring sdxf startEntity strdxfstringcodes strl vlaobjects)
;;;--------------------------------------------------------------------------------
(defun memberp ( Obj listObjects / i boolResult)
(setq boolResult "NO" )
(setq i 0)
(while (and (= boolResult "NO")
(vla-object ename) lst))
)
lst
)
;;; -------------------------------------------------------------------------
;;选择集生成无名组
(defun AddUnNameGroup (ss / actDwg objGroup ss2array)
(defun SS2Array (ss / c r en)
(repeat (setq c (sslength ss))
(setq en (ssname ss (setq c (1- c))))
(if(entget en)
(setq r (cons en r))
)
)
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbObject
(cons 0 (1- (length r)))
)
(mapcar 'vlax-ename->vla-object r)
)
)
(setq actDwg (vla-get-activedocument(vlax-get-acad-object)))
(vla-AppendItems (setq objGroup (vla-add (vla-get-Groups actDwg) "*")) (SS2Array ss))
objGroup
)
;;; -------------------------------------------------------------------------
;;说明：把自指定对象开始生成的所有对象，加入到一个新的无名组
(defun AddToNewGroupFrom( addNewGroupBeginEntity / groupEntities )
(setq groupEntities (ssadd addNewGroupBeginEntity))
(while (setq addNewGroupBeginEntity (entnext addNewGroupBeginEntity ))
(setq groupEntities (ssadd addNewGroupBeginEntity groupEntities))
)
(AddUnNameGroup groupEntities)
)
;;;-----------------------------------------------------------------
(princ "\n选择需要的对象:")
(if (setq objections (ssget '((0 . "*line,*text,arc,circle,ellipse,hatch,dimension,ray"))))
(progn
(setq basicPoint (getpoint "需要复制的对象的插入基点："))
(setq vlaObjects (SelectSet2VlaObjects objections ))
(foreach obj vlaObjects
(vla-move obj (vlax-3d-point basicPoint)(vlax-3d-point '(00 )) )
)
(setq fileName "d:/makeEntity.lsp")
(setq FileObject (open fileName "w"))
(setq NotNeedCodes (list -3 -1 2 5 102 330 340 )) ;所有不需要保留的组码的第一个元素
(setq FileHeadString "(defun NewSignOrBlock (/ startEntity ) \n")
(setq codeOrder (list "string"))
;;coder记录按顺序输出结果时，组码第二个元素是否是字符串，用于在生成结果文件时地确定是输出strDxfStringCodes还是listNonStringCodes中的元素
(setq i -1)
(while (setq obEname (ssname objections (setq i (1+ i))))
(setq obDxf (entget obEname))
(setq k -1)
(setq strDxfStringCodes (list "(entmake '(") )
(setq listNonStringCodes nil)
;;组码第二个元素是字符串的和不是字符串的分开保存，字符串需要程序在保存文件中添加分号，非字符的直接用princ函数输出即可
;;逐个处理选择对象，生成需要输入的结果表strDxfStringCodes、listNonStringCodes，及记录结果表中的各组码类型的codeOrder
(while (setq kDxf (nth (setq k (1+ k)) obDxf))
(if(/=(memberp (car kDxf ) NotNeedCodes ) "YES")
(progn
(setq sdxf(cdr kDxf ))
(if (or (numberp sdxf)
(listp sdxf)
)
(progn
(setq listNonStringCodes (append listNonStringCodes (list kDxf)))
(setq codeOrder (append codeOrder (list "NotString")))
)
(progn
(setq strDxfStringCodes (append strDxfStringCodes (list (strcat "(" (rtos (car kDxf)) " . "" (cdr kDxf) "")"))))
(setq codeOrder (append codeOrder (list "string")))
)
)
)
)
)
;;以下输出结果文件数据
;;生成文件部分不变内容
(if ( = i 0)
(princ FileHeadString FileObject)
)
;;逐个生成选择对象组码数据
(setq strL -1)
(setq NonStrL -1)
(foreach order codeOrder
(if (= order "string")
(progn
(setq strL (1+ strL))
(if ( i 1)
(princ "(AddToNewGroupFrom startEntity)\n(princ)\n)\n(NewSignOrBlock)\n" FileObject)
(princ "(princ)\n)\n(NewSignOrBlock)\n" FileObject)
)
(close FileObject)
(replaceString)
)
)
(foreach obj vlaObjects
(vla-move obj (vlax-3d-point '(00 ))(vlax-3d-point basicPoint))
)
(princ)
)
程序文件
结果测试文件
**** Hidden Message ***** 感谢分享 不知道是不是我姿势不对
转成的lisp 组码不对
(defun NewSignOrBlock (/ startEntity )
(entmake '((0 .(cdr kDxf) )(100 .(cdr kDxf) )(67 . 0)(410 .(cdr kDxf) )(8 .(cdr kDxf) )(100 .(cdr kDxf) )(10 393.167 426.663 0.0)(11 706.735 -98.8315 0.0)(210 0.0 0.0 1.0)))
(setq startEntity ( entlast ) )
(entmake '((0 .(cdr kDxf) )(100 .(cdr kDxf) )(67 . 0)(410 .(cdr kDxf) )(8 .(cdr kDxf) )(100 .(cdr kDxf) )(10 0.0 0.0 0.0)(11 393.167 426.663 0.0)(210 0.0 0.0 1.0)))
(AddToNewGroupFrom startEntity)
(princ)
)
(NewSignOrBlock)
(setq strDxfStringCodes (append strDxfStringCodes (list (strcat "(" (rtos (car kDxf)) " . "" (cdr kDxf) "")"))))问题出现在115行这个位置，“”（cdr kdxf）“”比如是圆，您想生成：(0 . "CIRCLE")，实际生成的是 (0 .(cdr kDxf)，不知道您是不是有其它函数，能把(cdr kDxf) 转成字符串，再加上引号
可以了，前面我反斜杠错了一位，弄半天不行，改成这个也能用：
(setq strDxfStringCodes (append strDxfStringCodes (list (strcat "(" (rtos (car kDxf)) " . " (write-line "\"")(cdr kDxf)(write-line "\"") ")"))))，感谢楼主无私奉献！ 这个牢固有了，搜图块打包，文字样式线型标注样式图层块名等等均识别。我的也是
复制网页中的源码时候，\"只复制了 "
下载附件中的文件吧。
各有各的用途。不影响。 谢谢梁老师分享新品 我这边试了，可以转lisp，但是生成的lisp转不成图形，我用的是CAD2020，是跟CAD版本有关吗？ 我的转出来也出现(cdr kDxf)
页:
[1]
2