有没有快速输出dwg的程序
有没有快速输出dwg的程序这个dxf输出的，来自论坛
(DEFUN C:DXF( / GRP PATH NAME)
(SETVAR "CMDECHO" 0)
(PRINC "\n 【以DXF格式输出】")
(PROMPT "\n请选择DXF输出的实体:")
(SETQ GRP (SSGET))
(SETQ PATH (GETVAR "DWGPREFIX")) ;获取FILEPATH
(SETQ NAME (GETFILED "DXF档案输出快选" PATH "dwg" 15))
(SETVAR "FILEDIA" 0)
(COMMAND "_DXFOUT" NAME "V" "R12" "O" GRP "" "")
(SETVAR "FILEDIA" 1)
(SETVAR "CMDECHO" 1)
(PRINC "\n OK !!!")
(PRINC)
)
选定图形后，输出到指定的路径。有时候想要在一张大图中，选取部分图形，输出为dwg的文件，有什么办法实现？
多简单，wblock啊 kozmosovia 发表于 2024-10-19 12:00
多简单，wblock啊
还有更简单的，一个W就可以搞掂了:lol 用(command "-wblock") 写个程序就实现了
用你上边的程序修改一下
qazxswk 发表于 2024-10-19 23:02
还有更简单的，一个W就可以搞掂了
惭愧，还不知道有自带的，哈哈
感谢大佬指点 捉到源码一枚，特此补充；获取自cad自学网，大概率也是来自明经
觉得好用的，赏个免费的评分，系统每天赠送评分2币，不用也会过期哦！
;;==选物另存为DWG(W)=================================================================================================
(defun c:tt5 (/ dwgname n txt3 ss ppi date name time path filename )
(setvar "cmdecho" 0) ;
(setvar "OSMODE" 0)
(setq dwgname (getvar 'dwgname)
n (VL-STRING-SEARCH "." dwgname)
txt3 (strcat (substr dwgname 1 n) "_"))
(setq ss (ssget )) ;选择集
(setq ppi (mc:ssmind ss))
(setq date (rtos (getvar "cdate") 2 6));系统当前时间
(setq time (substr date 10 17))
(setq name (getstring "\n输入保存名:<文件名+当前时间>"))
(if (= name "")
(setq name time)
(setq txt3 "")
)
(setq path (strcat (vla-item (vlax-get (vlax-create-object "WScript.Shell" ) 'SpecialFolders) "Desktop") "\\")) ;自动获取桌面路径
(setq filename (strcat path txt3 name )) ;合并成文件路径及文件名
(if (= nil (vl-directory-filespath(strcat txt3 name ".dwg")))
(progn
(command "WBLOCK" filename "" PPISS"" "oops" )
(PRINC (strcat "\n 成功 保存:" txt3 name"到桌面！"))
)
(progn
(mc:okno (strcat txt3 name))
(setq newname (vl-registry-read "HKEY_CURRENT_USER\\Software\\TH++\\" "name"))
(setq filename (strcat path newname ))
(vl-file-delete (strcat filename ".dwg" ))
(command "WBLOCK" filename "" PPISS"" "oops" )
)
)
(setvar "cmdecho" 1)
(PRINC)
)
(defun mc:okno (oldname / bb dcl_re f fname fsys jqm n zcm)
(vl-load-com)
(setq fname (vl-filename-mktemp "name.dcl") f (open fname "w"))
(write-line "name:dialog{ label=\"文件已存在，重命名或覆盖\";" f)
(write-line ":edit_box{label=\" 原名称\";key=\"e01\";edit_width=38;}" f)
(write-line ":edit_box{label=\" 重命名\";key=\"e02\";edit_width=38;}" f)
(write-line ":row{:button {label=\"确定\";key=\"e03\";is_default=true;}" f)
(write-line ":button {label=\"取消\";is_cancel=true;}}}" f)
(close f)
(new_dialog "name" (setq dcl_re (load_dialog fname)))
(set_tile "e01" oldname)
(set_tile "e02" oldname)
(action_tile "e03" "(setq newname(get_tile \"e02\")) (done_dialog 1)")
(if (= (start_dialog) 1)
(vl-registry-write "HKEY_CURRENT_USER\\software\\TH++\\" "name" newname)
)
(unload_dialog dcl_re)
(vl-file-delete fname)
(princ)
)
;两点中
(defun Mc:Md (pt1 pt2 / ptz)
(setq ptz (mapcar'(lambda(X Y)(/(+ X Y)2.0)) pt1 pt2))
)
;;最小外包围点列表
(defun mc:wk (ss /lst n obj minx miny maxxmaxy pt1 pt2 pt3 pt4)
(repeat (setq n (sslength ss))
(setq obj (vlax-ename->vla-object (ssname ss (setq n (1- n)))))
(vla-getboundingbox obj 'x 'y)
(setq lst (cons (vlax-safearray->list y)
(cons (vlax-safearray->list x) lst)
)
)
)
(setqminx (car (vl-sort (mapcar 'car lst) '<))
miny (car (vl-sort (mapcar 'cadr lst) '<))
maxx (car (vl-sort (mapcar 'car lst) '>))
maxy (car (vl-sort (mapcar 'cadr lst) '>))
)
(setq pt1 (list minx miny))
(setq pt2 (list maxx miny))
(setq pt3 (list maxx maxy))
(setq pt4 (list minx maxy))
(setq ptlist (list pt1 pt2 pt3 pt4))
)
;;选择集中心点****************************************************
(defun mc:ssmind (ss / pts ptz)
(setq pts (mc:wk ss))
(setq ptz (mc:md (car pts) (caddr pts)))
)
页:
[1]