Jump to content

REQUIRE LISP FOR DRAW BLOCK AT MID POINT OF PLINE

Ish

By Ish
in AutoLISP, Visual LISP & DCL

 Share

Recommended Posts

Ish Community Regular

Ish

Posted
Posted

REQUIRE LISP FOR DRAW BLOCK AT MID POINT OF PLINE WITH SAME ROTATION AS PLINE.

 

SEE IMAGE 

 

THANKS

Capture69.JPG

dlanorh Mentor

dlanorh

Posted
Posted (edited)

Attached is block to insert. The drawing is not a block but contains a block. Insert the drawing as a block and explode and you will be left with the block.

 

The lisp below will handle LINE's and LWPOLYLINE's

 

Lisp :

  

(vl-load-com)

(defun c:bm ( / *error* c_doc c_spc sv_lst sv_vals ent gr xt)
  
  (defun *error* ( msg )
	(mapcar 'setvar sv_lst sv_vals)
	(if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
	(if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nOops an Error : " msg " occurred.")))
	(princ)
  );end_*error*_defun
	
  (setq c_doc (vla-get-activedocument (vlax-get-acad-object))
        c_spc (vlax-get-property c_doc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
        sv_lst (list 'osmode 'cmdecho)
        sv_vals (mapcar 'getvar sv_lst)
        blk "ARBLOCK"                   ;;BLOCK NAME TO INSERT
        sca 1                           ;;BLOCK SCALE  
  );end_setq
  
  (mapcar 'setvar sv_lst '(0 0))
  
  (prompt "\nSelect Lines : ")
  (setq ss (ssget '((0 . "LINE,LWPOLYLINE"))))
  (cond (ss
          (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
          (vla-startundomark c_doc)
          (repeat (setq cnt (sslength ss))
            (setq ent (ssname ss (setq cnt (1- cnt)))
                  m_dst (/ (vlax-curve-getdistatparam ent (vlax-curve-getendparam ent)) 2)
                  m_pt (vlax-curve-getpointatdist ent m_dst)
                  r_ang (angle '(0.0 0.0 0.0) (vlax-curve-getfirstderiv ent (vlax-curve-getparamatpoint ent m_pt)))
                  n_obj (vla-insertblock c_spc (vlax-3d-point m_pt) blk sca sca sca r_ang)
            );end_setq
          );end_repeat
          (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
        )
  );end_cond
  (mapcar 'setvar sv_lst sv_vals)
  (princ)
);end_defun

 

block.dwg

Edited by dlanorh
tidied code
Ish Community Regular

Ish

Posted
  • Author
Posted

i need another lisp also,

see image.

 

require leader with easting , northing of points object , circle center, polyline end and start.

 

 

leader.JPG

dlanorh Mentor

dlanorh

Posted
Posted

Try the attached. It inserts the leader/text as a mleader in the current mleader style. This must be set up correctly for your desired text size, since I don't know what this is.

  

(defun rh:sammlung_n (o_lst grp / tmp n_lst)
  (setq n_lst nil)
  (cond ( (and o_lst (= (rem (length o_lst) grp) 0))
          (while o_lst
            (repeat grp (setq tmp (cons (car o_lst) tmp) o_lst (cdr o_lst)))
            (setq n_lst (cons (reverse tmp) n_lst) tmp nil)
          );end_while
        )  
        ( (/= (rem (length o_lst) grp) 0) (princ "\nModulus Error : The passed list length is not exactly divisible by the group size!!"))
  );end_cond
  (if n_lst (reverse n_lst))
);end_defun

(vl-load-com)

(defun rh:223 (lst / a) (setq a (mapcar '(lambda (x) (reverse (cons 0.0 (reverse x)))) lst)))

;;Object ID
(defun c:oid ( / *error* c_doc c_spc sv_lst sv_vals level p0 p1)
  (defun *error* ( msg )
	(mapcar 'setvar sv_lst sv_vals)
	(if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
	(if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nOops an Error : " msg " occurred.")))
	(princ)
  );end_*error*_defun
	
  (setq c_doc (vla-get-activedocument (vlax-get-acad-object))
        c_spc (vlax-get-property c_doc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
    	sv_lst (list 'osmode 'cmdecho)
    	sv_vals (mapcar 'getvar sv_lst)
  );end_setq
  
  (mapcar 'setvar sv_lst '(0 0))
  
  (setq ss (ssget '((0 . "POINT,CIRCLE,LINE,LWPOLYLINE"))))
  (cond (ss          
          (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
          (vla-startundomark c_doc)
          
          (repeat (setq cnt (sslength ss))
            (setq obj (vlax-ename->vla-object (ssname ss (setq cnt (1- cnt)))))
            (cond ( (= (vlax-get-property obj 'objectname) "AcDbLine") (setq i_pts (mapcar '(lambda (x) (vlax-get obj x)) (list "startpoint" "endpoint"))))
                  ( (= (vlax-get-property obj 'objectname) "AcDbCircle") (setq i_pts (rh:sammlung_n (vlax-get obj 'center) 3)))
                  ( (= (vlax-get-property obj 'objectname) "AcDbPoint") (setq i_pts (rh:sammlung_n (vlax-get obj 'coordinates) 3)))
                  (t (setq i_pts (rh:223 (rh:sammlung_n (vlax-get obj 'coordinates) 2))))
            );end_cond
            (foreach pt i_pts
              (setq pt2 (mapcar '+ pt '(1.0 1.0 0.0))
                    txt (strcat "E=" (rtos (car pt) 2 4) "\\P" "N=" (rtos (cadr pt) 2 4))
                    ml_obj (vlax-invoke c_spc 'addmleader (append pt pt2) 0)
              );end_setq
              (vlax-put-property ml_obj 'textstring txt)              
              (vlax-put-property ml_obj 'textleftattachmenttype 7)
              (vlax-put-property ml_obj 'textrightattachmenttype 7)
            );end_foreach
          );end_repeat
          (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
        )
  );end_cond
  (mapcar 'setvar sv_lst sv_vals)
  (princ)
);end_defun

 

  • Like 1
  • 2 weeks later...
Ish Community Regular

Ish

Posted
  • Author
Posted
On 6/23/2019 at 9:48 PM, dlanorh said:

Try the attached. It inserts the leader/text as a mleader in the current mleader style. This must be set up correctly for your desired text size, since I don't know what this is.

  


(defun rh:sammlung_n (o_lst grp / tmp n_lst)
  (setq n_lst nil)
  (cond ( (and o_lst (= (rem (length o_lst) grp) 0))
          (while o_lst
            (repeat grp (setq tmp (cons (car o_lst) tmp) o_lst (cdr o_lst)))
            (setq n_lst (cons (reverse tmp) n_lst) tmp nil)
          );end_while
        )  
        ( (/= (rem (length o_lst) grp) 0) (princ "\nModulus Error : The passed list length is not exactly divisible by the group size!!"))
  );end_cond
  (if n_lst (reverse n_lst))
);end_defun

(vl-load-com)

(defun rh:223 (lst / a) (setq a (mapcar '(lambda (x) (reverse (cons 0.0 (reverse x)))) lst)))

;;Object ID
(defun c:oid ( / *error* c_doc c_spc sv_lst sv_vals level p0 p1)
  (defun *error* ( msg )
	(mapcar 'setvar sv_lst sv_vals)
	(if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
	(if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nOops an Error : " msg " occurred.")))
	(princ)
  );end_*error*_defun
	
  (setq c_doc (vla-get-activedocument (vlax-get-acad-object))
        c_spc (vlax-get-property c_doc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
    	sv_lst (list 'osmode 'cmdecho)
    	sv_vals (mapcar 'getvar sv_lst)
  );end_setq
  
  (mapcar 'setvar sv_lst '(0 0))
  
  (setq ss (ssget '((0 . "POINT,CIRCLE,LINE,LWPOLYLINE"))))
  (cond (ss          
          (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
          (vla-startundomark c_doc)
          
          (repeat (setq cnt (sslength ss))
            (setq obj (vlax-ename->vla-object (ssname ss (setq cnt (1- cnt)))))
            (cond ( (= (vlax-get-property obj 'objectname) "AcDbLine") (setq i_pts (mapcar '(lambda (x) (vlax-get obj x)) (list "startpoint" "endpoint"))))
                  ( (= (vlax-get-property obj 'objectname) "AcDbCircle") (setq i_pts (rh:sammlung_n (vlax-get obj 'center) 3)))
                  ( (= (vlax-get-property obj 'objectname) "AcDbPoint") (setq i_pts (rh:sammlung_n (vlax-get obj 'coordinates) 3)))
                  (t (setq i_pts (rh:223 (rh:sammlung_n (vlax-get obj 'coordinates) 2))))
            );end_cond
            (foreach pt i_pts
              (setq pt2 (mapcar '+ pt '(1.0 1.0 0.0))
                    txt (strcat "E=" (rtos (car pt) 2 4) "\\P" "N=" (rtos (cadr pt) 2 4))
                    ml_obj (vlax-invoke c_spc 'addmleader (append pt pt2) 0)
              );end_setq
              (vlax-put-property ml_obj 'textstring txt)              
              (vlax-put-property ml_obj 'textleftattachmenttype 7)
              (vlax-put-property ml_obj 'textrightattachmenttype 7)
            );end_foreach
          );end_repeat
          (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
        )
  );end_cond
  (mapcar 'setvar sv_lst sv_vals)
  (princ)
);end_defun

 

THNAKS  A LOT, 

WORKING NICELY,

JUST PLZ ADD A SMALL CODE FOR LAYER,

ALL LEADER AND TEST MUST COME IN LAYER AUTOMATICALLY.

LAYER NAME: LABEL

dlanorh Mentor

dlanorh

Posted
Posted 
(defun rh:sammlung_n (o_lst grp / tmp n_lst)
  (setq n_lst nil)
  (cond ( (and o_lst (= (rem (length o_lst) grp) 0))
          (while o_lst
            (repeat grp (setq tmp (cons (car o_lst) tmp) o_lst (cdr o_lst)))
            (setq n_lst (cons (reverse tmp) n_lst) tmp nil)
          );end_while
        )  
        ( (/= (rem (length o_lst) grp) 0) (princ "\nModulus Error : The passed list length is not exactly divisible by the group size!!"))
  );end_cond
  (if n_lst (reverse n_lst))
);end_defun

(vl-load-com)

(defun rh:223 (lst z / a) (setq a (mapcar '(lambda (x) (reverse (cons z (reverse x)))) lst)))

;;Object ID
(defun c:oid ( / *error* c_doc c_spc sv_lst sv_vals level p0 p1)
  (defun *error* ( msg )
    (mapcar 'setvar sv_lst sv_vals)
    (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
    (if (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")) (princ (strcat "\nOops an Error : " msg " occurred.")))
    (princ)
  );end_*error*_defun
  
  (setq c_doc (vla-get-activedocument (vlax-get-acad-object))
        c_spc (vlax-get-property c_doc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
        sv_lst (list 'osmode 'cmdecho)
        sv_vals (mapcar 'getvar sv_lst)
  );end_setq
  
  (mapcar 'setvar sv_lst '(0 0))
  
  (cond ( (null (tblsearch "LAYER" "LABEL")) (vlax-put (vla-add (vla-get-layers c_doc) "LABEL") 'color 7)))

  (setq ss (ssget '((0 . "POINT,CIRCLE,LINE,LWPOLYLINE"))))
  (cond (ss          
          (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
          (vla-startundomark c_doc)
          
          (repeat (setq cnt (sslength ss))
            (setq obj (vlax-ename->vla-object (ssname ss (setq cnt (1- cnt)))))
            (cond ( (= (vlax-get-property obj 'objectname) "AcDbLine") (setq i_pts (mapcar '(lambda (x) (vlax-get obj x)) (list "startpoint" "endpoint"))))
                  ( (= (vlax-get-property obj 'objectname) "AcDbCircle") (setq i_pts (rh:sammlung_n (vlax-get obj 'center) 3)))
                  ( (= (vlax-get-property obj 'objectname) "AcDbPoint") (setq i_pts (rh:sammlung_n (vlax-get obj 'coordinates) 3)))
                  (t (setq i_pts (rh:223 (rh:sammlung_n (vlax-get obj 'coordinates) 2) 0.0)))
            );end_cond
            (foreach pt i_pts
              (setq pt2 (mapcar '+ pt '(1.0 1.0 0.0))
                    txt (strcat "E=" (rtos (car pt) 2 4) "\\P" "N=" (rtos (cadr pt) 2 4))
                    ml_obj (vlax-invoke c_spc 'addmleader (append pt pt2) 0)
              );end_setq
              (mapcar '(lambda (x y) (vlax-put-property ml_obj x y)) (list 'textstring 'layer 'textleftattachmenttype 'textrightattachmenttype) (list txt "LABEL" 7 7))
            );end_foreach
          );end_repeat
          (if (and c_doc (= 8 (logand 8 (getvar 'UNDOCTL)))) (vla-endundomark c_doc))
        )
  );end_cond
  (mapcar 'setvar sv_lst sv_vals)
  (princ)
);end_defun

 

  • Like 1
notredave Collaborator

notredave

Posted
Posted

dlanorh,

 

Good morning. I tried your bm.lsp which inserts a block aligned to line or pline but I get Oops an Error : Automation error. File error occured. I have placed my drawing in my search path lisp directory and edited lisp with my blocks name but it didn't work. If you get time, can you tell me what I'm doing wrong.

 

Thank you,

David

dlanorh Mentor

dlanorh

Posted
Posted (edited)
2 hours ago, notredave said:

dlanorh,

 

Good morning. I tried your bm.lsp which inserts a block aligned to line or pline but I get Oops an Error : Automation error. File error occured. I have placed my drawing in my search path lisp directory and edited lisp with my blocks name but it didn't work. If you get time, can you tell me what I'm doing wrong.

 

Thank you,

David

 

I can reproduce the error when the required block ("ARBLOCK") is not in the drawing.

 

Has the block attached to post 2 been loaded into the drawing? (Read first line of post 2) The block must be present in the drawing, It is not loaded by the lisp. If you want to reconfigure the look of the block or use another block; then use the block in the attached drawing as a guide to orientation.

 

Alternatively you could import the block using Lee Mac's Steal lisp Here  IMHO a must have lisp.

 

If you want to rename the block change the appropriate variable (blk) and change the blocks scale by altering variable sca

  

  (setq c_doc (vla-get-activedocument (vlax-get-acad-object))
        c_spc (vlax-get-property c_doc (if (= 1 (getvar 'cvport)) 'paperspace 'modelspace))
        sv_lst (list 'osmode 'cmdecho)
        sv_vals (mapcar 'getvar sv_lst)
        blk "ARBLOCK"                   ;;BLOCK NAME TO INSERT
        sca 1                           ;;BLOCK SCALE  
  );end_setq

 

Edited by dlanorh
Altered code
notredave Collaborator

notredave

Posted
Posted

dlanorh, that did the trick by having block in drawing before executing. Thank you very much for your time and efforts. I appreciate it.

 

David

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