Topic: Help with slope lisp

[pedroantonio]

Hi .I am using a slope lisp ,but i want to do same changes

This lisp give you two options

1) to select 2 points and then pick a point to insert the slope text
2)select a line and then pic a point to insert the slope text

The changes i want to do is

1) Automatically insert the slope text  in the midle of the line (over the line)

2) Correct the angle of the text. I want to align the text with the line

Code - Auto/Visual Lisp: [Select]

1. (defun c:TanLineanot(/     doc      spc      *error*  TH:UnDo
2.                   TH:StartUnDo      p1       p2       p3       scl   ht
3.                   tan2     TL-Line  TH:UnDo
4.                  )
5. ;;; Authour : Hasan Asos    -> Modified by Tharwat
6.   (vl-load-com)
7.  (COMMAND "_layer" "_m" "_slope" "_c" "140" "" "")
8.  (command "-style" "_TanLine" "wgsimpl.shx" "_annotative" "_yes" "_no" 1.75 1.0 0.0 "_no" "_no" "" "")
9.   (and (setq doc (cond (doc)
10.                        ((vla-get-ActiveDocument (vlax-get-Acad-Object)))
11.                  )
12.        )
13.        (setq spc (if (zerop (vla-get-activespace doc))
14.                    (if (= (vla-get-mspace doc) :vlax-true)
15.                      (vla-get-modelspace doc)
16.                      (vla-get-paperspace doc)
17.                    )
18.                    (vla-get-modelspace doc)
19.                  )
20.        )
21.   )
22.   (defun *error* (msg)
23.     (and TH:UnDo (vla-EndUndoMark doc))
24.     (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
25.         (princ (strcat "\n** Error: " msg " **"))
26.     )
27.     (princ)
28.   )
29.   (setq TH:StartUnDo (vla-StartUndoMark doc))
30.   (initget "Line Points")
31.   (if (eq (setq TL-sel
32.                  (getkword (strcat "\nSpecify line or point [Line/Points]: " "< Line >"))
33.           )
34.           "Points"
35.       )
36.     (progn
37.          (setq p1 (getpoint "\n Specify 1 point : "))
38.       (setq p2 (getpoint p1 "\n Specify 2 point : "))
39.       (setq p3 (getpoint "\n Specify the insert point : "))
40.           (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1))))
41.       (entmake (list (cons 0 "LINE")
42.                      (cons 10 (trans p1 1 0))
43.                      (cons 11 (trans p2 1 0))
44.                )
45.       )
46.  (vla-AddText spc (strcat (rtos (abs (* tan2 100)) 2 2) "%") (vlax-3d-point (trans p3 1 0))  (/ (getvar 'TEXTSIZE) (getvar 'cannoscalevalue)))
47. )
48.     (progn
49.       (prompt "\n Select line: ")
50.       (setq TL-Line (ssget '((0 . "LINE"))))
51.       (setq e (ssname TL-Line 0))
52.       (setq p1 (cdr (assoc 10 (entget e))))
53.       (setq p2 (cdr (assoc 11 (entget e))))
54.       (setq p3 (getpoint "\n Specify the insert point : "))
55.       (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1))))
56.       (vla-AddText spc (strcat (rtos (abs (* tan2 100)) 2 2) "%") (vlax-3d-point (trans p3 1 0)) 1.75)
57.        
58.     )
59.   )
60.   (setq TH:UnDo (vla-EndUndoMark Doc))
61.   (princ "\n ")
62.   (princ)
63. )
64.  
65.  

Thanks

[HasanCAD]

Give this a try

Code - Auto/Visual Lisp: [Select]

1. (defun c:TanLineanot (/ doc      spc      *error*  TH:UnDo  TH:StartUnDo
2.                         p1       p2       p3       scl      ht
3.                         tan2     TL-Line  TH:UnDo  ang      doc
4.                         e        ff       myline   objstyle p12dist
5.                         p1x      p1y      p2x      p2y      r-ang
6.                         styles   th:undo  tl-sel   txt
7.                        )
8. ;;; Authour : Hasan Asos    -> Modified by Tharwat
9.  
10.   ;; Readable  -  Lee Mac
11. ;; Returns an angle corrected for text readability.
12. (defun LM:readable ( a ) ((lambda ( a ) (if (and (< (* pi 0.5) a) (<= a (* pi 1.5))) (LM:readable (+ a pi)) a)) (rem (+ a pi pi) (+ pi pi))))
13.  
14.   (defun *error* (msg)    (and TH:UnDo (vla-EndUndoMark doc))    (or    (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")        (princ (strcat "\n** Error: " msg " **"))    )    (princ)  )
15.  
16.   (vl-load-com)
17.   (foreach args '( ("_SLOPE" 140 "Continuous" 0.15 t 0 "SLOPE VALUE")) (apply 'lyrmk args))  
18.  
19.  ;(command "-style" "_TanLine" "wgsimpl.shx" "_annotative" "_yes" "_no" 1.75 1.0 0.0 "_no" "_no" "" "")
20.  
21.   (and (setq doc (cond (doc)                   ((vla-get-ActiveDocument (vlax-get-Acad-Object)))                 )       )
22.        (setq 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))))
23.   (setq styles (vla-get-textstyles doc))
24.   (setq objStyle (vla-add styles "_TanLine"))
25.   (setq ff "c:\\Windows\\fonts\\swisscbo.ttf")
26.   (vla-put-fontfile objStyle ff)
27.   (vla-put-activetextstyle doc objStyle)
28.    
29.   (setq TH:StartUnDo (vla-StartUndoMark doc))
30.   (initget "Line Points")
31.   (if (eq (setq TL-sel (getkword (strcat "\nSpecify line or point [Line/Points]: " "< Line >"))   )       "Points"      )
32.     (progn
33.       (setq p1 (getpoint "\n Specify 1 point : "))
34.       (setq p2 (getpoint p1 "\n Specify 2 point : "))
35.       (setq p12dist (distance p1 p2))
36.       (setq ang (angle p1 p2))
37.       (setq R-ang (LM:readable ang))
38.       (setq p3 (polar p1 R-ang (/ p12dist 2.0)))
39.       (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1))))
40.       (setq myline (vla-addline spc (vlax-3d-point (trans p1 1 0)) (vlax-3d-point (trans p2 1 0))))
41.       (vla-put-layer myline "_SLOPE")      
42.       (setq txt (vla-AddText spc
43.                   (strcat (rtos (abs (* tan2 100)) 2 2) "%")
44.                   (vlax-3d-point (trans p3 1 0)) (/ (getvar 'TEXTSIZE) (getvar 'cannoscalevalue))))
45.       (vla-put-rotation txt R-ang)
46.       )
47.     (progn
48.       (prompt "\n Select line: ")
49.       (setq TL-Line (ssget '((0 . "LINE"))))
50.       (setq e (ssname TL-Line 0))
51.       (setq p1 (cdr (assoc 10 (entget e))))
52.       (setq p2 (cdr (assoc 11 (entget e))))
53.       (setq p1 (trans p1 1 0 )
54.             p2 (trans p2 1 0 )
55.             p1X (min (nth 0 p1) (nth 0 p2))
56.             p1Y (min (nth 1 p1) (nth 1 p2))
57.             p2X (max (nth 0 p1) (nth 0 p2))
58.             p2Y (max (nth 1 p1) (nth 1 p2))
59.             )
60.       (setq p1 (list p1X p1Y 0)
61.             p2 (list p2X p2Y 0)
62.             )
63.       (setq p12dist (distance p1 p2))
64.       (setq ang (angle p1 p2))
65.       (setq R-ang (LM:readable ang))
66.       (setq p3 (polar p1 R-ang (/ p12dist 2.0)))
67.       (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1))))
68.       (setq txt (vla-AddText spc (strcat (rtos (abs (* tan2 100)) 2 2) "%") (vlax-3d-point (trans p3 1 0)) (/ (getvar 'TEXTSIZE) (getvar 'cannoscalevalue))))
69.       (vla-put-rotation txt R-ang)
70.       (vla-put-textstyle txt "_TanLine")
71.  
72.     )
73.   )
74.   (setq TH:UnDo (vla-EndUndoMark Doc))
75.   (princ "\n ")
76.   (princ)
77. )
78.  

[pedroantonio]

hi HasanCAD.I try your code but gives me this error

** Error: no function definition: nil **

[HasanCAD]

There was missing subroutine
Try this

Code - Auto/Visual Lisp: [Select]

1. (defun c:TanLineanot (/ doc      spc      *error*  TH:UnDo  TH:StartUnDo
2.                         p1       p2       p3       scl      ht
3.                         tan2     TL-Line  TH:UnDo  ang      doc
4.                         e        ff       myline   objstyle p12dist
5.                         p1x      p1y      p2x      p2y      r-ang
6.                         styles   th:undo  tl-sel   txt
7.                        )
8. ;;; Authour : Hasan Asos    -> Modified by Tharwat
9.  
10.   ;; Readable  -  Lee Mac
11. ;; Returns an angle corrected for text readability.
12. (defun LM:readable ( a ) ((lambda ( a ) (if (and (< (* pi 0.5) a) (<= a (* pi 1.5))) (LM:readable (+ a pi)) a)) (rem (+ a pi pi) (+ pi pi))))
13.  
14.   (defun *error* (msg)    (and TH:UnDo (vla-EndUndoMark doc))    (or    (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")        (princ (strcat "\n** Error: " msg " **"))    )    (princ)  )
15.  
16.   (defun lTload (lTyp)
17.   (vl-load-com)
18.   (if (not (tblsearch "LTYPE" lTyp))
19.     (vla-load
20.       (vla-get-Linetypes
21.         (vla-get-ActiveDocument
22.           (vlax-get-acad-object))) lTyp (if (= (getvar "MEASUREMENT") 0) "acad.lin" "acadiso.lin"))))
23.  
24.   (defun lyrmk (Nme Col lTyp lWgt Plt trns dsc / lay lyrs cmd) ;lee mac
25.   ;http://www.cadtutor.net/forum/showthread.php?36882-Check-create-layer-issue-in-Lisp&p=243520&viewfull=1#post243520
26.   (vl-load-com)
27.   (setq cmd (getvar 'cmdecho))
28.   (setvar 'cmdecho 0)  
29.   (if (not (tblsearch "LAYER" Nme))
30.     (progn
31.       (setq lyrs (vla-get-layers (vla-get-ActiveDocument (vlax-get-acad-object))))
32.       (setq lay (vla-add lyrs Nme))
33.       ;(mdfy)
34.         (setq entVL (vlax-ename->vla-object (tblobjname "LAYER" Nme)))
35.       (and Col (vla-put-Color entVL Col))
36.       (and lTyp (lTload lTyp) (vla-put-Linetype entVL lTyp))
37.       ;  (and lWgt (vla-put-LineWeight entVL (eval (read (strcat "acLnWt" lWgt)))))
38.       (and lWgt (vl-cmdf "_.-layer" "_LWeight" lWgt Nme ""))
39.       (and (not Plt) (vla-put-Plottable entVL :vlax-false))
40.       (and (setq LyrDs (vlax-put-property entVL 'Description dsc)))
41.       (vl-cmdf "_.-layer" "_TR" trns Nme "")
42.       )
43.     (progn
44.       ;(mdfy)
45.       (setq entVL (vlax-ename->vla-object (tblobjname "LAYER" Nme)))
46.       (and Col (vla-put-Color entVL Col))
47.       (and lTyp (lTload lTyp) (vla-put-Linetype entVL lTyp))
48.       ;  (and lWgt (vla-put-LineWeight entVL (eval (read (strcat "acLnWt" lWgt)))))
49.       (and lWgt (vl-cmdf "_.-layer" "_LWeight" lWgt Nme ""))
50.       (and (not Plt) (vla-put-Plottable entVL :vlax-false))
51.       (and (setq LyrDs (vlax-put-property entVL 'Description dsc)))
52.       (vl-cmdf "_.-layer" "_TR" trns Nme "")))
53.   (setvar 'cmdecho cmd))
54.  
55.   (vl-load-com)
56.   (foreach args '( ("_SLOPE" 140 "Continuous" 0.15 t 0 "SLOPE VALUE")) (apply 'lyrmk args))  
57.  
58.   (and (setq doc (cond (doc) ((vla-get-ActiveDocument (vlax-get-Acad-Object))) ) )
59.        (setq 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))))
60.   (setq styles (vla-get-textstyles doc))
61.   (setq objStyle (vla-add styles "_TanLine"))
62.   (setq ff "c:\\Windows\\fonts\\swisscbo.ttf")
63.   (vla-put-fontfile objStyle ff)
64.   (vla-put-activetextstyle doc objStyle)
65.    
66.   (setq TH:StartUnDo (vla-StartUndoMark doc))
67.   (initget "Line Points")
68.   (if (eq (setq TL-sel (getkword (strcat "\nSpecify line or point [Line/Points]: " "< Line >"))   )       "Points"      )
69.     (progn
70.       (setq p1 (getpoint "\n Specify 1 point : "))
71.       (setq p2 (getpoint p1 "\n Specify 2 point : "))
72.       (setq p12dist (distance p1 p2))
73.       (setq ang (angle p1 p2))
74.       (setq R-ang (LM:readable ang))
75.       (setq p3 (polar p1 R-ang (/ p12dist 2.0)))
76.       (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1))))
77.       (setq myline (vla-addline spc (vlax-3d-point (trans p1 1 0)) (vlax-3d-point (trans p2 1 0))))
78.       (vla-put-layer myline "_SLOPE")      
79.       (setq txt (vla-AddText spc
80.                   (strcat (rtos (abs (* tan2 100)) 2 2) "%")
81.                   (vlax-3d-point (trans p3 1 0)) (/ (getvar 'TEXTSIZE) (getvar 'cannoscalevalue))))
82.       (vla-put-rotation txt R-ang)
83.       )
84.     (progn
85.       (prompt "\n Select line: ")
86.       (setq TL-Line (ssget '((0 . "LINE"))))
87.       (setq e (ssname TL-Line 0))
88.       (setq p1 (cdr (assoc 10 (entget e))))
89.       (setq p2 (cdr (assoc 11 (entget e))))
90.       (setq p1 (trans p1 1 0 )
91.             p2 (trans p2 1 0 )
92.             p1X (min (nth 0 p1) (nth 0 p2))
93.             p1Y (min (nth 1 p1) (nth 1 p2))
94.             p2X (max (nth 0 p1) (nth 0 p2))
95.             p2Y (max (nth 1 p1) (nth 1 p2))
96.             )
97.       (setq p1 (list p1X p1Y 0)
98.             p2 (list p2X p2Y 0)
99.             )
100.       (setq p12dist (distance p1 p2))
101.       (setq ang (angle p1 p2))
102.       (setq R-ang (LM:readable ang))
103.       (setq p3 (polar p1 R-ang (/ p12dist 2.0)))
104.       (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1))))
105.       (setq txt (vla-AddText spc (strcat (rtos (abs (* tan2 100)) 2 2) "%") (vlax-3d-point (trans p3 1 0)) (/ (getvar 'TEXTSIZE) (getvar 'cannoscalevalue))))
106.       (vla-put-rotation txt R-ang)
107.       (vla-put-textstyle txt "_TanLine")
108.  
109.     )
110.   )
111.   (setq TH:UnDo (vla-EndUndoMark Doc))
112.   (princ "\n ")
113.   (princ)
114. )
115.