Lisp file request

[Stryder]

It has been a while but if at all possible I would like to get an update to this lisp. As if the string of text wasn't long enough I need to add to it. Instead of only the decimal form I need a percentage added to it. So, where it used to read:

 

363 L.F. OF 8" P.V.C. @ 0.037 SLOPE

 

It needs to read:

 

363 L.F. OF 8" P.V.C. @ 0.037 SLOPE (3.7%)

 

Thanks,

Stryder

[Lee Mac]

This seems like such a long time ago!

 

I think I may re-write this one to make it better

[Lee Mac]

Try this:

 

;; Pipe Text Marker  by  Lee McDonnell  13.04.2009

;;; Updated 30.07.2009 (Lee McDonnell)

(defun c:pipetxt  (/ *error* CANG COBJ CPT DIAM DOC GR LANG LENT LEPT
                    LLEN LMID LSLP LSPT MANHOL MSG OSPT OVAR PT SCL
                    SPC TBOX TOBJ TSTR TSZE TWID VLST WBSE XDIS)
 (vl-load-com)
 
 (defun *error*  (msg)
   (if doc (vla-EndUndoMark doc))
   (if ovar (mapcar 'setvar vlst ovar))
   (and tObj (not (vlax-erased-p tObj))
        (vla-delete tObj))
   (if (not
         (wcmatch
           (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
     (princ
       (strcat "\n** Error: " msg " **"))
     (princ "\n*Cancel*"))
   (redraw) (princ))
 
 (setq vlst '("CLAYER" "DIMZIN")
       ovar (mapcar 'getvar vlst))
 (mapcar 'setvar (cdr vlst) '(1))

 (if (eq 4 (logand 4 (cdr (assoc 70 (tblsearch "LAYER" (getvar "CLAYER"))))))
   (progn
     (princ "\n<< Current Layer Locked >>") (exit)))
 
 (setq doc (vla-get-ActiveDocument
             (vlax-get-Acad-Object))
       spc (if (zerop (vla-get-activespace doc))
             (if (= (vla-get-mspace doc) :vlax-true)
               (vla-get-modelspace doc)
               (vla-get-paperspace doc))
             (vla-get-modelspace doc)))
 
 (or (tblsearch "LAYER" "TXT-100")
     (vla-add (vla-get-layers doc) "TXT-100"))
 
 (or (and (zerop (getvar "DIMSCALE")) (setq scl 1.0))
     (setq scl (getvar "DIMSCALE")))
 
 (or pip:dia (setq pip:dia )
 (or man:hol (setq man:hol 10.96))
 (or *Mac$Per* (setq *Mac$Per* (/ pi 2.)))
 (or *Mac$tOff* (setq *Mac$tOff* 1.))
 
 (initget 6)
 (or (not (setq diam
            (getreal
              (strcat "\nSpecify Diameter of Pipeline <"
                      (rtos pip:dia 2 0) "\">: "))))
     (setq pip:dia diam))  
 (initget 6)
 (or (not (setq manhol
            (getreal
              (strcat "\nSpecify Manhole Diameter <"
                      (rtos man:hol 2 2) "'>: "))))
     (setq man:hol manhol))  
 
 (while
   (and
     (setq lEnt (car (entsel "\nSelect Pipeline: ")))
     (eq "LINE" (cdadr (entget lEnt))))
   (setq cObj (vlax-ename->vla-object lEnt)
         lSpt (vlax-curve-getStartPoint cObj)
         lEpt (vlax-curve-getEndPoint cObj)
         lAng (angle lSpt lEpt)
         xdis (- (car lEpt) (car lSpt)))
   (if (zerop xdis)
     (setq lSlp "-")
     (setq lSlp (rtos (/ (- (cadr lEpt) (cadr lSpt)) (* 10.0 xdis)) 2 3)))
   (setq lLen (+ (abs (- (car lEpt) (car lSpt))) man:hol)
         lMid (vlax-curve-getPointatParam cObj
                (/ (vlax-curve-getEndParam cObj) 2.0)))
   (setq tStr (strcat (rtos lLen 2 0) " L.F. OF "
                      (rtos pip:dia 2 0) "\"%%C P.V.C. @ " lSlp " SLOPE ("
                      (rtos (* (distof lSlp 2) 100.) 2 2) "%)")
         tSze (* 0.1 scl))
   (setq tBox (textbox (list (cons 1 (strcat tStr ".."))
                               (cons 40 tSze)
                               (cons 7 (getvar "TEXTSTYLE"))))
           wBse (textbox (list (cons 1 ".")
                               (cons 40 tSze)
                               (cons 7 (getvar "TEXTSTYLE"))))
           wBse (- (caadr wBse) (caar wBse)))
   (vla-put-attachmentpoint
     (setq tObj
       (vla-addMText spc
         (vlax-3D-point '(0 0 0))
           (setq tWid (- (caadr tBox) (caar tBox))) tStr))
         acAttachmentPointMiddleCenter)
   (vla-put-Height tObj tSze)
   (vla-put-layer tObj "TXT-100")

   (setq msg
          (princ "\n<< Type [+] or [-] for offset, [P]er & [<] or [>] for MText Width  >>"))
   
   ;; Place Text
   
   (while
     (progn
       (setq gr (grread t 15 0))
       (redraw)
       (cond ((and (eq 5 (car gr)) (listp (setq cPt (cadr gr))))
              (setq pt (vlax-curve-getClosestPointto cObj cPt))
              (if (and (< 0 (getvar "OSMODE") 16383)
                       (setq osPt (osnap pt (osLst (getvar "OSMODE")))))
                (osMark osPt))
              (setq cAng (angle pt cPt)
                    lAng (+ cAng *Mac$Per*))
              
              ;; Correct Angle
              
              (cond ((and (> lAng (/ pi 2)) (<= lAng pi))
                     (setq lAng (- lAng pi)))
                    ((and (> lAng pi) (<= lAng (/ (* 3 pi) 2)))
                     (setq lAng (+ lAng pi))))
              
              (vla-move tObj
                        (vla-get-InsertionPoint tObj)
                        (vlax-3D-point
                          (polar pt cAng (* tSze *Mac$tOff*))))
              (vla-put-Rotation tObj lAng) t)
             
             ((eq 2 (car gr))
              (cond ((vl-position (cadr gr) '(43 61))
                     (setq *Mac$tOff*
                            (+ (/ 1 10.) *Mac$tOff*)))
                    ((eq (cadr gr) 45)
                     (setq *Mac$tOff*
                            (-  *Mac$tOff* (/ 1 10.))))
                    ((eq 6 (cadr gr))
                     (cond ((< 0 (getvar "OSMODE") 16384)
                            (setvar "OSMODE" (+ 16384 (getvar "OSMODE")))
                            (princ (strcat "\n<Osnap off>" msg)))
                           (t (setvar "OSMODE" (- (getvar "OSMODE") 16384))
                            (princ (strcat "\n<Osnap on>" msg)))) t)
                    ((vl-position (cadr gr) '(80 112))
                     (setq *Mac$Per* (- (/ pi 2.) *Mac$Per*)))
                    ((vl-position (cadr gr) '(60 44))
                     (if (> (- (vla-get-Width tObj) wBse) 0)
                       (vla-put-Width tObj
                         (- (vla-get-Width tObj) wBse))) t)
                    ((vl-position (cadr gr) '(62 46))
                     (vla-put-Width tObj
                       (+ (vla-get-Width tObj) wBse)) t)
                    ((vl-position (cadr gr) '(13 32)) nil)
                    (t)))
             
             ((eq 3 (car gr))
              (if (and (< 0 (getvar "OSMODE") 16383)
                       (setq osPt (osnap pt (osLst (getvar "OSMODE")))))
                (progn
                  (osMark osPt)
                  (setq cAng (angle pt cPt)
                        lAng (+ cAng *Mac$Per*))
                  
                  ;; Correct Angle
                  
                  (cond ((and (> lAng (/ pi 2)) (<= lAng pi))
                         (setq lAng (- lAng pi)))
                        ((and (> lAng pi) (<= lAng (/ (* 3 pi) 2)))
                         (setq lAng (+ lAng pi))))
                  
                  (vla-move tObj
                            (vla-get-InsertionPoint tObj)
                            (vlax-3D-point
                              (polar ospt cAng (* tSze *Mac$tOff*))))
                  (vla-put-Rotation tObj lAng)))
              
              nil)
             
             ((eq 25 (car gr)) nil) (t)))))
 
 (mapcar 'setvar vlst ovar)
 (redraw) (princ))

(princ "\n.: PipeText Loaded, type \"Pipetxt\" to invoke :.")
(princ)

(defun oSlst (os / str cnt)
 (setq str "" cnt 0)
 (if (< 0 os 16383)
   (foreach mod '("_end" "_mid" "_cen" "_nod" "_qua"
                  "_int" "_ins" "_per" "_tan" "_nea"
                  "_non" "_app" "_ext" "_par")
     (if (not (zerop (logand (expt 2 cnt) os)))
       (setq str (strcat str mod (chr 44))))
     (setq cnt (1+ cnt))))
 (vl-string-right-trim (chr 44) str))

(defun osMark (pt / drft osSz osCol ratio bold glst i)
 (setq drft (vla-get-drafting
              (vla-get-preferences
                (vlax-get-acad-object)))
       osSz (vla-get-AutoSnapMarkerSize drft)
       oscol (vla-get-AutoSnapMarkerColor drft)
       ratio (/ (getvar "VIEWSIZE")
              (cadr (getvar "SCREENSIZE")))
       bold (mapcar
              (function
                (lambda (x)
                  (* x ratio))) (list (+ osSz 0.5) osSz (- osSz 0.5))) i 0)

 (repeat 50
   (setq glst
     (cons
       (polar '(0 0 0) (* i (/ pi 25.)) 1.) glst) i (1+ i)))      

 (foreach x bold
    (grvecs (append (list oscol) glst (cdr glst) (list (car glst)))
            (list (list  x  0.0 0.0 (car pt))
                  (list 0.0  x  0.0 (cadr pt))
                  (list 0.0 0.0 1.0 0.0)
                  (list 0.0 0.0 0.0 1.0)))))

[Stryder]

GENIUS!!! I love it!!! I may bring this post back up every 2 months just to see if there is anything you want to do to make it better! Thanks for the update and the quick response as usual!!!

 

Later,

Stryder

[Lee Mac]

Cheers Stryder, I have learnt a lot more since we last spoke, so I just applied the new knowledge

 

Glad you like it,

 

Lee

[Stryder]

I am back... I have a request for this lisp. I really love it and it makes my life at work so much easier. However, the latest change with the for text width and the + - for the distance off the line is getting to be a chore when I have to label hundreds of pipes in a project. So, I don't know if this is possible but it might work better if I could designate how many lines of text I want it to use. Maybe there could be a promt to ask me how many lines of text I want.

 

If this isn't possible we could just go back to the way it was. If it is less than a certain number it would make it 2 lines and the same for 3 lines.

 

Thanks,

Stryder