[编程交流] Autocad开源绘图

(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)

(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 - [str] 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 - [str/int] 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)

(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 )
[b][i][color=red](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[/color][/i][/b]
        (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 )
[b][i][color=red](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[/color][/i][/b]
)
;;
(defun findblock ( dwg )
   (vl-some '(lambda ( p ) (findfile (strcat p dwg)))
      '(   ""
[color=seagreen]"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\"[/color] 
       )
   )
)
;; Drawing Open-p  -  Lee Mac
;; Returns the owner of an open drawing, else nil if the drawing is unopen.
;; dwg - [str] 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 - [str/int] 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)

12

13