Jump to content

LISP to attach xref to multiple drawings


Pattosun

Recommended Posts

3 hours ago, rlx said:

I don't have zwcad and never used it so not sure if its compatible with visual lisp. Maybe there lies your problem because this is mainly a forum for AutoCad. But I tested it on my own system (AutoCad2022) and for me it works.

(defun c:RlxOdbxDeleteXref (/ _getfolder dbx_ver app dbxv folder xref-name )
  (vl-load-com)
  (defun _getfolder ( m / sh f r )
    (setq sh (vla-getinterfaceobject (vlax-get-acad-object) "Shell.Application") f (vlax-invoke-method sh 'browseforfolder 0 m 0))
    (vlax-release-object sh)(if f (progn (setq r (vlax-get-property (vlax-get-property f 'self) 'path))(if (wcmatch r "*\\") r (strcat r "\\")))))
  (defun dbx_ver ( / v)
    (strcat "objectdbx.axdbdocument" (if (< (setq v (atoi (getvar 'acadver))) 16) "" (strcat "." (itoa v)))))
  (defun void (x) (or (not x) (= "" x) (and (eq 'STR (type x)) (not (vl-remove 32 (vl-string->list x))))))
  (setq app (vlax-get-acad-object) dbxv (dbx_ver))
  
  (cond
    ((void (setq xref-name (getstring "\nEnter name of xref you want to detach : ")))
     (princ "\nComputer says no : invalid xref name"))
    ((vl-catch-all-error-p (setq odbx (vl-catch-all-apply 'vla-getinterfaceobject (list app dbxv))))
     (princ "\nObject DBX interface not created!"))
    ((setq folder (_getfolder "Select folder with drawings to delete (ALL) xrefs"))
     (setq xref-name (strcase xref-name))
     (foreach dwg (vl-directory-files folder "*.dwg" 0)
       (setq dwg (strcat folder dwg))
       (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-open (list odbx dwg)))
	 (princ (strcase (strcat "\nError opening: " dwg)))
	 (progn
	   (princ (strcat "\nOpening: " dwg))
	   ;;; seek & destroy (all) xrefs
	   (vlax-for lt (vla-get-layouts odbx)
	     (vlax-for blkobj (vla-get-block lt)
	       (if (and
		     (eq (vla-get-objectname blkobj) "AcDbBlockReference")
		     (vlax-property-available-p blkobj 'Path)
		     (eq xref-name (strcase (vl-filename-base (vla-get-name blkobj)) t))
		   )
		 
		 (vlax-invoke-method blkobj 'Delete)
               )
             )
           )
	   ; save drawing
	   (vla-saveas odbx (vla-get-name odbx))
         );end progn
       );end if
       (princ "\nDone")
     ); end foreach
    ); end setq folder
    (t (princ "\nComputer says no"))
  ); end cond
  (vl-catch-all-apply 'vlax-release-object (list app))
  (vl-catch-all-apply 'vlax-release-object (list odbx))
  (princ)
)

 

thank you so much it's works now.much appreciated your effort for me😍😍

Link to comment
Share on other sites

  • 1 month later...
On 9/28/2022 at 2:33 PM, rlx said:

 

(defun c:RlxOdbxDeleteXref (/ _getfolder dbx_ver app dbxv folder xref-name )
  (vl-load-com)
  (defun _getfolder ( m / sh f r )
    (setq sh (vla-getinterfaceobject (vlax-get-acad-object) "Shell.Application") f (vlax-invoke-method sh 'browseforfolder 0 m 0))
    (vlax-release-object sh)(if f (progn (setq r (vlax-get-property (vlax-get-property f 'self) 'path))(if (wcmatch r "*\\") r (strcat r "\\")))))
  (defun dbx_ver ( / v)
    (strcat "objectdbx.axdbdocument" (if (< (setq v (atoi (getvar 'acadver))) 16) "" (strcat "." (itoa v)))))
  (defun void (x) (or (not x) (= "" x) (and (eq 'STR (type x)) (not (vl-remove 32 (vl-string->list x))))))
  (setq app (vlax-get-acad-object) dbxv (dbx_ver))
  
  (cond
    ((void (setq xref-name (getstring "\nEnter name of xref you want to detach : ")))
     (princ "\nComputer says no : invalid xref name"))
    ((vl-catch-all-error-p (setq odbx (vl-catch-all-apply 'vla-getinterfaceobject (list app dbxv))))
     (princ "\nObject DBX interface not created!"))
    ((setq folder (_getfolder "Select folder with drawings to delete (ALL) xrefs"))
     (setq xref-name (strcase xref-name))
     (foreach dwg (vl-directory-files folder "*.dwg" 0)
       (setq dwg (strcat folder dwg))
       (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-open (list odbx dwg)))
	 (princ (strcase (strcat "\nError opening: " dwg)))
	 (progn
	   (princ (strcat "\nOpening: " dwg))
	   ;;; seek & destroy (all) xrefs
	   (vlax-for lt (vla-get-layouts odbx)
	     (vlax-for blkobj (vla-get-block lt)
	       (if (and
		     (eq (vla-get-objectname blkobj) "AcDbBlockReference")
		     (vlax-property-available-p blkobj 'Path)
		     (eq xref-name (strcase (vl-filename-base (vla-get-name blkobj)) t))
		   )
		 
		 (vlax-invoke-method blkobj 'Delete)
               )
             )
           )
	   ; save drawing
	   (vla-saveas odbx (vla-get-name odbx))
         );end progn
       );end if
       (princ "\nDone")
     ); end foreach
    ); end setq folder
    (t (princ "\nComputer says no"))
  ); end cond
  (vl-catch-all-apply 'vlax-release-object (list app))
  (vl-catch-all-apply 'vlax-release-object (list odbx))
  (princ)
)

 

 hi rlx. i already try this code . after i put "name of xref you want to detach". nothing all happen you can see on picture i attach

log.jpg

log2.jpg

Link to comment
Share on other sites

5 hours ago, rlx said:

sorry , your picture is to small to see anyting.

sorry my mistake . i already reattach with new picture. and the problem is  i already try this code . after i put "name of xref you want to detach". nothing all happen you can see on picture i attach

log2.jpg

log.jpg

Link to comment
Share on other sites

(defun c:RlxOdbxDeleteXref (/ _getfolder dbx_ver app dbxv folder xref-name )
  (vl-load-com)
  (defun _getfolder ( m / sh f r )
    (setq sh (vla-getinterfaceobject (vlax-get-acad-object) "Shell.Application") f (vlax-invoke-method sh 'browseforfolder 0 m 0))
    (vlax-release-object sh)(if f (progn (setq r (vlax-get-property (vlax-get-property f 'self) 'path))(if (wcmatch r "*\\") r (strcat r "\\")))))
  (defun dbx_ver ( / v)
    (strcat "objectdbx.axdbdocument" (if (< (setq v (atoi (getvar 'acadver))) 16) "" (strcat "." (itoa v)))))
  (defun void (x) (or (not x) (= "" x) (and (eq 'STR (type x)) (not (vl-remove 32 (vl-string->list x))))))
  (setq app (vlax-get-acad-object) dbxv (dbx_ver))
  
  (cond
    ((void (setq xref-name (getstring "\nEnter name of xref you want to detach : ")))
     (princ "\nComputer says no : invalid xref name"))
    ((vl-catch-all-error-p (setq odbx (vl-catch-all-apply 'vla-getinterfaceobject (list app dbxv))))
     (princ "\nObject DBX interface not created!"))
    ((setq folder (_getfolder "Select folder with drawings to delete xref"))
     (setq xref-name (strcase xref-name))
     (foreach dwg (vl-directory-files folder "*.dwg" 0)
       (setq dwg (strcat folder dwg))
       (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-open (list odbx dwg)))
	 (princ (strcase (strcat "\nError opening: " dwg)))
	 (progn
	   (princ (strcat "\nOpening: " dwg))
	   (vlax-for lt (vla-get-layouts odbx)
	     (vlax-for blkobj (vla-get-block lt)
	       (if (and
		     (eq (vla-get-objectname blkobj) "AcDbBlockReference")
		     (vlax-property-available-p blkobj 'Path)
		     (eq xref-name (strcase (vl-filename-base (vla-get-name blkobj))))
		   )
		 
		 (vlax-invoke-method blkobj 'Delete)
               )
             )
           )
	   ; save drawing
	   (vla-saveas odbx (vla-get-name odbx))
         );end progn
       );end if
       (princ "\nDone")
     ); end foreach
    ); end setq folder
    (t (princ "\nComputer says no"))
  ); end cond
  (vl-catch-all-apply 'vlax-release-object (list app))
  (vl-catch-all-apply 'vlax-release-object (list odbx))
  (princ)
)

 

or with some more error checking 

 

(defun c:RlxOdbxDeleteXref (/ _getfolder dbx_ver app dbxv folder xref-name xn err )
  (vl-load-com)
  (defun _getfolder ( m / sh f r )
    (setq sh (vla-getinterfaceobject (vlax-get-acad-object) "Shell.Application") f (vlax-invoke-method sh 'browseforfolder 0 m 0))
    (vlax-release-object sh)(if f (progn (setq r (vlax-get-property (vlax-get-property f 'self) 'path))(if (wcmatch r "*\\") r (strcat r "\\")))))
  (defun dbx_ver ( / v)
    (strcat "objectdbx.axdbdocument" (if (< (setq v (atoi (getvar 'acadver))) 16) "" (strcat "." (itoa v)))))
  (defun void (x) (or (not x) (= "" x) (and (eq 'STR (type x)) (not (vl-remove 32 (vl-string->list x))))))
  (setq app (vlax-get-acad-object) dbxv (dbx_ver))
  
  (cond
    ((void (setq xref-name (getstring "\nEnter name of xref you want to detach : ")))
     (princ "\nComputer says no : invalid xref name"))
    ((vl-catch-all-error-p (setq odbx (vl-catch-all-apply 'vla-getinterfaceobject (list app dbxv))))
     (princ "\nObject DBX interface not created!"))
    ((setq folder (_getfolder (strcat "Select folder with drawings to delete Xrefs" xref-name)))
     (setq xref-name (strcase xref-name))
     (foreach dwg (vl-directory-files folder "*.dwg" 0)
       (setq dwg (strcat folder dwg))
       (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-open (list odbx dwg)))
	 (princ (strcase (strcat "\nError opening: " dwg)))
	 (progn
	   (princ (strcat "\nOpening: " dwg))
	   (vlax-for lt (vla-get-layouts odbx)
	     (vlax-for blkobj (vla-get-block lt)
	       (if (and (eq (vla-get-objectname blkobj) "AcDbBlockReference") (vlax-property-available-p blkobj 'Path)
			(setq xn (strcase (vl-filename-base (vla-get-name blkobj)))))
		 (cond
		   ((not (eq xref-name xn))
		    (princ (strcat "\n*Names not equal " (vl-princ-to-string xref-name) " /= " (vl-princ-to-string xn))))
		   ((setq err (vl-catch-all-error-p (vl-catch-all-apply 'vla-delete (list blkobj))))
		    (princ (strcat "\n*Unable to detach xref " xn " : " (vl-catch-all-error-message err))))
		   (t (princ (strcat "\nSuccesfully detached xref : " xn)))
                 )
               )
	     )
           )
	   ; save drawing
	   (if (setq err (vl-catch-all-error-p (vl-catch-all-apply 'vla-saveas (list odbx (vla-get-name odbx)))))
	     (princ (strcat "\n*Unable to save drawing " (vla-get-name odbx) " : " (vl-catch-all-error-message err)))
	       (princ (strcat "\nSuccesfully saved drawing : " (vla-get-name odbx))))
         );end progn
       );end if
       (princ "\nDone")
     ); end foreach
    ); end setq folder
    (t (princ "\nComputer says no"))
  ); end cond
  (vl-catch-all-apply 'vlax-release-object (list app))
  (vl-catch-all-apply 'vlax-release-object (list odbx))
  (princ)
)

 

Hope these work better. Think the bug is (was) the strcase function. The xref name you typed in was converted upper case and the name of the scanned xref converted to lower case.

 

🐉

Link to comment
Share on other sites

On 11/3/2022 at 8:23 PM, rlx said:
(defun c:RlxOdbxDeleteXref (/ _getfolder dbx_ver app dbxv folder xref-name )
  (vl-load-com)
  (defun _getfolder ( m / sh f r )
    (setq sh (vla-getinterfaceobject (vlax-get-acad-object) "Shell.Application") f (vlax-invoke-method sh 'browseforfolder 0 m 0))
    (vlax-release-object sh)(if f (progn (setq r (vlax-get-property (vlax-get-property f 'self) 'path))(if (wcmatch r "*\\") r (strcat r "\\")))))
  (defun dbx_ver ( / v)
    (strcat "objectdbx.axdbdocument" (if (< (setq v (atoi (getvar 'acadver))) 16) "" (strcat "." (itoa v)))))
  (defun void (x) (or (not x) (= "" x) (and (eq 'STR (type x)) (not (vl-remove 32 (vl-string->list x))))))
  (setq app (vlax-get-acad-object) dbxv (dbx_ver))
  
  (cond
    ((void (setq xref-name (getstring "\nEnter name of xref you want to detach : ")))
     (princ "\nComputer says no : invalid xref name"))
    ((vl-catch-all-error-p (setq odbx (vl-catch-all-apply 'vla-getinterfaceobject (list app dbxv))))
     (princ "\nObject DBX interface not created!"))
    ((setq folder (_getfolder "Select folder with drawings to delete xref"))
     (setq xref-name (strcase xref-name))
     (foreach dwg (vl-directory-files folder "*.dwg" 0)
       (setq dwg (strcat folder dwg))
       (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-open (list odbx dwg)))
	 (princ (strcase (strcat "\nError opening: " dwg)))
	 (progn
	   (princ (strcat "\nOpening: " dwg))
	   (vlax-for lt (vla-get-layouts odbx)
	     (vlax-for blkobj (vla-get-block lt)
	       (if (and
		     (eq (vla-get-objectname blkobj) "AcDbBlockReference")
		     (vlax-property-available-p blkobj 'Path)
		     (eq xref-name (strcase (vl-filename-base (vla-get-name blkobj))))
		   )
		 
		 (vlax-invoke-method blkobj 'Delete)
               )
             )
           )
	   ; save drawing
	   (vla-saveas odbx (vla-get-name odbx))
         );end progn
       );end if
       (princ "\nDone")
     ); end foreach
    ); end setq folder
    (t (princ "\nComputer says no"))
  ); end cond
  (vl-catch-all-apply 'vlax-release-object (list app))
  (vl-catch-all-apply 'vlax-release-object (list odbx))
  (princ)
)

 

or with some more error checking 

 

(defun c:RlxOdbxDeleteXref (/ _getfolder dbx_ver app dbxv folder xref-name xn err )
  (vl-load-com)
  (defun _getfolder ( m / sh f r )
    (setq sh (vla-getinterfaceobject (vlax-get-acad-object) "Shell.Application") f (vlax-invoke-method sh 'browseforfolder 0 m 0))
    (vlax-release-object sh)(if f (progn (setq r (vlax-get-property (vlax-get-property f 'self) 'path))(if (wcmatch r "*\\") r (strcat r "\\")))))
  (defun dbx_ver ( / v)
    (strcat "objectdbx.axdbdocument" (if (< (setq v (atoi (getvar 'acadver))) 16) "" (strcat "." (itoa v)))))
  (defun void (x) (or (not x) (= "" x) (and (eq 'STR (type x)) (not (vl-remove 32 (vl-string->list x))))))
  (setq app (vlax-get-acad-object) dbxv (dbx_ver))
  
  (cond
    ((void (setq xref-name (getstring "\nEnter name of xref you want to detach : ")))
     (princ "\nComputer says no : invalid xref name"))
    ((vl-catch-all-error-p (setq odbx (vl-catch-all-apply 'vla-getinterfaceobject (list app dbxv))))
     (princ "\nObject DBX interface not created!"))
    ((setq folder (_getfolder (strcat "Select folder with drawings to delete Xrefs" xref-name)))
     (setq xref-name (strcase xref-name))
     (foreach dwg (vl-directory-files folder "*.dwg" 0)
       (setq dwg (strcat folder dwg))
       (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-open (list odbx dwg)))
	 (princ (strcase (strcat "\nError opening: " dwg)))
	 (progn
	   (princ (strcat "\nOpening: " dwg))
	   (vlax-for lt (vla-get-layouts odbx)
	     (vlax-for blkobj (vla-get-block lt)
	       (if (and (eq (vla-get-objectname blkobj) "AcDbBlockReference") (vlax-property-available-p blkobj 'Path)
			(setq xn (strcase (vl-filename-base (vla-get-name blkobj)))))
		 (cond
		   ((not (eq xref-name xn))
		    (princ (strcat "\n*Names not equal " (vl-princ-to-string xref-name) " /= " (vl-princ-to-string xn))))
		   ((setq err (vl-catch-all-error-p (vl-catch-all-apply 'vla-delete (list blkobj))))
		    (princ (strcat "\n*Unable to detach xref " xn " : " (vl-catch-all-error-message err))))
		   (t (princ (strcat "\nSuccesfully detached xref : " xn)))
                 )
               )
	     )
           )
	   ; save drawing
	   (if (setq err (vl-catch-all-error-p (vl-catch-all-apply 'vla-saveas (list odbx (vla-get-name odbx)))))
	     (princ (strcat "\n*Unable to save drawing " (vla-get-name odbx) " : " (vl-catch-all-error-message err)))
	       (princ (strcat "\nSuccesfully saved drawing : " (vla-get-name odbx))))
         );end progn
       );end if
       (princ "\nDone")
     ); end foreach
    ); end setq folder
    (t (princ "\nComputer says no"))
  ); end cond
  (vl-catch-all-apply 'vlax-release-object (list app))
  (vl-catch-all-apply 'vlax-release-object (list odbx))
  (princ)
)

 

Hope these work better. Think the bug is (was) the strcase function. The xref name you typed in was converted upper case and the name of the scanned xref converted to lower case.

 

🐉

@rlx thank you so much it's works now.much appreciated your effort for me

Link to comment
Share on other sites

  • 4 months later...

RLX,

I have a question on the way that lisp attach the xref, is there a way to change the option "attach" to "overlay"? and also is possible to select the layer instead to use layer 0? thanks 

Link to comment
Share on other sites

minimal tested

🐉

(defun c:RlxOverlayXref (/ _getfolder app adoc odbs odbx v xref folder dwg xr lay)
  (vl-load-com)
  (defun _getfolder ( m / sh f r )
    (setq sh (vla-getinterfaceobject (vlax-get-acad-object) "Shell.Application") f (vlax-invoke-method sh 'browseforfolder 0 m 0))
    (vlax-release-object sh)(if f (progn (setq r (vlax-get-property (vlax-get-property f 'self) 'path))(if (wcmatch r "*\\") r (strcat r "\\")))))
  ; i is 0 (absolute), 1 (relative) of 2 (no) -xref path
  (defun RLXref_SetPathType (i)
    (vl-registry-write (strcat "HKEY_CURRENT_USER\\" (vlax-product-key) "\\Profiles\\" (getvar "cprofile") "\\Dialogs\\XattachDialog") "PathType" i))
  (setq odbs "ObjectDBX.AxDbDocument" v (substr (getvar 'acadver) 1 2) adoc (vla-get-activedocument (setq app (vlax-get-acad-object))))
  (RLXref_SetPathType 1)
  (cond
    ((vl-catch-all-error-p (setq odbx (vl-catch-all-apply 'vla-getinterfaceobject (list app (if (< (atoi v) 16) odbs (strcat odbs "." v))))))
     (princ "\nObject DBX interface not created!"))
    ((not (setq xref (getfiled "Select Xref to attach" "" "dwg" 0))) (alert "No Xref was selected"))
    ((setq folder (_getfolder "Select folder with drawings to attach xref to"))
     (if (not (setq lay (ask "Enter layer [0]"))) (setq lay "0"))
     (foreach dwg (vl-directory-files folder "*.dwg" 0)
       (setq dwg (strcat folder dwg))
       (if (vl-catch-all-error-p (vl-catch-all-apply 'vla-open (list odbx dwg)))
         (princ (strcase (strcat "\nError opening: " dwg)))
         (progn
           (princ (strcat "\nOpening: " dwg))
           ; overlay xref
           (if (vl-catch-all-error-p (setq xr (vl-catch-all-apply 'vla-AttachExternalReference
                 (list (vla-get-ModelSpace odbx) xref (vl-filename-base xref) (vlax-3d-point 0 0 0) 1 1 1 0 :vlax-true))))
             (princ (vl-catch-all-error-message xr))
             (progn
               (vl-catch-all-apply 'vla-add (list (vla-get-layers odbx) lay))
               (vl-catch-all-apply 'vla-put-layer (list xr lay))
             )
           )
           ; save drawing
           (vla-saveas odbx (vla-get-name odbx))
         )
       )
     )
    );;; end getfolder
    (t (princ "\nAction cancelled"))
  ); end cond
  (princ)
)

; simple dialog for getstring so no switching needed from dialog to command line (ask "How are you?")
(defun ask ( $m / f p d r s) (if (and (setq f (vl-filename-mktemp ".dcl"))(setq p (open f "w")))
  (progn (write-line (strcat "ask :dialog {label =\"" $m "\";:edit_box {key=\"eb\";}spacer;ok_cancel;}") p)(close p)(gc)
    (setq d (load_dialog f))(new_dialog "ask" d) (mapcar '(lambda(x y)(action_tile x y)) '("eb" "accept" "cancel")
      '("(setq s $value)""(done_dialog 1)""(done_dialog 0)"))(setq r (start_dialog))(unload_dialog d)(vl-file-delete f)))
  (if (and (= r 1) (= 'STR (type s)) (/= s "")) s nil)
)

 

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...