Jump to content

Splitting up drawing into seperate files with LISP function?

KLKSMILE

By KLKSMILE
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

  • Replies 116
  • Created
  • Last Reply

Top Posters In This Topic

  • Lee Mac

    59

  • KLKSMILE

    53

  • Biscuits

    3

  • ronjonp

    2

Popular Days

Top Posters In This Topic

Popular Days

ronjonp Grand Master

ronjonp

Posted
Posted
Ahh, didn't know that Ron, thanks mate :)

 

You're welcome :)

KLKSMILE Contributor

KLKSMILE

Posted
  • Author
Posted

Sorry,

 

I didn't realize you had replied

 

Ok - yes, all the borders are the same

Below is a link to a jpg shot of a sample sheet with the TAG stamp

I can email you the CAD file if you want

edhttp://docs.google.com/Doc?id=dgxjkf3j_11f6khkhhg

Thanks!

Lee Mac Grand Master

Lee Mac

Posted
Posted

Ok, this was a bit harder, but give this a shot:

 

;; Drawing Cutter V4, by Lee McDonnell 27.04.2009

(defun c:DwgCut  (/ *error* vlst ovar doc file path ss
                   miPt maPt winLst iSs i Nme fname wBss wLst)
 (vl-load-com)

 (defun *error*  (msg)
   (if ovar (mapcar 'setvar vlst ovar))
   (if (not (member msg '("Function cancelled" "quit / exit abort")))
     (princ (strcat "\nError: " msg))
     (princ "\n<<-- Function Cancelled -->>"))
   (princ))

 (setq vlst '("CLAYER" "OSMODE")
       ovar (mapcar 'getvar vlst))
 (setvar "OSMODE" 0)

 (setq doc  (vla-get-ActiveDocument
              (vlax-get-acad-object)))
 
   (or (tblsearch "LAYER" "DATESTAMP")
     (vla-put-color
       (vla-add
         (vla-get-Layers doc) "DATESTAMP") acYellow))
 
 (setq file (getfiled "Select Location for New Files" (if $def $def "") "dwg" 1))
 (if (not (setq $def file))
   (exit))
 (setq path (vl-filename-directory file))
 (if (setq ss (ssget "X" '((0 . "INSERT") (2 . "BORDER"))))
   (foreach Obj  (mapcar 'vlax-ename->vla-object
                         (mapcar 'cadr (ssnamex ss)))
     (vla-getBoundingBox Obj 'miPt 'maPt)
     (setq winLst (mapcar
                    (function
                      (lambda (x) (vlax-safearray->list x)))
                        (list miPt maPt)))
     (vla-ZoomExtents
       (vlax-get-acad-object))
     (setq iSs (ssget "_C" (car winLst) (cadr winLst)) i 2)
     (foreach ent  (vl-remove-if 'listp
                     (mapcar 'cadr (ssnamex iSs)))
       (if (and (eq "TitleText" (cdr (assoc 8 (entget ent))))
                (member (cdr (assoc 0 (entget ent))) '("TEXT" "MTEXT")))
         (setq Nme (cdr (assoc 1 (entget ent))))))
     (if (member (strcat Nme ".dwg") (vl-directory-files path "*.dwg" 1))
       (progn
         (setq Nme (strcat Nme (chr 40) (itoa i) (chr 41)) i (1+ i))
         (while (member (strcat Nme ".dwg") (vl-directory-files path "*.dwg" 1))
           (setq Nme (strcat
                       (substr Nme 1 (- (strlen Nme) 3)) (chr 40) (itoa i) (chr 41))
                 i   (1+ i)))))
     (setq fname (strcat path "\\" Nme ".dwg"))
     (ssadd (Make_Text (car winLst) (DStamp Nme) (/ pi 2)) iSs)
     (setq wBss (vla-add (vla-get-SelectionSets doc) "wBss")
           wLst (mapcar 'vlax-ename->vla-object
                        (vl-remove-if 'listp
                          (mapcar 'cadr (ssnamex iSs)))))
     (vla-additems wBss (vlax-make-variant
                          (vlax-safearray-fill
                            (vlax-make-safearray
                              vlax-vbobject (cons 0 (1- (length wLst)))) wLst)))
     (vla-wBlock doc fname wBss)
     (vla-delete
       (vla-item
         (vla-get-SelectionSets doc) "wBss")))
   (princ "\n<!> No Borders Found <!>"))
 (mapcar 'setvar vlst ovar)
 (princ))

(defun Make_Text  (pt val rot)
 (entmakex (list '(0 . "TEXT")
                (cons 8 "DATESTAMP")
                (cons 10 pt)
                (cons 40 (getvar "TEXTSIZE"))
                (cons 1 val)
                (cons 50 rot)
                (cons 7 (getvar "TEXTSTYLE"))
                '(71 . 0)
                '(72 . 0)
                '(73 . 1)
                (cons 11 pt))))

(defun DStamp  (DNme / cAP cDate cMon cHrs cMin tStr)
 (setq cAP   "AM"
       cDate (rtos (getvar "CDATE") 2 4)
       cMon  (nth (1- (atoi (substr cDate 5 2)))
                  '("JAN" "FEB" "MAR" "APR" "MAY" "JUN" "JUL" "AUG" "SEP" "OCT" "NOV" "DEC"))
       cHrs  (atoi (substr cDate 10 2))
       cMin  (substr cDate 12 2))
 (cond ((<= 13 cHrs)
        (setq cAP  "PM" cHrs (itoa (- cHrs 12))))
       ((= 12 cHrs)
        (setq cAP  "PM" cHrs (itoa cHrs))))
 (setq tStr (strcat "DRFT: KLK FILE:" DNme "  DATE: " cMon
                    (chr 32) (substr cDate 7 2) ", "
                    (substr cDate 1 4) "  TIME: " cHrs (chr 58) cMin (chr 32) cAP))
 tStr)

KLKSMILE Contributor

KLKSMILE

Posted
  • Author
Posted

It won't load in AutoCAD - I've double checked everything in terms of loading it properly. It says it's not a known command.

KLKSMILE Contributor

KLKSMILE

Posted
  • Author
Posted

ok - it does now :) I don't know why is wasn't at first. :) Sorry :)

Is there any way to double the space between the title block and the TAG? It's supposed to be aroung .16 and it's about.08

 

THANK YOU SO SO SO much!!!

Lee Mac Grand Master

Lee Mac

Posted
Posted

Have you copied EVERYTHING from the code frame, and what command are you typing to invoke it?

Lee Mac Grand Master

Lee Mac

Posted
Posted
ok - it does now :) I don't know why is wasn't at first. :) Sorry :)

 

Ok, no worries :)

 

Is there any way to double the space between the title block and the TAG? It's supposed to be aroung .16 and it's about.08

 

Will give you an adjustment option at the top of the LISP

 

THANK YOU SO SO SO much!!!

 

No probs :)

Lee Mac Grand Master

Lee Mac

Posted
Posted

Ok, alter the variable at the very top of the LISP if necessary :thumbsup:

 

;; Drawing Cutter V4, by Lee McDonnell 27.04.2009

(defun c:DwgCut  (/ *error* vlst ovar tOff doc file path ss
                   miPt maPt winLst iSs i Nme fname wBss wLst)

 [color=Red][b](setq tOff 1.6)  ; <<-- Adjust this if necessary[/b][/color]

 (vl-load-com)

 (defun *error*  (msg)
   (if ovar (mapcar 'setvar vlst ovar))
   (if (not (member msg '("Function cancelled" "quit / exit abort")))
     (princ (strcat "\nError: " msg))
     (princ "\n<<-- Function Cancelled -->>"))
   (princ))

 (setq vlst '("CLAYER" "OSMODE")
       ovar (mapcar 'getvar vlst))
 (setvar "OSMODE" 0)

 (setq doc  (vla-get-ActiveDocument
              (vlax-get-acad-object)))
 
   (or (tblsearch "LAYER" "DATESTAMP")
     (vla-put-color
       (vla-add
         (vla-get-Layers doc) "DATESTAMP") acYellow))
 
 (setq file (getfiled "Select Location for New Files" (if $def $def "") "dwg" 1))
 (if (not (setq $def file))
   (exit))
 (setq path (vl-filename-directory file))
 (if (setq ss (ssget "X" '((0 . "INSERT") (2 . "BORDER"))))
   (foreach Obj  (mapcar 'vlax-ename->vla-object
                         (mapcar 'cadr (ssnamex ss)))
     (vla-getBoundingBox Obj 'miPt 'maPt)
     (setq winLst (mapcar
                    (function
                      (lambda (x) (vlax-safearray->list x)))
                        (list miPt maPt)))
     (vla-ZoomExtents
       (vlax-get-acad-object))
     (setq iSs (ssget "_C" (car winLst) (cadr winLst)) i 2)
     (foreach ent  (vl-remove-if 'listp
                     (mapcar 'cadr (ssnamex iSs)))
       (if (and (eq "TitleText" (cdr (assoc 8 (entget ent))))
                (member (cdr (assoc 0 (entget ent))) '("TEXT" "MTEXT")))
         (setq Nme (cdr (assoc 1 (entget ent))))))
     (if (member (strcat Nme ".dwg") (vl-directory-files path "*.dwg" 1))
       (progn
         (setq Nme (strcat Nme (chr 40) (itoa i) (chr 41)) i (1+ i))
         (while (member (strcat Nme ".dwg") (vl-directory-files path "*.dwg" 1))
           (setq Nme (strcat
                       (substr Nme 1 (- (strlen Nme) 3)) (chr 40) (itoa i) (chr 41))
                 i   (1+ i)))))
     (setq fname (strcat path "\\" Nme ".dwg"))
     (ssadd (Make_Text (polar (car winLst) pi (- tOff 0.86)) (DStamp Nme) (/ pi 2)) iSs)
     (setq wBss (vla-add (vla-get-SelectionSets doc) "wBss")
           wLst (mapcar 'vlax-ename->vla-object
                        (vl-remove-if 'listp
                          (mapcar 'cadr (ssnamex iSs)))))
     (vla-additems wBss (vlax-make-variant
                          (vlax-safearray-fill
                            (vlax-make-safearray
                              vlax-vbobject (cons 0 (1- (length wLst)))) wLst)))
     (vla-wBlock doc fname wBss)
     (vla-delete
       (vla-item
         (vla-get-SelectionSets doc) "wBss")))
   (princ "\n<!> No Borders Found <!>"))
 (mapcar 'setvar vlst ovar)
 (princ))

(defun Make_Text  (pt val rot)
 (entmakex (list '(0 . "TEXT")
                (cons 8 "DATESTAMP")
                (cons 10 pt)
                (cons 40 (getvar "TEXTSIZE"))
                (cons 1 val)
                (cons 50 rot)
                (cons 7 (getvar "TEXTSTYLE"))
                '(71 . 0)
                '(72 . 0)
                '(73 . 1)
                (cons 11 pt))))

(defun DStamp  (DNme / cAP cDate cMon cHrs cMin tStr)
 (setq cAP   "AM"
       cDate (rtos (getvar "CDATE") 2 4)
       cMon  (nth (1- (atoi (substr cDate 5 2)))
                  '("JAN" "FEB" "MAR" "APR" "MAY" "JUN" "JUL" "AUG" "SEP" "OCT" "NOV" "DEC"))
       cHrs  (atoi (substr cDate 10 2))
       cMin  (substr cDate 12 2))
 (cond ((<= 13 cHrs)
        (setq cAP  "PM" cHrs (itoa (- cHrs 12))))
       ((= 12 cHrs)
        (setq cAP  "PM" cHrs (itoa cHrs))))
 (setq tStr (strcat "DRFT: KLK FILE:" DNme "  DATE: " cMon
                    (chr 32) (substr cDate 7 2) ", "
                    (substr cDate 1 4) "  TIME: " cHrs (chr 58) cMin (chr 32) cAP))
 tStr)

KLKSMILE Contributor

KLKSMILE

Posted
  • Author
Posted

It works perfect now - thank you so much again! :)

Lee Mac Grand Master

Lee Mac

Posted
Posted

I'm glad it will save you some time :D

 

If you need anything else, just ask :)

KLKSMILE Contributor

KLKSMILE

Posted
  • Author
Posted

So it seems that every time I run the LISP pgm on the multiple sheet file, it TAGs it properly, but if I've already ran it once, it doesn't replace the 1st TAG, it adds another TAG on top of the 1st one.

Also, the original TAG lisp used the line:

(command "zoom" "e")

is there any way I can put this back into the code so it zooms in on the split file before it saves it? That way you can see the whole drawing in the preview window.

Lee Mac Grand Master

Lee Mac

Posted
Posted

When I'm WBlocking, I can't access the WBlock'ed drawing file to make changes on it - which is why I had to add the Date-Tag in the main drawing and not the WBlock'ed one.

 

But as for replacing the datestamp - this can be done :)

Lee Mac Grand Master

Lee Mac

Posted
Posted

Try this:

 

;; Drawing Cutter V4, by Lee McDonnell 27.04.2009

(defun c:DwgCut  (/ *error* vlst ovar tOff doc file path ss dSs
                   miPt maPt winLst iSs i Nme fname wBss wLst)

 (setq tOff 1.6)  ; <<-- Adjust this if necessary

 (vl-load-com)

 (defun *error*  (msg)
   (if ovar (mapcar 'setvar vlst ovar))
   (if (not (member msg '("Function cancelled" "quit / exit abort")))
     (princ (strcat "\nError: " msg))
     (princ "\n<<-- Function Cancelled -->>"))
   (princ))

 (setq vlst '("CLAYER" "OSMODE")
       ovar (mapcar 'getvar vlst))
 (setvar "OSMODE" 0)

 (setq doc  (vla-get-ActiveDocument
              (vlax-get-acad-object)))
 
   (or (tblsearch "LAYER" "DATESTAMP")
     (vla-put-color
       (vla-add
         (vla-get-Layers doc) "DATESTAMP") acYellow))
 
 (setq file (getfiled "Select Location for New Files" (if $def $def "") "dwg" 1))
 (if (not (setq $def file))
   (exit))
 (setq path (vl-filename-directory file))
 (if (setq ss (ssget "X" '((0 . "INSERT") (2 . "BORDER"))))
   (foreach Obj  (mapcar 'vlax-ename->vla-object
                         (mapcar 'cadr (ssnamex ss)))
     (vla-getBoundingBox Obj 'miPt 'maPt)
     (setq winLst (mapcar
                    (function
                      (lambda (x) (vlax-safearray->list x)))
                        (list miPt maPt)))
     (vla-ZoomExtents
       (vlax-get-acad-object))
     (setq iSs (ssget "_C" (car winLst) (cadr winLst)) i 2)
     (foreach ent  (vl-remove-if 'listp
                     (mapcar 'cadr (ssnamex iSs)))
       (if (and (eq "TitleText" (cdr (assoc 8 (entget ent))))
                (member (cdr (assoc 0 (entget ent))) '("TEXT" "MTEXT")))
         (setq Nme (cdr (assoc 1 (entget ent))))))
     (if (member (strcat Nme ".dwg") (vl-directory-files path "*.dwg" 1))
       (progn
         (setq Nme (strcat Nme (chr 40) (itoa i) (chr 41)) i (1+ i))
         (while (member (strcat Nme ".dwg") (vl-directory-files path "*.dwg" 1))
           (setq Nme (strcat
                       (substr Nme 1 (- (strlen Nme) 3)) (chr 40) (itoa i) (chr 41))
                 i   (1+ i)))))
     (setq fname (strcat path "\\" Nme ".dwg"))
     (if (setq dSs (ssget "X" '((0 . "*TEXT") (8 . "DATESTAMP"))))
       (mapcar 'entdel (mapcar 'cadr (ssnamex dSs))))
     (ssadd (Make_Text (polar (car winLst) pi (- tOff 0.86)) (DStamp Nme) (/ pi 2)) iSs)
     (setq wBss (vla-add (vla-get-SelectionSets doc) "wBss")
           wLst (mapcar 'vlax-ename->vla-object
                        (vl-remove-if 'listp
                          (mapcar 'cadr (ssnamex iSs)))))
     (vla-additems wBss (vlax-make-variant
                          (vlax-safearray-fill
                            (vlax-make-safearray
                              vlax-vbobject (cons 0 (1- (length wLst)))) wLst)))
     (vla-wBlock doc fname wBss)
     (vla-delete
       (vla-item
         (vla-get-SelectionSets doc) "wBss")))
   (princ "\n<!> No Borders Found <!>"))
 (mapcar 'setvar vlst ovar)
 (princ))

(defun Make_Text  (pt val rot)
 (entmakex (list '(0 . "TEXT")
                (cons 8 "DATESTAMP")
                (cons 10 pt)
                (cons 40 (getvar "TEXTSIZE"))
                (cons 1 val)
                (cons 50 rot)
                (cons 7 (getvar "TEXTSTYLE"))
                '(71 . 0)
                '(72 . 0)
                '(73 . 1)
                (cons 11 pt))))

(defun DStamp  (DNme / cAP cDate cMon cHrs cMin tStr)
 (setq cAP   "AM"
       cDate (rtos (getvar "CDATE") 2 4)
       cMon  (nth (1- (atoi (substr cDate 5 2)))
                  '("JAN" "FEB" "MAR" "APR" "MAY" "JUN" "JUL" "AUG" "SEP" "OCT" "NOV" "DEC"))
       cHrs  (atoi (substr cDate 10 2))
       cMin  (substr cDate 12 2))
 (cond ((<= 13 cHrs)
        (setq cAP  "PM" cHrs (itoa (- cHrs 12))))
       ((= 12 cHrs)
        (setq cAP  "PM" cHrs (itoa cHrs))))
 (setq tStr (strcat "DRFT: KLK FILE:" DNme "  DATE: " cMon
                    (chr 32) (substr cDate 7 2) ", "
                    (substr cDate 1 4) "  TIME: " cHrs (chr 58) cMin (chr 32) cAP))
 tStr)

KLKSMILE Contributor

KLKSMILE

Posted
  • Author
Posted

SWEET - that works ... only other thing is the zoom extents command

Lee Mac Grand Master

Lee Mac

Posted
Posted
SWEET - that works ... only other thing is the zoom extents command

 

 

Yes, but see my ealier post ^^

Lee Mac Grand Master

Lee Mac

Posted
Posted
When I'm WBlocking, I can't access the WBlock'ed drawing file to make changes on it - which is why I had to add the Date-Tag in the main drawing and not the WBlock'ed one.

 

See this post ^^

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