Jump to content

Contour Leabel lisp


mhy3sx

Recommended Posts

Hi, I am trying to change the text height by the giving scale using a ht parameter , but I can not find In the code  where  the text height change. Can any one help

 

 

(defun C:LabelContour ( / *error* @ang cmdecho Done Space E Ent Etype Flag Obj P OK Ang Elev Prec)
  ;* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
  ;*                                                                           *
  ;*    LabelContour.LSP  by   John F. Uhden                                   *
  ;*                           2 Village Road                                  *
  ;*                           Sea Girt, NJ  08750                             *
  ;*                                                                           *
  ;* * * * * * * * * * * *  Do not delete this heading!  * * * * * * * * * * * *

  ; Routine labels the elevation of 2D polylines and AECC_CONTOURS.
  ; v1.00 (02-13-08) on 5:13pm from Hoboken
  ; v1.01 (04-27-08) in Fun Room - added precision; fixed (atan...)

  ;-------------------I add this Lines  ---------------------------
     (if (=(tblsearch "layer" "Contour Label") nil)
      (command "_layer" "_m" "Contour Label" "_c" "7" "" "")
     );end if
     (setvar "clayer" "Contour Label")
    ; (setq scl (getvar "useri1")) 
    (setq scl (getint "\n Set Scale  (50,100,200,250,500,etc) :"))
     (setq ht (* 0.00175 scl)) 

  ;--------------------------------------------------------------
  (gc)
  (vl-load-com)
  (prompt "\nLabelContour v1.01 (c)2008, John F. Uhden, Cadlantic")

  (defun *error* (error)
    (if (= (type cmdecho) 'INT)(setvar "cmdecho" cmdecho))
    (vla-endundomark *doc*)
    (cond
      ((not error))
      ((wcmatch (strcase error) "*QUIT*,*CANCEL*"))
      (1 (princ (strcat "\nERROR: " error)))
    )
    (princ)
  )

  ;;-------------------------------------------
  ;; Initialize drawing and program variables:
  ;;
  (or *acad* (setq *acad* (vlax-get-acad-object)))
  (or *doc* (setq *doc* (vla-get-ActiveDocument *acad*)))
  (vla-endundomark *doc*)
  (vla-startundomark *doc*)
  (setq cmdecho (getvar "cmdecho")
        Space (vlax-get *doc* (if (= (getvar "cvport") 1) 'PaperSpace 'ModelSpace))
  )
  (setvar "cmdecho" 0)
  (command "_.Expert" (getvar "expert")) ; dummy command
  (setvar "errno" 0)
  (defun @ang (ang)
    (if (<= (* 0.5 pi) ang (* 1.5 pi))
      (+ ang pi)
      ang
    )
  )
  (or
    (setq Prec (vl-bb-ref 'CAD#LabelContourPrec))
    (vl-bb-set 'CAD#LabelContourPrec (setq Prec 0))
  )
  (initget 4) ; no negative
  (while (not Done)
    (setq OK nil)
    (if (setq P (entsel "\nSelect contour at point to label: "))
      (setq E (car P)
            P (cadr P)
            Ent (entget E)
            Obj (vlax-ename->vla-object E)
            Etype (cdr (assoc 0 Ent))
            Flag (cdr (assoc 70 Ent))
      )
      (setq Ent nil)
    )
    (cond
      ((= (getvar "errno") 52)
        (setq Done 1)
      )
      ((not Ent))
      ((= Etype "AECC_CONTOUR")(setq OK 1))
      ((= Etype "LWPOLYLINE")(setq OK 1))
      ((and (= Etype "POLYLINE")(= (logand Flag 8) 0))(setq OK 1))
      (1 (prompt "\nEntity selected is not a contour or 2D polyline."))
    )
    (and OK
      (setq P (vlax-curve-getclosestpointto Obj P))
      ;| BE CAREFUL WITH ATAN...
         Command: (apply 'atan (list -3.0 -5.0))
         -2.60117

         Command: (atan (apply '/ (list -3.0 -5.0)))
         0.54042
      |;
    				
    					
      (setq ang (atan (apply '/ (cdr (reverse (vlax-curve-getfirstderiv Obj (vlax-curve-getparamatpoint obj P)))))))
      (setq Elev (last P))
      (setq Obj (vlax-invoke Space 'AddMtext P 0.0 (rtos Elev 2 2)))
      (or (vlax-put Obj 'AttachmentPoint 5) 1) ; Middle Center
      (or (vlax-put Obj 'InsertionPoint (list (car P)(cadr P) 0.0)) 1)
      (or
        (not (vlax-property-available-p Obj 'Backgroundfill))
        (vlax-put Obj 'Backgroundfill 1)
        1
      )
      (or (vlax-put Obj 'Rotation (@ang ang)) 1)
    )
  )
  (*error* nil)
)
(defun c:LC ()(c:LabelContour))

 

Thanks

Link to comment
Share on other sites

This line creates the text:

 

(setq Obj (vlax-invoke Space 'AddMtext P 0.0 (rtos Elev 2 2)))

 

searching about on the internet should give you solution and explanation, 

 

Add something like this on the next line, where ht is your text height - might need to alter the position of the text height line to make it work

(vla-put-textheight obj ht)

 

Link to comment
Share on other sites

Use to check properties of entity's in AutoCAD.

;;----------------------------------------------------------------------------;;
;; Dump All Visual Lisp Methods and Properties for Selected Entity
(defun C:VDumpIt (/ ent)
  (while (setq ent (car (entsel "\nSelect Entity to Dump")))
    (vlax-Dump-Object (vlax-Ename->Vla-Object ent) t)
  )
  (princ)
)

 

Most are simple to change as (val-put-"property name" vla-object value)

Properties values listed with a (RO) are read only.

Edited by mhupp
  • Like 1
Link to comment
Share on other sites

Hi mhupp. I add this line

 

(vla-put-textheight obj ht)

 

but i didn't see any difference , the text height didn't change

 

Thanks

Link to comment
Share on other sites

@mhy3sx Give this a shot and let me know. :)

NOTE: Yo can press enter to accept the default scale factor or enter your desired one.

(defun c:Test (/ *error* prc sel ent pos cls ang typ txt)
  ;;----------------------------------------------------;;
  ;;	Author : Tharwat Al Choufi			;;
  ;; website: https://autolispprograms.wordpress.com	;;
  ;;----------------------------------------------------;;
  (defun *error* (msg)
    (and prc (setvar 'DIMZIN prc))
    (vla-endundomark *TH:doc*)
    (and msg
         (not (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*"))
         (princ (strcat "\nError => " msg))
    )
    (princ)
  )

  (or *TH:doc*
      (setq *TH:doc* (vla-get-ActiveDocument (vlax-get-acad-object)))
  )
  (vla-endundomark *TH:doc*)
  (vla-startundomark *TH:doc*)

  (or (tblsearch "layer" "Contour Label")
      (entmake (list
                 '(0 . "LAYER")
                 '(100 . "AcDbSymbolTableRecord")
                 '(100 . "AcDbLayerTableRecord")
                 '(2 . "Contour Label")
                 '(62 . 7)
                 '(70 . 0)
                )
      )
  )
  (or *MHY:Scale* (setq *MHY:Scale* 50))
  (and (progn
         (initget 6)
         (setq *MHY:Scale*
                (cond ((getint
                         (strcat
                           "\nSet Scale (50,100,200,250,500,etc) < "
                           (itoa *MHY:Scale*)
                           " > : "
                         )
                       )
                      )
                      (*MHY:Scale*)
                )
         )
       )
       (setq prc (getvar 'DIMZIN))
       (setvar 'DIMZIN 0)
       (while
         (and (setq sel (entsel "\nSelect contour at point to label: "))
              (setq ent (car sel)
                    pos (cadr sel)
              )
              (or (setq typ (wcmatch (cdr (assoc 0 (entget ent)))
                                     "AECC_CONTOUR,*POLYLINE"
                            )
                  )
                  (alert "Invalid object!. Try again")
                  t
              )
         )
          (and typ
               (setq cls (vlax-curve-getclosestpointto ent pos))
               (setq ang (angle '(0. 0. 0.)
                                (vlax-curve-getfirstderiv
                                  ent
                                  (vlax-curve-getparamatpoint ent cls)
                                )
                         )
               )
               (setq txt (entmakex (list '(0 . "MTEXT")
                                         '(100 . "AcDbEntity")
                                         '(100 . "AcDbMText")
                                         (cons 10 cls)
                                         (cons 1 (rtos (last cls) 2 2))
                                         (cons 40 (* 0.00175 *MHY:Scale*))
                                         (cons 8 "Contour Label")
                                         '(50 . 0.0)
                                         '(71 . 5)
                                         '(72 . 5)
                                         '(73 . 1)
                                         '(210 0.0 0.0 1.0)
                                   )
                         )
               )
               (or (vlax-put (setq txt (vlax-ename->vla-object txt))
                             'Backgroundfill
                             1
                   )
                   t
               )
               (vlax-put txt 'Rotation (@ang ang))
          )
       )
  )
  (*error* nil)
) (vl-load-com)
(defun @ang (ang)
  (if (<= (* 0.5 pi) ang (* 1.5 pi))
    (+ ang pi)
    ang
  )
)

 

Link to comment
Share on other sites

  • 1 year later...

This lisp almost works for us.  I need to change the text style from standard to one of ours. 
I hope that sets the height using the style.

 

What parameters are being used for the text style?

Link to comment
Share on other sites

Using Tharwats code?

 

Look at this section 

               (setq txt (entmakex (list '(0 . "MTEXT")
                                         '(100 . "AcDbEntity")
                                         '(100 . "AcDbMText")
                                         (cons 10 cls)
                                         (cons 1 (rtos (last cls) 2 2))
                                         (cons 40 (* 0.00175 *MHY:Scale*))
                                         (cons 8 "Contour Label")
                                         '(50 . 0.0)
                                         '(71 . 5)
                                         '(72 . 5)
                                         '(73 . 1)
                                         '(210 0.0 0.0 1.0)
                                   )
                         )
               )

 

Add '(7 . "Text_Style") where text style is your font in between '(50 . ...) and '(71 . ...). Here using Standard text style:

 

                                         '(50 . 0.0)
                                         '(7 . "Standard")
                                         '(71 . 5)

 

For height modify the (cons 40 (* 0.00175 *MHY@Scale*)) if necessary. Either change the 0.00175 to a different number or replace the whole (* 0.00175 *MHY:Scale*) to a value if you want the same height all the time eg. (cons 40 2.5)

  • Thanks 1
Link to comment
Share on other sites

Yes those fixes worked I almost have what I want.   Need to make the label have no decimal places too.  Comes in like first image but need second:

First.jpg.92b214c796b8586a0b0649aecbb82d65.jpg

 

Second.jpg.feefe4c44dfbb5471ae19597afd27abd.jpg

Link to comment
Share on other sites

A very simple answer is, it is your turn to do a little home work and learn at same time.

 

Google "RTOS Autodesk"

 

Have a look in the code you should be able to find it very quickly what to change.

  • Like 1
  • Thanks 1
Link to comment
Share on other sites

I am not the best at lisp routines but can edit them ok.  Thanks for the lesson.  I went online and found the syntax and edited it and now it is working well.

(cons 1 (rtos (last cls) 2 0))

  • Like 1
Link to comment
Share on other sites

Perfect - to be honest that is a much better answer than us just giving you the syntax! A little hint from BigAl, a bit of confidence that you can change the code and we can retire now?

Link to comment
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
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.

×
×
  • Create New...