发个批量插图/图纸后台处理程序[2013.2.5]
本帖最后由 xiaxiang 于 2013-2-5 16:19 编辑批量插入同样大小的图纸
程序思路来自明经通道网友xiaoyingzi 的帖子
http://bbs.mjtd.com/forum.php?mod=redirect&goto=findpost&ptid=89231&pid=481612&fromuid=358682
原帖现在已被我改得面目全非了，呵呵哈哈哈
帖子发出来很久没人关注，可能是介绍太少，又可能是我许久不共享程序的结果
看到没人需要我就不想再更新了，直到今天老黄把我的帖子又顶了出来
还是来做个介绍吧，程序的主体是Lee Mac的DBX容器，真的很棒！
最新版的程序，主要功能如下
一。使用DBX方法处理选中的图纸
1.将图纸中离散的属性文字转换为文字，以便插图时不再出错；
2.将图纸中模型空间的所有图形对象集合从选集的左下角点移动至坐标原点（0 0 0）；
3.对图纸模型空间模仿ZOOM命令(其实是改变view对象的属性)；
4.处理图纸字体缺失的问题；
5.清理图形中空字串文字和零长度直线和多义线；
6.其余的功能有待添加。。。
二。插图或者图纸后台处理
1.如在当前图形中选点，则将上一步处理过的图纸拷贝至当前图纸模型空间；相当于插图的功能，不过不再使用insert命令；后台处理过的图纸皆不存盘；
2.如取消选点，则将上一步处理过的图纸存盘并退出程序。
。。。
编程的酸甜苦辣只有身在其中时才能体会。
献给所有对lisp语言如痴如醉的朋友们，祝你们蛇年心想事成！
版权归各位作者，请勿用于商业用途
其余不解释
;;**********************************************************************************************
;;程序主体来自明经通道网友xiaoyingzi 的帖子
;;http://bbs.mjtd.com/forum.php?mod=redirect&goto=findpost&ptid=89231&pid=481612&fromuid=358682
;;**********************************************************************************************
;;拼图1.0程序，初版，完成于2012.1.6
;;**********************************************************************************************
;;拼图1.1程序,修正了一些bug，完成于2012.12.19
;;本程序会对需要插入的图纸进行后台操作并存盘，请注意做好备份!!!
;;程序与2004与2008下调试通过，其它版本未做测试
;;bug1.图纸插入点问题，因为要插入的图纸的左下角不在原点(0 0 0)而是一个负值，造成插图的时候方向为
;; 从右向左，与前面的图重叠;
;;bug2.属性文字问题，图纸里有属性文字，插入的时候需要手动填写值的，在自动插入时直接忽略了本张图;
;;使用了DBX方法解决了这两个问题，引用了Lee Mac的程序。注意DBX方法有使用的讲究，不能用ss选择集类，
;;command类，ent实体类，系统变量类的命令，也不能使用必须依赖活动文档activedocument相关的命令，
;;如vla-get-selectionsets，vla-ZoomExtents等;
;;DBX方法不是很稳定，在后台处理图纸时经常出现问题，不好排查，原则上在图纸打开时不即可以处理;
;;用DBX方法处理过的图纸用别的版本cad打开似乎会报错，必须用处理时那个版本的cad打开再保存一次才能
;;正常;
;;bug3.图名排序的问题，使用了VVA的高仿win_sort程序，跟windows的按名称排序基本一致，可以忽略大小写
;; 的干扰，同时加入了对"_"全部改为"-"的处理，这是因为图名不规范的原因;
;;bug4.待插入图纸的左下角判断问题，因为图纸中很多实体的插入点会影响vla-GetBoundingBox的判断，所以
;; 本例中只判断图纸中的直线和多义线两种实体的左下角点;
;;bug5.新建的图纸Drawing1.dwg执行本程序会出错，提示参数太少，再执行一次则正常，似乎跟_insert命令
;; 有关系;
;;其它未发现的bug有待进一步完善。
;;**********************************************************************************************
;;拼图1.11程序,完成于2012.12.20
;;加入了备份提示和参数修改功能，完善了注释
;;**********************************************************************************************
;;拼图1.12程序,完成于2013.1.6
;;用vla-InsertBlock 替换command "insert"，但是以上bug5依然存在，提示参数太少
;;需要插入的图纸若打开时出现报错提示框(如字体替换框)，则插入后用了缺失字体的文字不会被插入本图
;;不知如何解决
;;**********************************************************************************************
;;拼图1.2程序,完成于2013.1.9
;;增加后台替换字体功能
;;**********************************************************************************************
;;拼图1.3程序,完成于2013.1.10
;;重要更新
;;改变原有插入方式，commmand方式和vl方式；改为DBX方式
;;改变操作模式，1为DBX方式插入图纸但不改变原图纸，2为DBX方式后台处理图纸并保存
;;**********************************************************************************************
;;拼图1.4程序,完成于2013.1.16
;;重要更新
;;修正以上bug4，使用了ElpanovEvgeniy的lst-getboundingbox函数，改变了图纸的左下角点判断算法
;;增加ZOOM功能，其实是用计算左下角点和右上角点的方式来计算View(视图)的中心，高度，宽度；
;;实际与ZoomExtents还是有区别的！
;;DBX方法不能处理任何与"Active"有关的东西，activedocument或activeviewport，等等
;;**********************************************************************************************
;;拼图1.45程序,完成于2013.1.18
;;重要更新
;;继续修正以上bug4，增加了purge功能，处理0长度的文字和直线
;;**********************************************************************************************
;;全局变量赋值
(setq *x_paper_dist* 20);;全局变量，图纸x坐标偏移量，列间隔
(setq *y_paper_dist* 20);;全局变量，图纸y坐标偏移量，行间隔
(setq *x_num* 10) ;;全局变量，每行图纸数量
;;插图到一起,来源吴所不及的插计算书源程序,自己做了修改,可多选文件，自动排列插入
(defun c:batchins (/ oldosmode filelist file_list)
(setq oldosmode (getvar "osmode"))
(setvar "cmdecho" 0)
(setvar "osmode" 0)
(setq *acdoc*(vla-get-activedocument(vlax-get-acad-object)))
(setq filelist (ayGetMultFiles "选择多个DWG文件" "图形文件(*.dwg)|*.dwg|所有(*.*)|*.*" "") )
(setq *filedir* (car filelist))
(setq file_list (cdr filelist))
(if file_list
(my_insert file_list 1)
)
(princ "\n清理插入图纸临时生成的块:\n")
(command "purge" "b" "*" "n")
;(vla-purgeall (vla-get-activedocument(vlax-get-acad-object)))
(command "zoom" "e" "zoom" "0.8x")
(setvar "osmode" oldosmode)
(princ)
)
;;-------------------------------------------------------------------------------------------------------------
;; 明经通道 参照xiaomu写于2005-10-12，按wangph意见，ayunger修改于2008-11-07
;; Windows多文件选择(适用于CADR15以上) 函数
;; 说明: 本函数使用MsComDlg.Commondialog对象(Comdlg.OCX)
;; 调用: (ayGetMultFiles "多选文件" "图形文件(*.dwg)|*.dwg|所有(*.*)|*.*" "")
;; 返回: ("C:\\DWG" "1.dwg" "2.dwg" "3.Dwg")
(if (/= (vl-registry-read "HKEY_CLASSES_ROOT\\Licenses\\4D553650-6ABE-11cf-8ADB-00AA00C00905")
"gfjmrfkfifkmkfffrlmmgmhmnlulkmfmqkqj")
(vl-registry-write "HKEY_CLASSES_ROOT\\Licenses\\4D553650-6ABE-11cf-8ADB-00AA00C00905" ""
"gfjmrfkfifkmkfffrlmmgmhmnlulkmfmqkqj")
)
(defun ayGetMultFiles (strTitle strFilter strInitDir / Maxfiles Flags WinDlg mFiles Catchit)
(vl-load-com)
(setq WinDlg (vlax-create-object "MSComDlg.CommonDialog"))
(if (not WinDlg)
(progn;then
(princ "\n【错误】系统中未安装通用控件Comdlg.OCX, 请安装后再运行!")
(setq mFiles nil)
);end_progn then
(progn;else
(setq Maxfiles 32767)
(setq Flags (+ 4 512 524288 1048576 1024))
(vlax-put-property WinDlg 'CancelError :vlax-true)
(vlax-put-property WinDlg 'MaxFileSize Maxfiles)
(vlax-put-property WinDlg 'Flags Flags)
(vlax-put-property WinDlg 'DialogTitle strTitle)
(vlax-put-property WinDlg 'Filter strFilter)
(vlax-put-property WinDlg 'InitDir strInitDir)
(setq Catchit nil)
(setq Catchit (vl-catch-all-apply '(lambda ()
(vlax-invoke-method WinDlg 'ShowOpen)
(setq mFiles (vlax-get WinDlg 'Filename)))))
(vlax-release-object WinDlg)
(if (not (vl-catch-all-error-p Catchit));处理"取消"错误.
(ayFSTR->LST mFiles)
nil;else
);end_if
);end_progn
);end_if
);end_defun
;; 明经通道 参照xiaomu 按wangph意见 ayunger修改
;; 处理Windows多文件选择返回值 函数
;; 说明: 将"C:\\DWG1\0001.dwg\0002.dwg" 处理成:
;; ("C:\\DWG1" "1.dwg" "2.dwg" "3.dwg") 表形式.
(Defun ayFSTR->LST (xMFileStr / mFileList k)
(if (= xMFileStr "")
(setq mFileList nil);then
(progn
(if (vl-string-position (ascii "\000") xMFileStr)
(progn
(while (vl-string-position (ascii "\000") xMFileStr)
(setq k (vl-string-position (ascii "\000") xMFileStr))
(setq mFileList (append mFileList (list (substr xMFileStr 1 k))))
(setq xMFileStr (substr xMFileStr (+ k 2) (- (strlen xMFileStr) k 1)))
);end_while
(setq mFileList (append mFileList (list (vl-string-left-trim "\\" xMFileStr))))
);end_progn then
(progn
(setq mFileList (vl-filename-directory xMFileStr))
(setq mFileList (list mFileList (vl-string-left-trim "\\" (vl-string-subst "" mFileList xMFileStr))))
);end_progn else
);end_if
mFileList
);end_progn
);end_if
);end_defun
;;字符串转换为数字，不完善，本例没有使用
(defun str-to-num (str1)
(setq n 0)
(setq s1 "")
(while
(if (and (/= "" (setq cha (substr str1 (setq n (1+ n)) 1))))
(if (wcmatch cha "#")
(setq s1 (strcat s1 cha))
(if (/= s1 "")
nil
t
)
)
nil
)
)
(setq num1 (atoi s1))
)
;;字符串中只保留数字，本例没有使用
(defun str-remove(str / b c d e)
(setq b (vl-string->list str))
(setq c (vl-remove-if '(lambda (x) (>= x 57)) b))
(setq d (vl-remove-if '(lambda (x) (<= x 46)) c))
;以上两句是求出(0123456789)
(setq e (vl-list->string d))
)
;;;=================================================================*
;;; 通用函数 之 选择集转换系列 *
;;;=================================================================*
;;;功能：选择集转换为图元名的vla-object表 *
;;;参数：ss -----选择集 *
;;;返回：vla-object表 *
;;;本例没有使用
(defun ss2list (ss / i l objs)
(setq i -1 l (sslength ss) objs nil)
(repeat l
(setq objs (cons (vlax-ename->vla-object (ssname ss (setq i (1+ i)))) objs))
)
)
;;;=================================================================*
;;; 03 *
;;;功能：图元名表转换为选择集 *
;;;参数：lst_en -----图元名列表 *
;;;返回：选择集 *
(defun enlist->ss (lst_en / ss en)
(setq ss (ssadd))
(foreach enlst_en
(if (= (type en) 'ename)
(ssadd en ss) ;(setq ss (ssadd en ss))
)
)
;;返回
(if(= (sslength ss) 0)
nil
ss
)
)
;; [功能] 获取在图元 en 之后产生的图元列表
;; [参数] en----图元名
;; [返回] 图元列表
;; [测试]1.(setq en (entlast))
;; 执行创建图元的命令，如 LINE,BOUNDARY
;; (MJ:EntNextAll en)
;; 2.(MJ:EntNextAll (car(entsel)))
(defun MJ:EntNextAll (EN / LST)
(if EN
(while (setq EN (entnext EN))
(if (not (member (cdr (assoc 0 (entget EN)))
'("*TEXT*""ATTRIB" "VERTEX" "SEQEND")
)
)
(setq LST (cons EN LST))
)
)
)
(reverse LST)
)
;;图纸插入计算子程序
(defun my_insert (file_listscale / pt mode file_list1 num x y filename
ll ur pt1 pt2 distx disty en sslist plist)
(setq num 0)
(setq mode
(if(setq pt (getpoint "\n请选择插入点,请注意插入点为图纸的左下角<右键只处理图纸，不插入>:"))
nil
t
)
)
(if pt
(setq x (car pt)
y (cadr pt)
)
)
;;Windows type Sort function ,by VVA
(setq file_list(SortStringWithNumberAsNumberfile_list t));;文件名排序
(setq file_list1 '())
(foreach filename file_list ;;文件全路径处理
(setq file_list1 (cons (strcat *filedir* "\\" filename) file_list1))
)
(setq file_list1 (reverse file_list1))
(foreach filename file_list1
(setq en (entlast))
(progn
;*******************************************************
;调用DBX方法进行图纸后台预处理，可视情况添加删除或者禁用
(LM:ODBX 'My_Dbx_Handle (list filename) mode)
;*******************************************************
(if pt
(progn
(setq sslist(MJ:EntNextAll en)) ;;获得图纸插入后的新选择集并转换为表
(foreachen sslist ;;图纸的插入点为(0,0,0)，故将新选择集移动至新插入点
(vla-move (vlax-ename->vla-object en) (vlax-3d-point '(0 0 0)) (vlax-3d-point (list x y 0)))
)
(setq plist(lst-getboundingbox (mapcar(function vlax-ename->vla-object)sslist)))
;(setq plist(lst-getboundingbox(mapcar(function vlax-ename->vla-object)(vl-remove-if(function listp)(mapcar(function cadr)(ssnamex ss1))))))
;(mapcar(function vlax-ename->vla-object)(vl-remove-if(function listp)(mapcar(function cadr)(ssnamex ss1))))
(setq pt1(list x y 0)
pt2 (cadr plist));;计算右上角点
(setq distx (- (car pt2) (car pt1)))
(setq disty (- (cadr pt2) (cadr pt1)))
(setq x (+ distx x *x_paper_dist*)) ;_增加图的x坐标.
(setq num (1+ num))
(if (> num (1- *x_num*))
(progn
(setq y (- y(+ disty*y_paper_dist*))) ;_增加图的y坐标.
(setq x (car pt))
(setq num 0)
)
)
(princ (strcat "\n已插入" *filedir* "\\" filename))
)
)
)
)
)
;;Published http://www.theswamp.org/index.php?topic=16564.0
;;By VVA --05.20.07 mods by CAB
;;Usage (SortStringWithNumberAsNumber '("A9" "A1" "A10" "B11" "B2" "B05") nil)
;;With ignore case (SortStringWithNumberAsNumber '("A9" "A1" "A10" "B11" "B2" "B05") t)
;;CAB added Ignore Case Flag as an argument
;;Return ("A1" "A9" "A10" "B2" "B05" "B11")
(defun SortStringWithNumberAsNumber (ListOfString IgnoreCase / NorStrs count)
;;;Function Normalize (add 0 befor number) number in string
;;; Count normalize symbols set in variable count
;;; CAB added count as an argument
(defun NormalizeNumberInString (str count / ch i pat ret buf)
(setq i 0
pat '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")
ret ""
) ;_ end of setq
(while (/= (setq ch (substr str (setq i (1+ i)) 1)) "")
(if (vl-position ch pat)
(progn
(setq buf ch) ;_ end of setq
(while
(vl-position (setq ch (substr str (setq i (1+ i)) 1)) pat)
(setq buf (strcat buf ch))
) ;_ end of while
(while (< (strlen buf) count) (setq buf (strcat "0" buf)))
(setq ret (strcat ret buf))
) ;_ end of progn
) ;_ end of if
(setq ret (strcat ret ch))
) ;_ end of while
ret
) ;_ end of defun
;;-------------------------------------------------
;;function to Count the longest number in string
;;CAB added to get the correct COUNT
(defun getcount (lst / count pat)
(setq count 0)
(setq pat '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
(mapcar
'(lambda (str / i maxlen ch)
(setq i 0 maxlen 0)
(while (/= (setq ch (substr str (setq i (1+ i)) 1)) "")
(if (vl-position ch pat) ; number
(setq maxlen (1+ maxlen))
(setq count(max count maxlen) maxlen 0)
)
)
(setq count(max count maxlen)) ;_<<< ADD 21.06.2007 by VVA
)
Lst
)
count
)
;;===============================================
(setq count (GetCount ListOfString)
NorStrs (mapcar '(lambda (x) (setq x(ST_RepChar "_" "-" x)) ;;ADD 19.12.2012 by xiaxiang
(NormalizeNumberInString x count))
ListOfString)
)
(and IgnoreCase (setq NorStrs (mapcar 'strcase NorStrs)))
(mapcar '(lambda (x) (nth x ListOfString)) (vl-sort-i NorStrs '<))
) ;_ end of defun
;; | ----------------------------------------------------------------------------
;; | ST_RepChar
;; | ----------------------------------------------------------------------------
;; | Function : Replace one character in a string with another
;; | Argument : 'oldchar'- Old Character (source)
;; | 'newchar'- New Character (replace with)
;; | 'Str' - String to process
;; | Return : The string with the specified characters replaced
;; | Updated: February 5, 1999
;; | e-mail : rakesh.rao@4d-technologies.com
;; | Web : www.4d-technologies.com
;; | ----------------------------------------------------------------------------
(defun ST_RepChar(oldchar newchar Str / len cnt nstr cchar)
(setq
len (strlen str)
nstr ""
cnt 1
)
(repeat len
(setq
cchar (substr str cnt 1)
cnt (1+ cnt)
)
(if (/= cchar oldchar)
(setq nstr (strcat nstr cchar))
(setq nstr (strcat nstr newchar))
)
)
nstr
)
;;; Not used
;;; Insert block into drawing
;;; #Name - name of block
;;; #InsPt - insert point
;;; #XScale - block X scale
;;; #YScale - block Y scale
;;; #Rot - block rotation
;;; Alan J. Thompson, 04.21.09
(defun AT:InsertBlock (#Name #InsPt #XScale #YScale #Rot)
(if (or (tblsearch "block" #Name)
(findfile #Name)
) ;_ or
(vla-insertblock
((if (eq (getvar "cvport") 1)
vla-get-paperspace
vla-get-modelspace
) ;_ if
(vla-get-ActiveDocument
(vlax-get-acad-object)
) ;_ vla-get-ActiveDocument
)
(vlax-3d-point #InsPt)
#Name
#XScale
#YScale
#XScale
#Rot
) ;_ vla-insert-block
) ;_ if
) ;_ defun
;lst-getboundingbox By ElpanovEvgeniy
;lst-list of vla-object
(defun lst-getboundingbox (lst)
(vl-load-com)
(if (and lst (listp lst))
((lambda (x)
(list
(apply
(function mapcar)
(cons
(function min)
(mapcar (function car) x)
) ;_cons
) ;_apply
(apply
(function mapcar)
(cons
(function max)
(mapcar (function cadr) x)
) ;_cons
) ;_apply
) ;_list
) ;_lambda
(vl-remove-if
(function null)
(mapcar
(function
(lambda (x / minp maxp)
(if (not
(vl-catch-all-error-p
(vl-catch-all-apply
(function vla-getboundingbox)
(list x 'minp 'maxp)
) ;_vl-catch-all-apply
) ;_vl-catch-all-error-p
) ;_not
(list
(vlax-safearray->list minp)
(vlax-safearray->list maxp)
) ;_list
) ;_if
) ;_lambda
) ;_function
lst
) ;_mapcar
) ;_vl-remove-if
)
) ;_if
) ;_defun
;Not used
;Get All of the vla-object in one Layout
;Argument
;Doc -Name of Document
;Layout -Name of Layout
;Return -List of vla-object
(defun GetObjLayout (Doc Layout / newlay lst)
(vl-catch-all-error-p
(setq newlay
(vl-catch-all-apply
(function vla-item)
(list (vla-get-Layouts Doc) Layout)
)
)
)
(vlax-for o (vla-get-Block newlay)
(setq lst (cons o lst))
)
lst
)
;;------------------=={ ObjectDBX Wrapper }==-----------------;;
;; ;;
;;Evaluates a supplied function on all drawings in a ;;
;;given list or selected directory. ;;
;; ;;
;;------------------------------------------------------------;;
;; ;;
;;Author: Lee Mac, Copyright ?2012 - www.lee-mac.com ;;
;; ;;
;;------------------------------------------------------------;;
;; ;;
;;Arguments: ;;
;; ;;
;;_function ;;
;;--------------------------------- ;;
;;A function requiring a single argument (the Document ;;
;;object), and following the 'rules' of ObjectDBX: ;;
;; ;;
;;- No SelectionSets (ssget, ssname, ssdel etc) ;;
;;- No Command Calls (command "_.line" .. etc) ;;
;;- No ent* methods (entget, entmod, entupd etc) ;;
;;- No System Variables (setvar, getvar, setvariable etc) ;;
;; ;;
;;_drawinglist ;;
;;--------------------------------- ;;
;;List of DWG Filenames ;;
;;If nil, BrowseForFolder Dialog is displayed ;;
;; ;;
;;_save ;;
;;--------------------------------- ;;
;;Boolean flag determining whether drawings should be saved ;;
;;after function evaluation (T=saved, nil=not saved) ;;
;; ;;
;;------------------------------------------------------------;;
;; ;;
;;Returns: ;;
;; ;;
;;List of: ;;
;; ;;
;;( ;;
;; (<Drawing Filename> . <Function Result>) ;;
;; (<Drawing Filename> . <Function Result>) ;;
;; ... ;;
;; (<Drawing Filename> . <Function Result>) ;;
;;) ;;
;; ;;
;;Where: ;;
;; ;;
;;<Drawing Filename> ;;
;;is the filename of drawing that has been processed ;;
;; ;;
;;<Function Result> ;;
;;is the result of evaluating the supplied function on the;;
;;Document Object representing the associated drawing ;;
;;filename. ;;
;; ;;
;;If an error occurs when evaluating the supplied function;;
;;the Function Result will be nil and the error message ;;
;;will be printed to the command-line. ;;
;; ;;
;;------------------------------------------------------------;;
(defun LM:ODBX
(
_function
_drawinglist
_save
/
*error*
_releaseobject
acapp acdoc acdocs dbxdoc doc err path result
)
(defun *error* ( msg )
(_releaseobject doc)
(_releaseobject dbxdoc)
(if (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
(princ (strcat "\nError: " msg))
)
(princ)
)
(defun _releaseobject ( obj )
(if
(and
(eq 'VLA-OBJECT (type obj))
(not (vlax-object-released-p obj))
)
(vl-catch-all-apply 'vlax-release-object (list obj))
)
)
(setq
acapp(vlax-get-acad-object)
acdoc(vla-get-activedocument acapp)
dbxdoc (LM:ObjectDBXDocument acapp)
)
(vlax-for x (vla-get-documents acapp)
(setq acdocs
(cons
(cons (strcase (vla-get-fullname x)) x)
acdocs
)
)
)
(foreach dwg
(cond
( _drawinglist )
( (setq path (LM:DirectoryDialog "Select Folder of Drawings to Process" nil 512))
(mapcar
(function (lambda ( filename ) (strcat path "\\" filename)))
(vl-directory-files path "*.dwg" 1)
)
)
)
(if
(setq doc
(cond
( (cdr (assoc (strcase dwg) acdocs)) )
( (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-open (list dbxdoc dwg))))
dbxdoc
)
)
)
(progn
(setq err (vl-catch-all-apply _function (list doc)))
(setq result
(cons
(cons
dwg
(if (vl-catch-all-error-p err)
(prompt (strcat "\n" dwg "\t" (vl-catch-all-error-message err)))
err
)
)
result
)
)
(if _save
(vla-saveas doc dwg)
)
)
(princ (strcat "\nError Opening File: " (vl-filename-base dwg) ".dwg"))
)
)
(_releaseobject doc)
(_releaseobject dbxdoc)
(reverse result)
)
;;-------------------=={ Directory Dialog }==-----------------;;
;; ;;
;;Displays a dialog prompting the user to select a folder ;;
;;------------------------------------------------------------;;
;;Author: Lee Mac, Copyright ?2012 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;;Arguments: ;;
;;msg- message to display at top of dialog ;;
;;dir- root directory (or nil) ;;
;;flag - bit coded flag specifying dialog display settings;;
;;------------------------------------------------------------;;
;;Returns:Selected folder filepath, else nil ;;
;;------------------------------------------------------------;;
(defun LM:DirectoryDialog ( msg dir flag / fold path self shell )
(vl-catch-all-apply
(function
(lambda ( / acapp hwnd )
(if
(setq
acapp (vlax-get-acad-object)
shell (vla-getInterfaceObject acapp "Shell.Application")
hwnd(vl-catch-all-apply 'vla-get-hwnd (list acapp))
fold(vlax-invoke-method shell 'BrowseForFolder (if (vl-catch-all-error-p hwnd) 0 hwnd) msg flag dir)
)
(setq
self (vlax-get-property fold 'Self)
path (vlax-get-property self 'Path)
path (vl-string-right-trim "\\" (vl-string-translate "/" "\\" path))
)
)
)
)
)
(if self(vlax-release-objectself))
(if fold(vlax-release-objectfold))
(if shell (vlax-release-object shell))
path
)
;;-----------------=={ ObjectDBX Document }==-----------------;;
;; ;;
;;Retrieves a version specific ObjectDBX Document object ;;
;;------------------------------------------------------------;;
;;Author: Lee Mac, Copyright ?2012 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;;Arguments: ;;
;;acapp - AutoCAD VLA Application Object ;;
;;------------------------------------------------------------;;
;;Returns:VLA ObjectDBX Document object, else nil ;;
;;------------------------------------------------------------;;
(defun LM:ObjectDBXDocument ( acapp / acver )
(vla-getinterfaceobject acapp
(if (< (setq acver (atoi (getvar "ACADVER"))) 16)
"ObjectDBX.AxDbDocument"
(strcat "ObjectDBX.AxDbDocument." (itoa acver))
)
)
)
(vl-load-com) (princ)
;;------------------------------------------------------------;;
;; End of File ;;
;;------------------------------------------------------------;;
;; change exploded block attribute tags to text
;; From T.Willey
;;http://forums.augi.com/showthread.php?40372-change-exploded-block-attribute-tags-to-text&p=351262&viewfull=1#post351262
;;When working with ObjectDBX you are working with the ObjectDBX Document Object,
;;not the ActiveDocument, so the function supplied to my ObjectDBX Wrapper function
;;will need to require a single argument - the ObjectDBX Document.
(defun AttDef2Text ( Doc / ActDoc LayoutCol tmpLayoutBlk)
; Changes attdef entities (attributes that haven't been put into a block) into dtext in the whole drawing
;(setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
;(vla-StartUndoMark ActDoc)
(setq LayoutCol (vla-get-Layouts Doc))
(vlax-for LayoutObj LayoutCol
(setq tmpLayoutBlk (vla-get-Block LayoutObj))
(vlax-for Obj tmpLayoutBlk
(if (= (vla-get-ObjectName Obj) "AcDbAttributeDefinition")
(progn
(setq TextObj (vla-AddText tmpLayoutBlk (vla-get-TagString Obj) (vla-get-InsertionPoint Obj) (vla-get-Height Obj)))
(vla-put-Alignment TextObj (vla-get-Alignment Obj))
(if (/= (vla-get-Alignment TextObj) 0)
(vla-put-TextAlignmentPoint TextObj (vla-get-TextAlignmentPoint Obj))
)
(vla-put-Backward TextObj (vla-get-Backward Obj))
(vla-put-Layer TextObj (vla-get-Layer Obj))
(vla-put-Normal TextObj (vla-get-Normal Obj))
(vla-put-ObliqueAngle TextObj (vla-get-ObliqueAngle Obj))
(vla-put-Rotation TextObj (vla-get-Rotation Obj))
(vla-put-ScaleFactor TextObj (vla-get-ScaleFactor Obj))
(vla-put-StyleName TextObj (vla-get-StyleName Obj))
(vla-put-UpsideDown TextObj (vla-get-UpsideDown Obj))
(vla-Delete Obj)
)
)
)
)
;(vla-EndUndoMark ActDoc)
(princ)
)
;Delete empty text & zero length lines & polylines
(defun purge_all(Doc / newlay)
;(vla-PurgeAll Doc)
(vl-catch-all-error-p
(setq newlay
(vl-catch-all-apply
(function vla-item)
(list (vla-get-Layouts Doc) "Model")
)
)
)
(vlax-for o (vla-get-Block newlay)
(if (or
;empty text
(and(wcmatch(strcase(vla-get-objectname o))"*TEXT")(wcmatch(vla-get-TextString o)", "))
;zero length lines & polylines
(and(wcmatch(strcase(vla-get-objectname o))"*LINE")(equal(vlax-curve-getdistatparam o(vlax-curve-getendparam o))0.0 1e-6))
)
(vl-catch-all-error-p(vl-catch-all-apply 'vla-delete (list o)))
)
)
)
;;处理图纸左下角点子程序
(defun get_all_move ( Doc / newlay lst plist)
(vl-catch-all-error-p
(setq newlay
(vl-catch-all-apply
(function vla-item)
(list (vla-get-Layouts Doc) "Model")
)
)
)
(setq plist
(lst-getboundingbox
(vlax-for o (vla-get-Block newlay)
(setq lst (cons o lst))
)
)
)
(vlax-for o (vla-get-Block newlay)
(vla-move o (vlax-3d-point (car plist)) (vlax-3d-point '(0 0 0)))
)
)
;;处理图纸缩放范围子程序
(defun zoom_view (Doc / views av v p1 p2 c1 ds newlay lst plist)
;***********************************************
;;CAB 11.16.07 rev. 12.23.08
;;Remove based on pointer list
(defun RemoveNlst (nlst lst)
(setq i -1)
(vl-remove-if '(lambda (x) (vl-position (setq i (1+ i)) nlst)) lst)
)
;;***************************Main Routine**************************
(setq views (vla-get-views Doc) av(vla-item(vla-get-Viewports Doc)0));;Is there No.1 Viewport in each dwg？
(vl-catch-all-error-p
(setq newlay
(vl-catch-all-apply
(function vla-item)
(list (vla-get-Layouts Doc) "Model")
)
)
)
(setq plist
(lst-getboundingbox
(vlax-for o (vla-get-Block newlay)
(setq lst (cons o lst))
)
)
)
(setq v (vla-Add views "MyView"))
(setq p1 (car plist);'(100. 100.)
p2 (cadr plist);'(500. 500.)
c1 (mapcar '(lambda (x y) (* 0.5 (+ x y))) p1 p2)
ds (mapcar 'abs (mapcar '- p1 p2)))
(vlax-put v 'Center (RemoveNlst '(2) c1))
(vlax-put v 'Height (cadr ds))
(vlax-put v 'Width (car ds))
(vla-setview av v)
;(vla-put-activeViewport Doc av);;No need and can not to activeViewport
(vla-Delete v)
(princ)
)
;;处理字体缺失问题
(defun change_font (Doc / Font BigFont Ttf obj)
;;CAB @ TheSwamp 15.11.12
;;returns nil if not found, else font name if found
;;TTF file names should have the extension already added
;;"romant.ttf"
(defun find_font (fname / path font$)
(setq path (getenv "windir"))
(if (vl-position (substr path (strlen path)) '("/" "\\"))
(setq path (strcat path "FONTS\\"))
(setq path (strcat path "\\FONTS\\"))
)
(setq font$ (if (wcmatch fname "*\\*,*`.*")
fname
(strcat fname ".shx")
)
)
(cond
((findfile font$) font$)
((and path (findfile (strcat path font$))) font$)
((= fname "") fname) ;;Added By xiaxiang 09.01.13
(t nil)
)
)
;;CAB @ TheSwamp 03.06.07
;;Modified By xiaxiang 09.01.13
;;Create or Update a Text Style
;;Returns T is sucessfull created/updated else nil
;;Prompts with any failures
;;On Failure of Height or Width the other operations are completed
(defun CREATE_TEXTSTYLE
(Doc ;document
StyleName ; String - "txt" or "txt.shx" or "ArialN.TTF"
Font ; String
BigOrNot ; T -> BigFont and nil -> Font
/ TextStyles VLTextStyle msg)
(vl-load-com)
(if (null (wcmatch Font "*`.*"))
(setq Font (strcat Font ".shx"))
)
(if
(or (and (setq file (findfile font)) ; found an shx font
(setq file font)
)
(setq file (findfile (strcat (getenv "windir") "\\fonts\\" font)))
(prompt (strcat "\nFont File " Font " not found."))
)
(progn
(princ (strcat "\nText Style " StyleName))
(if (tblsearch "style" StyleName)
(princ " Updateing....")
(princ " Createing....")
)
(setq TextStyles (vla-get-textstyles Doc))
(if (vl-catch-all-error-p
(setq VLTextStyle
(vl-catch-all-apply
'vla-add (list (vla-get-textstyles Doc) StyleName))))
(not (princ " Failed\n**Bad Style Name...."))
(progn
(or (not (vl-catch-all-error-p
(vl-catch-all-apply 'vlax-put (list VLTextStyle (if BigOrNot 'BigFontFile'FontFile) file))))
(prompt "\n**Bad Font File...."))
)
)
)
)
)
;;***************************Main Routine**************************
(setq Font "simplex" BigFont "hztxt" Ttf"simfang.ttf")
(vlax-for obj (vla-get-textstyles Doc)
(if (null(find_font (vla-get-fontfile obj)))
(if(wcmatch (vla-get-fontfile obj) "*tt@,*TT@")
(CREATE_TEXTSTYLE Doc (vla-get-name obj) Ttf nil)
(CREATE_TEXTSTYLE Doc (vla-get-name obj) Font nil)
)
)
(if (null(find_font (vla-get-bigfontfile obj)))
(CREATE_TEXTSTYLE Doc (vla-get-name obj) BigFont t)
)
) ;_ vlax-for
;(vla-regen Doc 1)
)
;;将图纸拷贝至当前图纸模型空间
(defun CopyFromAnother ( Doc / l o name objlst newlay)
(vlax-for l (vla-get-Layouts Doc)
(if (= (setq name (vla-get-Name l)) "Model")
(progn
(setq objlst nil)
(vlax-foro (vla-get-Block l)
(setq objlst (cons o objlst))
)
(vl-catch-all-error-p
(setq newlay
(vl-catch-all-apply
(function vla-item)
(list (vla-get-Layouts *acdoc*) "Model")
)
)
)
(vla-Copyfrom newlay l);;the layout object (plot settings and visual properties) which can be copied by vla-CopyFrom
(vlax-invoke
Doc
'CopyObjects ;;and an block (graphic objects and viewports) which components can be copied by vla-CopyObjects
(reverse objlst)
(vla-get-Block newlay)
)
)
)
)
)
;;DBX方法集中处理子程序
(defun My_Dbx_Handle (Doc)
(change_font Doc)
(AttDef2Text Doc)
(purge_all Doc)
(get_all_move Doc)
(zoom_view Doc)
(if (null mode)(CopyFromAnother Doc))
)
;;适时模式打印子程序
(defun printt ()
(princ (strcat "\n*****行距" (rtos *x_paper_dist* 2 0) "，列距" (rtos *y_paper_dist* 2 0) "，每行" (rtos *x_num* 2 0) "张图纸*****\n"))
)
(defun c:modify ()
(printt)
;;参数调整子程序
(defun xxkey (global str / key keyw )
(setq key
(getint
(strcat str
(rtos global 2 0)
">>: "
)
)
)
(if (not key)
(setq keyw global)
(setq keyw key)
)
(setq global keyw)
)
;;此处可修改行距
(setq *x_paper_dist*(xxkey *x_paper_dist* "\n请输入行距,回车重复上次选择 : <<"))
;;此处可修改列距
(setq *y_paper_dist*(xxkey *y_paper_dist* "\n请输入列距,回车重复上次选择 : <<"))
;;此处可修改每行图纸数量
(setq *x_num*(xxkey *x_num* "\n请输入每行图纸数量,回车重复上次选择 : <<"))
(printt)
(princ)
)
(princ "\n*****快速拼图程序 命令：batchins*****")
(princ "\n***** 可用命令：modify修改参数*****")
(printt)
(princ)
是可以插入，就是有些特殊图元，比如勘察中的理正图元会丢失 本帖最后由 softbird 于 2019-4-8 17:21 编辑
有多个目录的dwg分别要合并成对应的目录名.DWG，请教一下如何加上批处理，比如把所有的目录名作为参数加到scr文件分别执行合并，然后保存为各自的目录名.DWG。
[*](defun c:dj()
[*](command "filedia" 0)
[*](command "script" "d:/1.scr")
[*](command "filedia" 1)
[*]1.scr
[*](batchinsert "D:\\图纸合并\\dwg1")(batchinsert "D:\\图纸合并\\dwg2")(batchinsert "D:\\图纸合并\\dwg3")(batchinsert "D:\\图纸合并\\dwg4")
[*]请教一下主程序应该怎么修改
xiaxiang 发表于 2013-8-20 13:07
朋友，你的例图我已经看过了。程序的作用是将零散的带图框的图纸批量插入你运行程序的这张图纸，不知道你 ...
能改善一下代码吗 图框大小不一致会出现重叠的地方 支持版主... 支持版主，支持源码，留存备用！ 这个必须预留个位置，顺便问一下DXF可以实现上面的演示吗？
谢谢 这个对打印人员特别有用,谢谢共享！！ 版主我爱死你了！！ 试用了一下，感觉还不错，但有几点疑问，请教X版
1 若一张图上，有A2 A3 A4几张图怎么办？
2 假如图框不是块怎么办？
3 假如有二个件，一个是A2 ，一个A4，怎么判断?
4 假如二个文件，都是A2图，放大比例不同，如何处理？ 本帖最后由 xiaxiang 于 2013-2-7 11:59 编辑
自贡黄明儒 发表于 2013-2-7 11:27 http://bbs.mjtd.com/static/image/common/back.gif
试用了一下，感觉还不错，但有几点疑问，请教X版
1 若一张图上，有A2 A3 A4几张图怎么办？
2 假如图框不是 ...
感谢关注，请教谈不上，互相学习，共同进步。
本程序主要考虑的是拼图或者后台处理图形，我想研究或讨论的是DBX方法。
1.被插的那张图上有多少图没有关系，但最好是单文件单图，不然插图后也是不规整排列的？
2.计算插图的时候与图框的类型无关，计算的是被插图形里的所有对象。
3.若有各种版面的图纸想拼到一张图上，是否可以考虑全部拼到一行，设置一下参数即可。这涉及到排版的问题，若按照版面来排版，是否会打乱原来的图样顺序？目前是按照图纸文件的名称来计算顺序的，没有考虑版面不同的问题，不知道有什么好的建议没有？
4.图纸比例的问题没考虑过，假如原图图框大小是一致的，插入后仍然不变，且插入后图形的比例与原图一致。
欢迎深入讨论，谢谢。 谢谢版主的好程序！有个问题帮忙看一下，
有些图形提示错误：参数值错误: AcDbCurve -33813392；（xiaoyingzi 的那个我用了，没有这个提示）
为何生 发表于 2013-2-8 14:32 static/image/common/back.gif
谢谢版主的好程序！有个问题帮忙看一下，
有些图形提示错误：参数值错误: AcDbCurve -33813392；（xiaoyin ...
庆祝论坛重生，回复测试：
这个报错估计是清理零长度直线造成的，方便的话上传样图以便调试。。。