Contour Leabel lisp

[mhy3sx]

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

[Steven P]

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)

 

[mhupp]

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 June 15, 2023 by mhupp

[mhy3sx]

I can not understand how to use all this !!! Is any other easy way to use ht ?

 

Thanks

[mhupp]

give this a look

 

https://www.afralisp.net/archive/methods/lista/addtext_method.htm

[mhy3sx]

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

[Tharwat]

@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
  )
)

 

[mhy3sx]

Thank you Tharwat.

[Tharwat]

34 minutes ago, mhy3sx said:

Thank you Tharwat.

You are welcome anytime.