(defun partsearch (n /)
(cond
((findfile n)) ;;; first search the dir's in AutoCAD's "env" variable, then search the additional places listed below:
((findfile (strcat "H:/bloc/profile/" n))) ;;;<--- this is an example path
((findfile (strcat "H:/bloc/gomme/" n)));;;<--- this is another example path
;;; etc, etc. List as many block folder
;;; paths as you need, following the patterns
(t (progn
(prompt
(strcat "** PartSearch Error ** Required file (" n ") could not be found."))
(terpri)
)
)
)
);defun
;;; ----------- Open source drawing of selected Block--------------
(defun c:OpenBL ( / cmdecho regen n bpath)
(setq cmdecho (getvar "cmdecho"))
(setq regen (getvar "regenmode"))
(setvar "cmdecho" 0)
(setvar "regenmode" 0)
(setq ent (car (entsel "\nSelect Block Entity: ")))
(if(eq (cdr (assoc 0 (entget ent))) "INSERT")
(progn
(setq BLKN (vla-get-effectivename
(vlax-ename->vla-object ent)))
)
)
(setq bpath (partsearch (strcat blkn ".dwg")))
(if bpath
(if (= 0 (getvar "SDI"))
(vla-activate (vla-open (vla-get-documents (vlax-get-acad-object)) bpath))
(vla-sendcommand
(vla-get-activedocument
(vlax-get-acad-object))
(strcat "(command \"_.open\")\n" bpath "\n") )
)
)
(setvar "cmdecho" cmdecho)
(setvar "regenmode" 1)
(princ)
); close defun
(princ)
;;; ----------- Insert & rededine Block --------------
(defun c:ReInsertBL ( / cmdecho regen n bpath)
(setq cmdecho (getvar "cmdecho"))
(setq regen (getvar "regenmode"))
(setvar "cmdecho" 0)
(setvar "regenmode" 0)
(setq ent (car (entsel "\nSelect Block Entity: ")))
(if(eq (cdr (assoc 0 (entget ent))) "INSERT")
(progn
(setq BLKN (vla-get-effectivename
(vlax-ename->vla-object ent)))
)
)
(setq bpath (partsearch (strcat blkn ".dwg")))
(if bpath
(vl-cmdf "insert" (strcat blkn "=" bpath) )
(command)
)
(setvar "cmdecho" cmdecho)
(setvar "regenmode" 1)
(princ)
); close defun
(princ)
通过第一个lisp命令“openBL”，如果该图形已经打开，Autocad是否可能不打开该图形！！！！
谁能帮帮我吗？ 请尝试以下代码：
(defun c:openbl ( / blk lst src usr )
(cond
( (not (setq blk (selectblock "\nSelect block to open source drawing: "))))
( (not (setq src (findblock (strcat blk ".dwg"))))
(princ (strcat "\n" blk ".dwg not found."))
)
( (progn
(vlax-for doc (vla-get-documents (vlax-get-acad-object))
(setq lst (cons (cons (strcase (vla-get-fullname doc)) doc) lst))
)
(assoc (strcase src) lst)
)
(vla-activate (cdr (assoc (strcase src) lst)))
)
( (setq usr (LM:dwgopen-p src))
(princ (strcat "\n" src " is currently in use by " usr))
)
( (LM:open src))
)
(princ)
)
(defun c:reinsertbl ( / blk src val var )
(cond
( (not (setq blk (selectblock "\nSelect block to redefine: "))))
( (not (setq src (findblock (strcat blk ".dwg"))))
(princ (strcat "\n" blk ".dwg not found."))
)
( (setq var '(cmdecho regenmode)
val(mapcar 'getvar var)
)
(mapcar 'setvar var '(0 0))
(command "_.-insert" (strcat blk "=" src) nil)
(mapcar 'setvar var val)
)
)
(princ)
)
(defun selectblock ( msg / obj rtn )
(while
(progn (setvar 'errno 0) (setq obj (car (entsel msg)))
(cond
( (= 7 (getvar 'errno))
(princ "\nMissed, try again.")
)
( (/= "INSERT" (cdr (assoc 0 (entget obj))))
(princ "\nSelected object is not a block.")
)
( (vlax-property-available-p (setq obj (vlax-ename->vla-object obj)) 'effectivename)
(null (setq rtn (vla-get-effectivename obj)))
)
( (null (setq rtn (vla-get-name obj))))
)
)
)
rtn
)
(defun findblock ( dwg )
(vl-some '(lambda ( p ) (findfile (strcat p dwg)))
'( ""
"H:/bloc/profile/"
"H:/bloc/gomme/"
)
)
)
;; Drawing Open-p-Lee Mac
;; Returns the owner of an open drawing, else nil if the drawing is unopen.
;; dwg - Drawing filename
(defun LM:dwgopen-p ( dwg / dwl tmp usr )
(if (and (setq dwl (findfile (strcat (substr dwg 1 (- (strlen dwg) 3)) "dwl")))
(null (vl-file-delete dwl))
)
(if (setq tmp (open dwl "r"))
(progn
(setq usr (read-line tmp)
tmp (close tmp)
)
usr
)
"<Unknown>"
)
)
)
;; Open-Lee Mac
;; Uses the 'Open' method of the Shell Object to open the specified file or folder.
;; tar - File, folder or ShellSpecialFolderConstants enum
(defun LM:open ( tar / shl rtn )
(if (and (or (= 'int (type tar)) (setq tar (findfile tar)))
(setq shl (vla-getInterfaceObject (vlax-get-acad-object) "shell.application"))
)
(progn
(setq rtn (vl-catch-all-apply 'vlax-invoke (list shl 'open tar)))
(vlax-release-object shl)
(not (vl-catch-all-error-p rtn))
)
)
)
(vl-load-com) (princ) 嗨，李，
我测试了您的lisp，它与目录链接“H:/bloc/gomme/”和“H:/bloc/gomme/”一起工作。我将这个direntory链接更改为：
“P:/GBR\U GreatBritain/02-DESIGN/02-05-BLOCKS/Shields/”
“P:/GBR\u GreatBritain/02-DESIGN/02-05-BLOCKS/Casting/”
“P:/GBR\u GreatBritain/02-DESIGN/02-05-BLOCKS/Mouldings/”
“P:/GBR\u GreatBritain/02-DESIGN/02-05-BLOCKS/Accessories/”
现在lisp不起作用，块未找到。你知道为什么吗？ 嗨，李，
我想我发现了问题：绿色改装
我还更改了块选择方法，因为我想选择嵌套块：修改为红色，可以吗？？？
(defun c:openbl ( / blk lst src usr )
(cond
( (not (setq blk (selectblock "\nSelect block to open source drawing: "))))
( (not (setq src (findblock (strcat blk ".dwg"))))
(princ (strcat "\n" blk ".dwg not found."))
)
( (progn
(vlax-for doc (vla-get-documents (vlax-get-acad-object))
(setq lst (cons (cons (strcase (vla-get-fullname doc)) doc) lst))
)
(assoc (strcase src) lst)
)
(vla-activate (cdr (assoc (strcase src) lst)))
)
( (setq usr (LM:dwgopen-p src))
(princ (strcat "\n" src " is currently in use by " usr))
)
( (LM:open src))
)
(princ)
)
;;
(defun c:reinsertbl ( / blk src val var )
(while (/=(type(setq e (car(last(nentsel "\nSelect block to redefine: "))))) 'ENAME))
(setq obj (vlax-ename->vla-object e))
(if (= (vlax-get-property obj 'ObjectName) "AcDbBlockReference")
(setq blk (vlax-get-property obj
(if (vlax-property-available-p obj 'effectivename)'effectivename 'name))
);setq
);if
(setq src (findblock (strcat blk ".dwg")))
(princ (strcat "\n" blk ".dwg not found."))
( (setq var '(cmdecho regenmode)
val(mapcar 'getvar var)
)
(mapcar 'setvar var '(0 0))
(command "_.-insert" (strcat blk "=" src))
(mapcar 'setvar var val)
)
(princ)
)
;;
(defun selectblock ( msg / obj rtn )
(while (/=(type(setq e (car(last(nentsel "\nSelect block to redefine: "))))) 'ENAME))
(setq obj (vlax-ename->vla-object e))
(if (= (vlax-get-property obj 'ObjectName) "AcDbBlockReference")
(setq rtn (vlax-get-property obj
(if (vlax-property-available-p obj 'effectivename)'effectivename 'name))
);setq
);if
)
;;
(defun findblock ( dwg )
(vl-some '(lambda ( p ) (findfile (strcat p dwg)))
'( ""
"P:\\GBR_GreatBritain\\02-DESIGN\\02-05-BLOCKS\\Profiles\\"
"P:\\GBR_GreatBritain\\02-DESIGN\\02-05-BLOCKS\\Gaskets\\"
"P:\\GBR_GreatBritain\\02-DESIGN\\02-05-BLOCKS\\Castings\\"
"P:\\GBR_GreatBritain\\02-DESIGN\\02-05-BLOCKS\\MouldingPieces\\"
)
)
)
;; Drawing Open-p-Lee Mac
;; Returns the owner of an open drawing, else nil if the drawing is unopen.
;; dwg - Drawing filename
(defun LM:dwgopen-p ( dwg / dwl tmp usr )
(if (and (setq dwl (findfile (strcat (substr dwg 1 (- (strlen dwg) 3)) "dwl")))
(null (vl-file-delete dwl))
)
(if (setq tmp (open dwl "r"))
(progn
(setq usr (read-line tmp)
tmp (close tmp)
)
usr
)
"<Unknown>"
)
)
)
;; Open-Lee Mac
;; Uses the 'Open' method of the Shell Object to open the specified file or folder.
;; tar - File, folder or ShellSpecialFolderConstants enum
(defun LM:open ( tar / shl rtn )
(if (and (or (= 'int (type tar)) (setq tar (findfile tar)))
(setq shl (vla-getInterfaceObject (vlax-get-acad-object) "shell.application"))
)
(progn
(setq rtn (vl-catch-all-apply 'vlax-invoke (list shl 'open tar)))
(vlax-release-object shl)
(not (vl-catch-all-error-p rtn))
)
)
)
(vl-load-com) (princ) 请尝试以下操作：
恐怕我无法就您的路径提供建议-如果找不到块，则路径一定不正确。
李 嗨，李
这正是我需要的，非常感谢
弗朗辛 你好
最后一个请求是，我有一个lisp用于重新定义图形中的许多块。这个lisp很好用，但是当一个有很多块的大图时，例程有时需要2分钟甚至更多。有没有办法优化这个lisp。也许只重新定义修改日期早于绘图日期的块！！！
我还希望通过脚本和批处理来实现这一点，我发现了这个解决方案：http://www.widom-assoc.com/AU-CP12-3L.pdf但我需要时间来理解它是如何工作的。
12
不客气，弗朗辛。
以下代码是否更快？
13 你好，李，
我尝试了你的Lisp程序，但我变成了唯一的信息，比如：
忽略块EF4318的重复定义。
忽略块EP1780的重复定义。
忽略块EP1781的重复定义。
页:
1
[2]