mhy3sx Posted June 15, 2023 Share Posted June 15, 2023 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 Quote Link to comment Share on other sites More sharing options...
Steven P Posted June 15, 2023 Share Posted June 15, 2023 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) Quote Link to comment Share on other sites More sharing options...
mhupp Posted June 15, 2023 Share Posted June 15, 2023 (edited) 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 1 Quote Link to comment Share on other sites More sharing options...
mhy3sx Posted June 16, 2023 Author Share Posted June 16, 2023 I can not understand how to use all this !!! Is any other easy way to use ht ? Thanks Quote Link to comment Share on other sites More sharing options...
mhupp Posted June 19, 2023 Share Posted June 19, 2023 give this a look https://www.afralisp.net/archive/methods/lista/addtext_method.htm Quote Link to comment Share on other sites More sharing options...
mhy3sx Posted June 19, 2023 Author Share Posted June 19, 2023 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 Quote Link to comment Share on other sites More sharing options...
Tharwat Posted June 19, 2023 Share Posted June 19, 2023 @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 ) ) Quote Link to comment Share on other sites More sharing options...
mhy3sx Posted June 20, 2023 Author Share Posted June 20, 2023 Thank you Tharwat. Quote Link to comment Share on other sites More sharing options...
Tharwat Posted June 20, 2023 Share Posted June 20, 2023 34 minutes ago, mhy3sx said: Thank you Tharwat. You are welcome anytime. Quote Link to comment Share on other sites More sharing options...
Recommended Posts
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.