Jump to content
Ish

REQUIRE LISP FOR DRAW BLOCK AT MID POINT OF PLINE

Recommended Posts

Ish

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

 

SEE IMAGE 

 

THANKS

Capture69.JPG

Share this post


Link to post
Share on other sites
dlanorh
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

Share this post


Link to post
Share on other sites
Ish

Thanks

dlanorh

 

it is working perfectly  for me.

 

Share this post


Link to post
Share on other sites
Ish

i need another lisp also,

see image.

 

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

 

 

leader.JPG

Share this post


Link to post
Share on other sites
dlanorh

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

Share this post


Link to post
Share on other sites
Ish
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

Share this post


Link to post
Share on other sites
dlanorh
(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

Share this post


Link to post
Share on other sites
Ish

Thanks

dlanorh

Rising Star

Share this post


Link to post
Share on other sites
notredave

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

Share this post


Link to post
Share on other sites
dlanorh
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

Share this post


Link to post
Share on other sites
notredave

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

Share this post


Link to post
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
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

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