Help me write this lisp like this photo! thanks

December 14, 2013

I have two similar procedures，There are differences with the picture，Someone help me changed it！thank you!

Lead endpoint with arrows

X,Y Values must have Plus or minus

thanks !!!

bzx.lsp

BZ.LSP

Edited December 14, 2013 by flyfox1047

December 14, 2013

Someone help me change it？ thanks very much!

December 14, 2013

flyfox1047,

For bz.lsp just add the following to get your plus sign (if (minusp (car p1)) "" "+" )

ymg

Revised code below:

(VL-LOAD-COM)
(or copy_reactor
   (setq copy_reactor (vlr-command-reactor "copy_reactor" '((:vlr-commandEnded . copy_1))))
)
(setvar "copymode" 1)
(defun C:bz (/ p1 p2 pt1 pt2 pts mSpace Mtextobj)
 (setq mSpace (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object))))
 (setq p1 (getpoint "\nÑ¡ÔñÒª±ê×¢µÄµã:"))
 (setq p2 (getpoint p1 "\nÑ¡Ôñ±ê×¢ÎÄ×ÖÎ»ÖÃ:"))
 (setq pt2 (vlax-3D-point p2))
 (setq Mtextobj (vla-addMtext
                  mSpace
                  pt2
                  0.0
                  (strcat "X=" [color="red"](if (minusp (car p1)) "" "+" )[/color](rtos (car p1) 2 1) "\nY=" [color="red"](if (minusp (cadr p1)) "" "+" )[/color](rtos (cadr p1) 2 1))
                )
 )
 (setq MtextH (* (getvar "DIMSCALE") (getvar "DIMTXT"))) ;ÎÄ×Ö¸ß¶ÈÎªµ±Ç°±êÖùÑùÊ½ÎÄ×Ö¸ß¶È*È«¾Ö±ÈÀý
 (vlax-put-property Mtextobj 'Height MtextH)
 (vlax-put-property Mtextobj 'LineSpacingDistance (+ MtextH 1))
 (if (> (car p1) (car p2))
   (vlax-put-property Mtextobj 'AttachmentPoint 9)
   (vlax-put-property Mtextobj 'AttachmentPoint 7)
 )
 (vlax-put-property Mtextobj 'InsertionPoint pt2)
 (setq pts (vlax-make-safearray vlax-vbDouble '(0 . 5)))
 (vlax-safearray-fill
   pts
   (list (car p1) (cadr p1) (caddr p1) (car p2) (cadr p2) (caddr p2))
 )
 (setq leaderobj (vla-Addleader mSpace pts Mtextobj acLineWithArrow))
 (setq vlr-objgx (vlr-object-reactor (list leaderobj) "" '((:vlr-modified . gx))))
 (setq vlr-objcopy (vlr-object-reactor (list leaderobj) "" '((:vlr-copied . copy_2))))
 (princ)
)

(defun copy_2 (obj vlrobj data)
 (if (/= (car data) 0)
   (setq newename (car data))
 )
)

(defun copy_1 (vlrobj data)
 (if (wcmatch (strcase (car data)) "*COPY*")
   (progn (setq newobj (vlax-ename->vla-object newename))
          (setq vlr-objgx (vlr-object-reactor (list newobj) "" '((:vlr-modified . gx))))
          (setq vlr-objcopy (vlr-object-reactor (list newobj) "" '((:vlr-copied . copy_2))))
          (princ)
   )
 )
)

(defun gx (obj vlrobj data / p1 pt1 Aobj)
 (if (and (not (vlax-erased-p obj)) (setq Aobj (vlax-get-property obj 'Annotation))) ;ÅÐ¶Ï¶ÔÏóÊÇ·ñ±»É¾³ý
   (progn (setq pt1 (vlax-get-property obj 'Coordinate 0))
          (setq p1 (vlax-safearray->list (vlax-variant-value pt1)))
          (vlax-put-property
            Aobj
            'TextString
            (strcat "X=" [color="red"](if (minusp (car p1)) "" "+" )[/color](rtos (car p1) 2 1) "\nY=" [color="red"](if (minusp (car p1))[/color] "" "+" )(rtos (cadr p1) 2 1))
          )
   )
 )
)

December 14, 2013

Hi ymg3 ,Thank you for help me ,appload -Always show: no function definition: COPY_1 , now I use autocad 2007

December 14, 2013

Here's the second one modified for the plus sign.

Now, for the life of me, why would you use such antiquated routine.

This one is actually drawing a line and an a cross to somewhat imitated

a leader.

This is what you should be using "LEADER" for that task.

ymg

(defun C:bz (/ AcadObject AcadDocument mSpace h1 len inp kflag obj1 p1 p2 x y anglel inpx inpy lasp olay tx ty)
 (princ "\n×ø±ê±ê×¢V1.10£¬Ö´ÐÐÃüÁî£ºbz")
 (setq olay (getvar "clayer"))
 (setvar "cmdecho" 0)
;;;  ÉèÖÃActiveXµÄ¹¤×÷»·¾³‰äÁ¿
 (VL-LOAD-COM)
 (setq AcadObject   (vlax-get-acad-object)
       AcadDocument (vla-get-ActiveDocument Acadobject)
       mSpace       (vla-get-ModelSpace Acaddocument)
 )
 (setvar "cmdecho" 0)
 (setq kflag t)
 (while kflag
   (chklay)
   (initget "S")
   (if (not h)
     (setq h '1.5)
   )
   (setq
     p (getpoint (strcat "\nÖ¸¶¨Æðµã/¡¾S¡¿ÉèÖÃ×Ö¸ß[<" (rtos h) ">]"))
   )
   (if (= p "S")
     (setq h1 (getreal (strcat "\nÊäÈëÐÂ×Ö¸ß<" (rtos h) ">")))
   )
   (if h1
     (setq h h1)
   )
   (if (and (/= p "S") p)
     (progn
       (drawcross p) ;ÔÚ´æÔÚpµÄÇé¿öÏÂ»*Ê®×Ö¹â±ê
       (prompt "\nÖ¸¶¨ÏÂÒ»µã£º")
       (command "line" p (getdist p) "")
       (setq obj1 (vlax-ename->vla-object (entlast)))
       (if (= (vlax-get-property obj1 'objectname) "AcDbLine")
         (progn
           (setq p1 (vlax-get obj1 'startpoint))
           (setq p2 (vlax-get obj1 'endpoint))
           (setq x (strcat "X=" (if (minusp (car p1)) "" "+" ) (rtos (car p1) 2 3)))
           (setq y (strcat "Y=" (if (minusp (cadr p1)) "" "+" ) (rtos (cadr p1) 2 3)))
           (setq len (max (strlen x) (strlen y)))
           (setq anglel (vlax-get obj1 'Angle))
           (if (and (> anglel (/ pi 2)) (< anglel (/ (* pi 1.5))))
             ;;ÔÚµÚ¶þ¡¢ÈýÏóÏÞ±ê×¢
             (progn
               (setq lasp (polar p2 (angtof "180") (* (* 0.6 h) len)))
               (setq inp (polar lasp '0 (* 0.2 h)))
               (setq inpx (polar inp (angtof "90") (* 0.2 h)))
               (setq inpy (polar inp (angtof "270") (* 1.1 h)))
               (vla-AddLine mSpace (vlax-3d-point p2) (vlax-3d-point lasp))
               (setq tx (vla-AddText mSpace x (vlax-3d-point inpx) h))
               (setq ty (vla-AddText mSpace y (vlax-3d-point inpy) h))
             ) ;progn
             ;;ÔÚµÚÒ»¡¢ËÄÏóÏÞ±ê×¢
             (progn
               (setq lasp (polar p2 '0 (* (* 0.7 h) len)))
               (setq inp (polar p2 '0 (* 0.3 h)))
               (setq inpx (polar inp (angtof "90") (* 0.2 h)))
               (setq inpy (polar inp (angtof "270") (* 1.1 h)))
               (vla-AddLine mSpace (vlax-3d-point p2) (vlax-3d-point lasp))
               (vla-AddText mSpace x (vlax-3d-point inpx) h)
               (vla-AddText mSpace y (vlax-3d-point inpy) h)
             ) ;progn
           )
         )
       ) ;if
       (if (/= (vlax-get-property obj1 'objectname) "AcDbLine")
         (progn
           (princ "\nÏß¶Î»æÖÆ´íÎó£¬ÖØÐÂ»æÖÆ»ò<ÍË³ö>")
           (command "_.erase" (entlast) "")
         )
       )
     )
     (if (/= p "S")
       (setq kflag nil) ;ÊäÈëSºó²»ÔÊÐíÌÓÀëÑ*»·
     )
   )
 ) ;while
 (setvar "clayer" olay)
)

(defun chklay (/ layflag)
 (setq layflag (tblsearch "layer" "×ø±ê±ê×¢"))
 (if (not layflag)
   (command "_layer" "m" "×ø±ê±ê×¢" "c" "3" "" "")
 )
 (setvar "clayer" "×ø±ê±ê×¢")
)

(defun drawcross (p / px1 px2 py1 py2)
 (setq eflag (tblsearch "block" "×ø±êÊ®×Ö±ê¼Ç")) ;¿é´æÔÚ±ê¼Ç
 (if (not eflag) ;²»´æÔÚÊ®×Ö±ê¼ÇµÄ¿é£¬Ôò°´ÈçÏÂ´´½¨
   (progn
     (setq px1 (polar p (angtof "180") 1.5) ;×ó×ø±ê
           px2 (polar p '0 '1.5) ;ÓÒ×ø±ê
           py1 (polar p (angtof "90") '1.5) ;ÉÏ×ø±ê
           py2 (polar p (angtof "270") '1.5) ;ÏÂ×ø±ê
     )
     (entmake (list
                (cons 0 "BLOCK")
                (cons 2 "×ø±êÊ®×Ö±ê¼Ç")
                (cons 70 0)
                (cons 10 p)
              )
     )
     (entmake (list
                (cons 0 "LINE")
                (cons 10 px1)
                (cons 11 px2)
              )
     )
     (entmake (list
                (cons 0 "LINE")
                (cons 10 py1)
                (cons 11 py2)
              )
     )
     (entmake '((0 . "endblk")))
   ) ;progn
 ) ;if
 (command "_insert" "×ø±êÊ®×Ö±ê¼Ç" p (/ h 3.5) (/ h 3.5) "0")
)

December 14, 2013

flyfox1047,

Something as simple as below actually does about the same as what you want,

while keeping the advantage of style definition.

ymg

(defun c:lb (/ p x y str)
 (while (setq p (getpoint "\nPick Point: "))
    (setq   x (strcat "X = " (if (minusp (car p)) ""  "+" ) (rtos (car   p))))
    (setq   y (strcat "Y = " (if (minusp (cadr p)) "" "+" ) (rtos (cadr  p))))
    (setq str (strcat x "\n" y))
   ;(setq   z (strcat "Z = "(if (minusp (caddr p)) "" "+" ) (rtos (caddr p))))
   ;(setq str (strcat x "\n" y "\n" z))                                       
    (command "_LEADER" p pause "" str "")
 )
)

Edited December 14, 2013 by ymg3

December 15, 2013

(defun C:bz (/ AcadObject AcadDocument mSpace h1 len inp kflag obj1 p1 p2 x y anglel inpx inpy lasp olay tx ty)
 (princ "\n×ø±ê±ê×¢V1.10£¬Ö´ÐÐÃüÁî£ºbz")
 (setq olay (getvar "clayer"))
 (setvar "cmdecho" 0)
;;;  ÉèÖÃActiveXµÄ¹¤×÷»·¾³‰äÁ¿
 (VL-LOAD-COM)
 (setq AcadObject   (vlax-get-acad-object)
       AcadDocument (vla-get-ActiveDocument Acadobject)
       mSpace       (vla-get-ModelSpace Acaddocument)
 )
 (setvar "cmdecho" 0)
 (setq kflag t)
 (while kflag
   (chklay)
   (initget "S")
   (if (not h)
     (setq h '1.5)
   )
   (setq
     p (getpoint (strcat "\nÖ¸¶¨Æðµã/¡¾S¡¿ÉèÖÃ×Ö¸ß[<" (rtos h) ">]"))
   )
   (if (= p "S")
     (setq h1 (getreal (strcat "\nÊäÈëÐÂ×Ö¸ß<" (rtos h) ">")))
   )
   (if h1
     (setq h h1)
   )
   (if (and (/= p "S") p)
     (progn
       (drawcross p) ;ÔÚ´æÔÚpµÄÇé¿öÏÂ»*Ê®×Ö¹â±ê
       (prompt "\nÖ¸¶¨ÏÂÒ»µã£º")
       (command "line" p (getdist p) "")
       (setq obj1 (vlax-ename->vla-object (entlast)))
       (if (= (vlax-get-property obj1 'objectname) "AcDbLine")
         (progn
           (setq p1 (vlax-get obj1 'startpoint))
           (setq p2 (vlax-get obj1 'endpoint))
           (setq x (strcat "X=" (if (minusp (car p1)) "" "+" ) (rtos (car p1) 2 3)))
           (setq y (strcat "Y=" (if (minusp (cadr p1)) "" "+" ) (rtos (cadr p1) 2 3)))
           (setq len (max (strlen x) (strlen y)))
           (setq anglel (vlax-get obj1 'Angle))
           (if (and (> anglel (/ pi 2)) (< anglel (/ (* pi 1.5))))
             ;;ÔÚµÚ¶þ¡¢ÈýÏóÏÞ±ê×¢
             (progn
               (setq lasp (polar p2 (angtof "180") (* (* 0.6 h) len)))
               (setq inp (polar lasp '0 (* 0.2 h)))
               (setq inpx (polar inp (angtof "90") (* 0.2 h)))
               (setq inpy (polar inp (angtof "270") (* 1.1 h)))
               (vla-AddLine mSpace (vlax-3d-point p2) (vlax-3d-point lasp))
               (setq tx (vla-AddText mSpace x (vlax-3d-point inpx) h))
               (setq ty (vla-AddText mSpace y (vlax-3d-point inpy) h))
             ) ;progn
             ;;ÔÚµÚÒ»¡¢ËÄÏóÏÞ±ê×¢
             (progn
               (setq lasp (polar p2 '0 (* (* 0.7 h) len)))
               (setq inp (polar p2 '0 (* 0.3 h)))
               (setq inpx (polar inp (angtof "90") (* 0.2 h)))
               (setq inpy (polar inp (angtof "270") (* 1.1 h)))
               (vla-AddLine mSpace (vlax-3d-point p2) (vlax-3d-point lasp))
               (vla-AddText mSpace x (vlax-3d-point inpx) h)
               (vla-AddText mSpace y (vlax-3d-point inpy) h)
             ) ;progn
           )
         )
       ) ;if
       (if (/= (vlax-get-property obj1 'objectname) "AcDbLine")
         (progn
           (princ "\nÏß¶Î»æÖÆ´íÎó£¬ÖØÐÂ»æÖÆ»ò<ÍË³ö>")
           (command "_.erase" (entlast) "")
         )
       )
     )
     (if (/= p "S")
       (setq kflag nil) ;ÊäÈëSºó²»ÔÊÐíÌÓÀëÑ*»·
     )
   )
 ) ;while
 (setvar "clayer" olay)
)

(defun chklay (/ layflag)
 (setq layflag (tblsearch "layer" "×ø±ê±ê×¢"))
 (if (not layflag)
   (command "_layer" "m" "×ø±ê±ê×¢" "c" "3" "" "")
 )
 (setvar "clayer" "×ø±ê±ê×¢")
)

(defun drawcross (p / px1 px2 py1 py2)
 (setq eflag (tblsearch "block" "×ø±êÊ®×Ö±ê¼Ç")) ;¿é´æÔÚ±ê¼Ç
 (if (not eflag) ;²»´æÔÚÊ®×Ö±ê¼ÇµÄ¿é£¬Ôò°´ÈçÏÂ´´½¨
   (progn
     (setq px1 (polar p (angtof "180") 1.5) ;×ó×ø±ê
           px2 (polar p '0 '1.5) ;ÓÒ×ø±ê
           py1 (polar p (angtof "90") '1.5) ;ÉÏ×ø±ê
           py2 (polar p (angtof "270") '1.5) ;ÏÂ×ø±ê
     )
     (entmake (list
                (cons 0 "BLOCK")
                (cons 2 "×ø±êÊ®×Ö±ê¼Ç")
                (cons 70 0)
                (cons 10 p)
              )
     )
     (entmake (list
                (cons 0 "LINE")
                (cons 10 px1)
                (cons 11 px2)
              )
     )
     (entmake (list
                (cons 0 "LINE")
                (cons 10 py1)
                (cons 11 py2)
              )
     )
     (entmake '((0 . "endblk")))
   ) ;progn
 ) ;if
 (command "_insert" "×ø±êÊ®×Ö±ê¼Ç" p (/ h 3.5) (/ h 3.5) "0")
)

Hi ymg,thank you! I don't know why text garbled，Can't work normally

December 15, 2013

(defun c:lb (/ p x y str)
 (while (setq p (getpoint "\nPick Point: "))
    (setq   x (strcat "X = " (if (minusp (car p)) ""  "+" ) (rtos (car   p))))
    (setq   y (strcat "Y = " (if (minusp (cadr p)) "" "+" ) (rtos (cadr  p))))
    (setq str (strcat x "\n" y))
   ;(setq   z (strcat "Z = "(if (minusp (caddr p)) "" "+" ) (rtos (caddr p))))
   ;(setq str (strcat x "\n" y "\n" z))                                       
    (command "_LEADER" p pause "" str "")
 )
)

This code is very good! concise，Thank you again ！can you help me in this code create a dim layer， layer Color is green，put dimleader into the dim layer，dim precision Keep two decimal places

Edited December 15, 2013 by flyfox1047

December 15, 2013

(defun c:lb ( / p x y str )
 (if (not (tblsearch "LAYER" "dim"))
   (entmake '((0 . "LAYER") (100 . "AcDbSymbolTableRecord") (100 . "AcDbLayerTableRecord") (2 . "dim") (70 . 0) (62 . 3) (6 . "Continuous")))
   (prompt "\nLayer : \"dim\" already exist - setting it to current and proceeding with routine...")
 )
 (setvar 'clayer "dim")
 (while (setq p (getpoint "\nPick Point - ENTER to finish: "))
    (setq   x (strcat "X = " (if (minusp (car p)) ""  "+" ) (rtos (car p) 2 2)))
    (setq   y (strcat "Y = " (if (minusp (cadr p)) "" "+" ) (rtos (cadr p) 2 2)))
    (setq str (strcat x "\n" y))
   ;(setq   z (strcat "Z = "(if (minusp (caddr p)) "" "+" ) (rtos (caddr p) 2 2)))
   ;(setq str (strcat x "\n" y "\n" z))                                       
    (command "_LEADER" p pause "" str "")
 )
 (princ)
)

December 15, 2013

(defun c:lb ( / p x y str )
 (if (not (tblsearch "LAYER" "dim"))
   (entmake '((0 . "LAYER") (100 . "AcDbSymbolTableRecord") (100 . "AcDbLayerTableRecord") (2 . "dim") (70 . 0) (62 . 3) (6 . "Continuous")))
   (prompt "\nLayer : \"dim\" already exist - setting it to current and proceeding with routine...")
 )
 (setvar 'clayer "dim")
 (while (setq p (getpoint "\nPick Point - ENTER to finish: "))
    (setq   x (strcat "X = " (if (minusp (car p)) ""  "+" ) (rtos (car p) 2 2)))
    (setq   y (strcat "Y = " (if (minusp (cadr p)) "" "+" ) (rtos (cadr p) 2 2)))
    (setq str (strcat x "\n" y))
   ;(setq   z (strcat "Z = "(if (minusp (caddr p)) "" "+" ) (rtos (caddr p) 2 2)))
   ;(setq str (strcat x "\n" y "\n" z))                                       
    (command "_LEADER" p pause "" str "")
 )
 (princ)
)

Very nice !marko_ribar, thank you!

Sign In

Help me write this lisp like this photo! thanks

Recommended Posts

flyfox1047

flyfox1047

ymg3

flyfox1047

ymg3

ymg3

flyfox1047

flyfox1047

marko_ribar

flyfox1047

Join the conversation

Tutorials

Forums

Activity