Repair Lisp to create superimpose acad

[karfung]

(defun c:new_desktop_file_copy (/ acad_dbx object_list zero_point)
  (defun make_color_21 (/ layers)
    (setq layers (vla-get-layers acad_dbx))
    (vlax-map-collection (vla-get-blocks acad_dbx)
      '(lambda (block) (vlax-map-collection block '(lambda (object) (vla-put-color object 256)
                                         (if (/= 21 (vla-get-color (setq layer (vla-item layers (vla-get-layer object)))))
                                      (vla-put-color layer 21)
                                    )
                           )
               )
       )
    )
  )
  (setq acad_dbx (vla-getinterfaceobject (vlax-get-acad-object) (strcat "ObjectDBX.AxDbDocument." (substr (getvar 'acadver) 1 2))))
  (prompt "\nPick objects to copy to a new file on the desktop...")
  (setq object_list (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget))))))
  (setq zero_point (getpoint "\nPick zero point for the copied entities: "))
  (foreach copied_object 
      (setq odbx_objects_list
          (vlax-invoke (vla-get-database (vla-get-activedocument (vlax-get-acad-object)))
                        'copyobjects
                         object_list
                         (vla-get-modelspace acad_dbx)
          )
      )
          (vla-move copied_object (vlax-3d-point zero_point) (vlax-3d-point 0 0 0))
  )
  (make_color_21)
  (vla-saveas acad_dbx (princ (strcat (getenv "userprofile") "\\Desktop\\" (getstring "\nEnter file name: ") ".dwg")))
  (vlax-release-object acad_dbx)
  (princ)
)

 

Hi Bro,

The LISP code above is awesome, and it is working. But, I encountered an error below and as per the attached drawing 1 with mp4 video (in link) and added it as follows,

1). Please set the unit to be "mm" in the created file. 

2). Please zoom extend for the created file. 

fyi, I did changed the LISP code to "CP"

 

Kindly advise and revert with the completed Lisp code. 

 

Thanks. 

 

https://drive.google.com/file/d/15VNesdJ3uHtPbUlrNbCsaP0yMzY3e2Po/view?usp=sharing

 

 

Drawing1.dwg

Edited Thursday at 06:19 PM by SLW210
Added Code Tags!!

[SLW210]

In the future, please place your code in code tags. (<> in the editor toolbar)

[SLW210]

Your video did not work for me.

 

Your LISP ran just fine on my computer.

[pkenewell]

Does the LISP file load the Visual LISP ActiveX functions with (vl-load-com)? I don't see it in the code.

[rlx]

maybe first do an audit on this drawing

[devitg]

6 hours ago, karfung said:

(defun c:new_desktop_file_copy (/ acad_dbx object_list zero_point)
  (defun make_color_21 (/ layers)
    (setq layers (vla-get-layers acad_dbx))
    (vlax-map-collection (vla-get-blocks acad_dbx)
      '(lambda (block) (vlax-map-collection block '(lambda (object) (vla-put-color object 256)
                                         (if (/= 21 (vla-get-color (setq layer (vla-item layers (vla-get-layer object)))))
                                      (vla-put-color layer 21)
                                    )
                           )
               )
       )
    )
  )
  (setq acad_dbx (vla-getinterfaceobject (vlax-get-acad-object) (strcat "ObjectDBX.AxDbDocument." (substr (getvar 'acadver) 1 2))))
  (prompt "\nPick objects to copy to a new file on the desktop...")
  (setq object_list (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget))))))
  (setq zero_point (getpoint "\nPick zero point for the copied entities: "))
  (foreach copied_object 
      (setq odbx_objects_list
          (vlax-invoke (vla-get-database (vla-get-activedocument (vlax-get-acad-object)))
                        'copyobjects
                         object_list
                         (vla-get-modelspace acad_dbx)
          )
      )
          (vla-move copied_object (vlax-3d-point zero_point) (vlax-3d-point 0 0 0))
  )
  (make_color_21)
  (vla-saveas acad_dbx (princ (strcat (getenv "userprofile") "\\Desktop\\" (getstring "\nEnter file name: ") ".dwg")))
  (vlax-release-object acad_dbx)
  (princ)
)

 

Hi Bro,

The LISP code above is awesome, and it is working. But, I encountered an error below and as per the attached drawing 1 with mp4 video (in link) and added it as follows,

1). Please set the unit to be "mm" in the created file. 

2). Please zoom extend for the created file. 

fyi, I did changed the LISP code to "CP"

 

Kindly advise and revert with the completed Lisp code. 

 

Thanks. 

 

https://drive.google.com/file/d/15VNesdJ3uHtPbUlrNbCsaP0yMzY3e2Po/view?usp=sharing

 

 

Drawing1.dwg 4.15 MB · 4 downloads

@karfung it seem to be you need to make a new.dwg , if so, you can use WRITEBLOCK acad command . 

 

 

[devitg]

@karfung see the new dwg 

new block.dwg

[devitg]

4 hours ago, SLW210 said:

In the future, please place your code in code tags. (<> in the editor toolbar)

@SLW210 how to select all the code at code tags , like a short key ctrl+a or whatever 

Edited Thursday at 10:58 PM by devitg
add text

[rlx]

somehow a document type object lives along your copied_objects so try this :

 

(defun c:new_desktop_file_copy ( / acad_dbx object_list zero_point db)
  (defun make_color_21 (/ layers)
    (setq layers (vla-get-layers acad_dbx))
    (vlax-map-collection (vla-get-blocks acad_dbx)
      '(lambda (block) (vlax-map-collection block '(lambda (object) (vla-put-color object 256)
          (if (/= 21 (vla-get-color (setq layer (vla-item layers (vla-get-layer object))))) (vla-put-color layer 21))))
       )
    )
  )
  
  (setq acad_dbx (vla-getinterfaceobject (vlax-get-acad-object) (strcat "ObjectDBX.AxDbDocument." (substr (getvar 'acadver) 1 2))))
  (prompt "\nPick objects to copy to a new file on the desktop...")
  (setq object_list (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget))))))
  (setq zero_point (getpoint "\nPick zero point for the copied entities: "))
  (setq db (vla-get-database (vla-get-activedocument (vlax-get-acad-object))))
  
  (foreach copied_object
    (setq odbx_objects_list (vlax-invoke db 'copyobjects object_list (vla-get-modelspace acad_dbx)))
    (if (vlax-method-applicable-p copied_object 'move)
      (vla-move copied_object (vlax-3d-point zero_point) (vlax-3d-point 0 0 0))
      (princ (strcat "\nUnable to move object name : " (vla-get-name copied_object)))
    )
  )
  (make_color_21)
  (vla-saveas acad_dbx (princ (strcat (getenv "userprofile") "\\Desktop\\" (getstring "\nEnter file name: ") ".dwg")))
  (vlax-release-object acad_dbx)
  (princ)
)

 

Edited yesterday at 12:50 AM by rlx

[SLW210]

12 hours ago, devitg said:

@SLW210 how to select all the code at code tags , like a short key ctrl+a or whatever 

 

Select at start of what you need, then shift select the end is fastest I know (you can actually go from end to the beginning as well).

[karfung]

 

 

@rlx Wow, your code is awesome and works very well. Thank bro. 

 

Additionally, could you assist in setting the new file with the condition as follows, 

1). Please set the unit to be "mm" in the created file. 

2). Please zoom extend for the created file. 

 

Kindly advise. Thanks. 

 

 

[devitg]

@karfung, why not to do a Writeblock command, it allow to set units as need, and show zoom extend 

new block.dwg

[karfung]

@devitg 

The file was created automatically by using the Lisp code. The format within the file did not follow to the template.

We shall need the Lisp code to set the created file by automatically. Thanks. 

 

 

 

[devitg]

5 minutes ago, karfung said:

@devitg 

The file was created automatically by using the Lisp code. The format within the file did not follow to the template.

We shall need the Lisp code to set the created file by automatically. Thanks. 

 

 

 

 

some like it 

copy to desktop.dwg copy to desktop.dwg

[rlx]

;;; https://www.cadtutor.net/forum/topic/98937-repair-lisp-to-create-superimpose-acad/

(defun c:new_desktop_file_copy ( / acad_dbx object_list zero_point db odbx_objects_list ss fn db actDocs doc)
  
  (vl-load-com) (setq acad_dbx (vla-getinterfaceobject (vlax-get-acad-object) (dbx_ver)))
  
  (defun make_color_21 ( / lays lay) (setq lays (vla-get-layers acad_dbx))
    (vlax-map-collection (vla-get-blocks acad_dbx)
      '(lambda (b) (vlax-map-collection b '(lambda (o) (vla-put-color o 256)
        (if (/= 21 (vla-get-color (setq l (vla-item lays (vla-get-layer o)))))
          (vla-put-color l 21)))))))
  
  (prompt "\nPick objects to copy to a new file on the desktop...")
  (if (not (setq ss (ssget)))
    (princ "\nNothing was selected")
    (progn
      (setq object_list (ss->ol ss))
      (setq zero_point (getpoint "\nPick zero point for the copied entities: "))
      (setq db (vla-get-database (vla-get-activedocument (vlax-get-acad-object))))
      (setq odbx_objects_list (vlax-invoke db 'copyobjects object_list (vla-get-modelspace acad_dbx)))

      (foreach copied_object odbx_objects_list
        (if (vlax-method-applicable-p copied_object 'move)
          (vla-move copied_object (vlax-3d-point zero_point) (vlax-3d-point 0 0 0))
          (princ (strcat "\nUnable to move object name : " (vla-get-name copied_object)))
        )
      )
      (make_color_21)
      (if (eq (setq fn (getstring "\nEnter file name: ")) "")
        (princ (strcat "\nInvalid filename for new drawing : " (vl-princ-to-string fn)))
        (progn
          (setq fn (strcat (getenv "userprofile") "\\Desktop\\" fn ".dwg"))
          (vla-saveas acad_dbx fn) (vlax-release-object acad_dbx) (gc)
          
          ;;; re-open & reset drawing
          (setq actDocs (vla-get-documents (vlax-get-acad-object)))
          (if (setq doc (vla-open actDocs fn))
            (progn
              (vla-SetVariable doc "LUNITS" 2) (vla-SetVariable doc "LUPREC" 4)
              (vla-zoomextents (vlax-get-acad-object))
              (vla-close doc :vlax-true)
              (vl-catch-all-apply 'vlax-release-object (list doc))
              (vl-catch-all-apply 'vlax-release-object (list actDocs))
            )
            (princ (strcat "\nUnable to open " (vl-princ-to-string fn)))
          )
        )
      )
    )
  )
  (princ)
)

(defun SS->OL (ss / i l)
  (setq i 0)(repeat (sslength ss)(setq l (cons (vlax-ename->vla-object (ssname ss i)) l) i (1+ i))) l)
(defun dbx_ver ( / v)
  (strcat "objectdbx.axdbdocument" (if (< (setq v (atoi (getvar 'acadver))) 16) "" (strcat "." (itoa v)))))

(defun c:t1 nil (c:new_desktop_file_copy))

 

[karfung]

8 hours ago, rlx said:

;;; https://www.cadtutor.net/forum/topic/98937-repair-lisp-to-create-superimpose-acad/

(defun c:new_desktop_file_copy ( / acad_dbx object_list zero_point db odbx_objects_list ss fn db actDocs doc)
  
  (vl-load-com) (setq acad_dbx (vla-getinterfaceobject (vlax-get-acad-object) (dbx_ver)))
  
  (defun make_color_21 ( / lays lay) (setq lays (vla-get-layers acad_dbx))
    (vlax-map-collection (vla-get-blocks acad_dbx)
      '(lambda (b) (vlax-map-collection b '(lambda (o) (vla-put-color o 256)
        (if (/= 21 (vla-get-color (setq l (vla-item lays (vla-get-layer o)))))
          (vla-put-color l 21)))))))
  
  (prompt "\nPick objects to copy to a new file on the desktop...")
  (if (not (setq ss (ssget)))
    (princ "\nNothing was selected")
    (progn
      (setq object_list (ss->ol ss))
      (setq zero_point (getpoint "\nPick zero point for the copied entities: "))
      (setq db (vla-get-database (vla-get-activedocument (vlax-get-acad-object))))
      (setq odbx_objects_list (vlax-invoke db 'copyobjects object_list (vla-get-modelspace acad_dbx)))

      (foreach copied_object odbx_objects_list
        (if (vlax-method-applicable-p copied_object 'move)
          (vla-move copied_object (vlax-3d-point zero_point) (vlax-3d-point 0 0 0))
          (princ (strcat "\nUnable to move object name : " (vla-get-name copied_object)))
        )
      )
      (make_color_21)
      (if (eq (setq fn (getstring "\nEnter file name: ")) "")
        (princ (strcat "\nInvalid filename for new drawing : " (vl-princ-to-string fn)))
        (progn
          (setq fn (strcat (getenv "userprofile") "\\Desktop\\" fn ".dwg"))
          (vla-saveas acad_dbx fn) (vlax-release-object acad_dbx) (gc)
          
          ;;; re-open & reset drawing
          (setq actDocs (vla-get-documents (vlax-get-acad-object)))
          (if (setq doc (vla-open actDocs fn))
            (progn
              (vla-SetVariable doc "LUNITS" 2) (vla-SetVariable doc "LUPREC" 4)
              (vla-zoomextents (vlax-get-acad-object))
              (vla-close doc :vlax-true)
              (vl-catch-all-apply 'vlax-release-object (list doc))
              (vl-catch-all-apply 'vlax-release-object (list actDocs))
            )
            (princ (strcat "\nUnable to open " (vl-princ-to-string fn)))
          )
        )
      )
    )
  )
  (princ)
)

(defun SS->OL (ss / i l)
  (setq i 0)(repeat (sslength ss)(setq l (cons (vlax-ename->vla-object (ssname ss i)) l) i (1+ i))) l)
(defun dbx_ver ( / v)
  (strcat "objectdbx.axdbdocument" (if (< (setq v (atoi (getvar 'acadver))) 16) "" (strcat "." (itoa v)))))

(defun c:t1 nil (c:new_desktop_file_copy))

 

 

@rlx The latest lisp code still cannot comply to the additional condition that I mentioned before. Kindly review again. 

 

The additional condition as follows, 

1). Please set the unit to be "mm" in the created file. 

2). Please zoom extend for the created file. 

3). (New add) At the original file, after picking the specific point for the object, please delete the selected object from the original file. This is to info user that if some of the objects weren't selected in the previous selection, it will not be deleted in this process. 

 

Kindly advise. Your assistance is appreciated. Thanks. 

 

[rlx]

;;; https://www.cadtutor.net/forum/topic/98937-repair-lisp-to-create-superimpose-acad/

(defun c:new_desktop_file_copy ( / acad_dbx object_list zero_point db odbx_objects_list ss fn db actDocs doc)
  
  (vl-load-com) (setq acad_dbx (vla-getinterfaceobject (vlax-get-acad-object) (dbx_ver)))
  
  (defun make_color_21 ( / lays lay) (setq lays (vla-get-layers acad_dbx))
    (vlax-map-collection (vla-get-blocks acad_dbx)
      '(lambda (b) (vlax-map-collection b '(lambda (o) (vla-put-color o 256)
        (if (/= 21 (vla-get-color (setq l (vla-item lays (vla-get-layer o)))))
          (vla-put-color l 21)))))))
  
  (prompt "\nPick objects to copy to a new file on the desktop...")
  (if (not (setq ss (ssget)))
    (princ "\nNothing was selected")
    (progn
      (setq object_list (ss->ol ss))
      (setq zero_point (getpoint "\nPick zero point for the copied entities: "))
      (setq db (vla-get-database (vla-get-activedocument (vlax-get-acad-object))))
      (setq odbx_objects_list (vlax-invoke db 'copyobjects object_list (vla-get-modelspace acad_dbx)))

      (foreach copied_object odbx_objects_list
        (if (vlax-method-applicable-p copied_object 'move)
          (vla-move copied_object (vlax-3d-point zero_point) (vlax-3d-point 0 0 0))
          (princ (strcat "\nUnable to move object name : " (vla-get-name copied_object)))
        )
      )
      (make_color_21)
      (if (eq (setq fn (getstring "\nEnter file name: ")) "")
        (princ (strcat "\nInvalid filename for new drawing : " (vl-princ-to-string fn)))
        (progn
          (setq fn (strcat (getenv "userprofile") "\\Desktop\\" fn ".dwg"))
          (vla-saveas acad_dbx fn) (vlax-release-object acad_dbx) (gc) (gc)
          (foreach obj object_list (vla-delete obj)) (command ".qsave")
          ;|lets go vanilla|;(ScriptDwg fn (list "LUNITS" "2" "LUPREC" "6" ".zoom" "extents"))
        )
      )
    )
  )
  (princ)
)

(defun SS->OL (ss / i l)
  (setq i 0)(repeat (sslength ss)(setq l (cons (vlax-ename->vla-object (ssname ss i)) l) i (1+ i))) l)

(defun dbx_ver ( / v)
  (strcat "objectdbx.axdbdocument" (if (< (setq v (atoi (getvar 'acadver))) 16) "" (strcat "." (itoa v)))))

(defun ScriptDwg ( dwg-fn dwg-com / scr-fn scr-fp )
  (if (= (getvar "SDI") 1) (setvar "SDI" 0)) 
  (setq scr-fn (strcat (getvar 'MYDOCUMENTSPREFIX) "\\ScriptDwg.scr"))
  (cond
    ((or (not (= (type dwg-fn) 'STR)) (not (findfile dwg-fn)))
     (princ (strcat "\n*error* : unable to find drawing : " (vl-princ-to-string dwg-fn))))
    ((not (setq scr-fp (open scr-fn "w")))
     (princ "\n*error* : unable to create script for commands."))
    ((not (vl-consp dwg-com))
     (princ "\n*error* : no commands in script"))
    (t
     (write-line (_open_cmd dwg-fn) scr-fp)
     (mapcar '(lambda (s)(write-line s scr-fp)) dwg-com)
     (write-line (_close_cmd) scr-fp)
    )
  )
  (if scr-fp (progn (close scr-fp)(gc)(command "._script" scr-fn)))
)


(defun _open_cmd ($fn)
  (strcat ".open\n\"" $fn "\"\n(while (= 1 (logand (getvar \"cmdactive\") 1))(command \"Yes\"))"))

(defun _close_cmd ()
  (eval "(if (= (getvar \"writestat\") 1)(command \".qsave\" \".close\"))"))


(defun c:t1 nil (c:new_desktop_file_copy))