Jump to content

Repair Lisp to create superimpose acad

karfung

By karfung
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

karfung Newbie

karfung

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

 

karfung_0-1767502700890.thumb.png.3f23c1e2b064af9ba06b0cd99705e4dd.png

 

Drawing1.dwg

Edited by SLW210
Added Code Tags!!
SLW210 Grand Master

SLW210

Posted
Posted

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

SLW210 Grand Master

SLW210

Posted
Posted

Your video did not work for me.

 

Your LISP ran just fine on my computer.

pkenewell Experienced

pkenewell

Posted
Posted

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

  • Like 1
rlx Grand Master

rlx

Posted
Posted

maybe first do an audit on this drawing

  • Thanks 1
devitg Mentor

devitg

Posted
Posted
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

 

karfung_0-1767502700890.thumb.png.3f23c1e2b064af9ba06b0cd99705e4dd.png

 

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 . 

 

 

  • Like 1
devitg Mentor

devitg

Posted
Posted (edited)
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 by devitg
add text
  • Like 1
rlx Grand Master

rlx

Posted
Posted (edited)

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 by rlx
  • Like 1
  • Thanks 1
SLW210 Grand Master

SLW210

Posted
Posted
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).

  • Like 2
karfung Newbie

karfung

Posted
  • Author
Posted

 

 

@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. 

 

 

karfung Newbie

karfung

Posted
  • Author
Posted

@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 Mentor

devitg

Posted
Posted
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 Grand Master

rlx

Posted
Posted 
;;; 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))

 

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.

×
 Share
Go to topic listing
×
×
  • Create New...