Author Topic: Help with slope lisp  (Read 295 times)

0 Members and 1 Guest are viewing this topic.

Topographer

  • Bull Frog
  • Posts: 492
Help with slope lisp
« on: August 07, 2017, 04:51:50 am »
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. (COMMAND "_layer" "_m" "_slope" "_c" "140" "" "")
  7. (command "-style" "_TanLine" "wgsimpl.shx" "_annotative" "_yes" "_no" 1.75 1.0 0.0 "_no" "_no" "" "")
  8.  (and (setq doc (cond (doc)
  9. )
  10.       )
  11.       (setq spc (if (zerop (vla-get-activespace doc))
  12.   (if (= (vla-get-mspace doc) :vlax-true)
  13.     (vla-get-modelspace doc)
  14.     (vla-get-paperspace doc)
  15.   )
  16. )
  17.       )
  18.  )
  19.  (defun *error* (msg)
  20.    (and TH:UnDo (vla-EndUndoMark doc))
  21.    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
  22. (princ (strcat "\n** Error: " msg " **"))
  23.    )
  24.    (princ)
  25.  )
  26.  (setq TH:StartUnDo (vla-StartUndoMark doc))
  27.  (initget "Line Points")
  28.  (if (eq (setq TL-sel
  29. (getkword (strcat "\nSpecify line or point [Line/Points]: " "< Line >"))
  30.  )
  31.  "Points"
  32.      )
  33.    (progn
  34.         (setq p1 (getpoint "\n Specify 1 point : "))
  35.      (setq p2 (getpoint p1 "\n Specify 2 point : "))
  36.      (setq p3 (getpoint "\n Specify the insert point : "))
  37.          (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1))))
  38.      (entmake (list (cons 0 "LINE")
  39.     (cons 10 (trans p1 1 0))
  40.     (cons 11 (trans p2 1 0))
  41.       )
  42.      )
  43. (vla-AddText spc (strcat (rtos (abs (* tan2 100)) 2 2) "%") (vlax-3d-point (trans p3 1 0))  (/ (getvar 'TEXTSIZE) (getvar 'cannoscalevalue)))
  44. )
  45.    (progn
  46.      (prompt "\n Select line: ")
  47.      (setq TL-Line (ssget '((0 . "LINE"))))
  48.      (setq e (ssname TL-Line 0))
  49.      (setq p1 (cdr (assoc 10 (entget e))))
  50.      (setq p2 (cdr (assoc 11 (entget e))))
  51.      (setq p3 (getpoint "\n Specify the insert point : "))
  52.      (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1))))
  53.      (vla-AddText spc (strcat (rtos (abs (* tan2 100)) 2 2) "%") (vlax-3d-point (trans p3 1 0)) 1.75)
  54.  
  55.    )
  56.  )
  57.  (setq TH:UnDo (vla-EndUndoMark Doc))
  58.  (princ "\n ")
  59.  (princ)
  60. )
  61.  
  62.  

Thanks

HasanCAD

  • Swamp Rat
  • Posts: 1198
Re: Help with slope lisp
« Reply #1 on: August 08, 2017, 07:43:29 am »
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.  (foreach args '( ("_SLOPE" 140 "Continuous" 0.15 t 0 "SLOPE VALUE")) (apply 'lyrmk args))  
  17.  
  18. ;(command "-style" "_TanLine" "wgsimpl.shx" "_annotative" "_yes" "_no" 1.75 1.0 0.0 "_no" "_no" "" "")
  19.  
  20.  (and (setq doc (cond (doc)       ((vla-get-ActiveDocument (vlax-get-Acad-Object))) )       )
  21.       (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))))
  22.  (setq styles (vla-get-textstyles doc))
  23.  (setq objStyle (vla-add styles "_TanLine"))
  24.  (setq ff "c:\\Windows\\fonts\\swisscbo.ttf")
  25.  (vla-put-fontfile objStyle ff)
  26.  (vla-put-activetextstyle doc objStyle)
  27.  
  28.  (setq TH:StartUnDo (vla-StartUndoMark doc))
  29.  (initget "Line Points")
  30.  (if (eq (setq TL-sel (getkword (strcat "\nSpecify line or point [Line/Points]: " "< Line >"))  )  "Points"      )
  31.    (progn
  32.      (setq p1 (getpoint "\n Specify 1 point : "))
  33.      (setq p2 (getpoint p1 "\n Specify 2 point : "))
  34.      (setq p12dist (distance p1 p2))
  35.      (setq ang (angle p1 p2))
  36.      (setq R-ang (LM:readable ang))
  37.      (setq p3 (polar p1 R-ang (/ p12dist 2.0)))
  38.      (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1))))
  39.      (setq myline (vla-addline spc (vlax-3d-point (trans p1 1 0)) (vlax-3d-point (trans p2 1 0))))
  40.      (vla-put-layer myline "_SLOPE")      
  41.      (setq txt (vla-AddText spc
  42.  (strcat (rtos (abs (* tan2 100)) 2 2) "%")
  43.  (vlax-3d-point (trans p3 1 0)) (/ (getvar 'TEXTSIZE) (getvar 'cannoscalevalue))))
  44.      (vla-put-rotation txt R-ang)
  45.      )
  46.    (progn
  47.      (prompt "\n Select line: ")
  48.      (setq TL-Line (ssget '((0 . "LINE"))))
  49.      (setq e (ssname TL-Line 0))
  50.      (setq p1 (cdr (assoc 10 (entget e))))
  51.      (setq p2 (cdr (assoc 11 (entget e))))
  52.      (setq p1 (trans p1 1 0 )
  53.    p2 (trans p2 1 0 )
  54.    p1X (min (nth 0 p1) (nth 0 p2))
  55.    p1Y (min (nth 1 p1) (nth 1 p2))
  56.    p2X (max (nth 0 p1) (nth 0 p2))
  57.    p2Y (max (nth 1 p1) (nth 1 p2))
  58.    )
  59.      (setq p1 (list p1X p1Y 0)
  60.    p2 (list p2X p2Y 0)
  61.    )
  62.      (setq p12dist (distance p1 p2))
  63.      (setq ang (angle p1 p2))
  64.      (setq R-ang (LM:readable ang))
  65.      (setq p3 (polar p1 R-ang (/ p12dist 2.0)))
  66.      (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1))))
  67.      (setq txt (vla-AddText spc (strcat (rtos (abs (* tan2 100)) 2 2) "%") (vlax-3d-point (trans p3 1 0)) (/ (getvar 'TEXTSIZE) (getvar 'cannoscalevalue))))
  68.      (vla-put-rotation txt R-ang)
  69.      (vla-put-textstyle txt "_TanLine")
  70.  
  71.    )
  72.  )
  73.  (setq TH:UnDo (vla-EndUndoMark Doc))
  74.  (princ "\n ")
  75.  (princ)
  76. )
  77.  

Topographer

  • Bull Frog
  • Posts: 492
Re: Help with slope lisp
« Reply #2 on: August 08, 2017, 09:24:26 am »
hi HasanCAD.I try your code but gives me this error

Quote
** Error: no function definition: nil **

HasanCAD

  • Swamp Rat
  • Posts: 1198
Re: Help with slope lisp
« Reply #3 on: August 08, 2017, 10:32:10 am »
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.  (if (not (tblsearch "LTYPE" lTyp))
  18.    (vla-load
  19.  (vlax-get-acad-object))) lTyp (if (= (getvar "MEASUREMENT") 0) "acad.lin" "acadiso.lin"))))
  20.  
  21.  (defun lyrmk (Nme Col lTyp lWgt Plt trns dsc / lay lyrs cmd) ;lee mac
  22.  ;http://www.cadtutor.net/forum/showthread.php?36882-Check-create-layer-issue-in-Lisp&p=243520&viewfull=1#post243520
  23.  (setq cmd (getvar 'cmdecho))
  24.  (setvar 'cmdecho 0)  
  25.  (if (not (tblsearch "LAYER" Nme))
  26.    (progn
  27.      (setq lay (vla-add lyrs Nme))
  28.      ;(mdfy)
  29.        (setq entVL (vlax-ename->vla-object (tblobjname "LAYER" Nme)))
  30.      (and Col (vla-put-Color entVL Col))
  31.      (and lTyp (lTload lTyp) (vla-put-Linetype entVL lTyp))
  32.      ;  (and lWgt (vla-put-LineWeight entVL (eval (read (strcat "acLnWt" lWgt)))))
  33.      (and lWgt (vl-cmdf "_.-layer" "_LWeight" lWgt Nme ""))
  34.      (and (not Plt) (vla-put-Plottable entVL :vlax-false))
  35.      (and (setq LyrDs (vlax-put-property entVL 'Description dsc)))
  36.      (vl-cmdf "_.-layer" "_TR" trns Nme "")
  37.      )
  38.    (progn
  39.      ;(mdfy)
  40.      (setq entVL (vlax-ename->vla-object (tblobjname "LAYER" Nme)))
  41.      (and Col (vla-put-Color entVL Col))
  42.      (and lTyp (lTload lTyp) (vla-put-Linetype entVL lTyp))
  43.      ;  (and lWgt (vla-put-LineWeight entVL (eval (read (strcat "acLnWt" lWgt)))))
  44.      (and lWgt (vl-cmdf "_.-layer" "_LWeight" lWgt Nme ""))
  45.      (and (not Plt) (vla-put-Plottable entVL :vlax-false))
  46.      (and (setq LyrDs (vlax-put-property entVL 'Description dsc)))
  47.      (vl-cmdf "_.-layer" "_TR" trns Nme "")))
  48.  (setvar 'cmdecho cmd))
  49.  
  50.  (foreach args '( ("_SLOPE" 140 "Continuous" 0.15 t 0 "SLOPE VALUE")) (apply 'lyrmk args))  
  51.  
  52.       (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))))
  53.  (setq styles (vla-get-textstyles doc))
  54.  (setq objStyle (vla-add styles "_TanLine"))
  55.  (setq ff "c:\\Windows\\fonts\\swisscbo.ttf")
  56.  (vla-put-fontfile objStyle ff)
  57.  (vla-put-activetextstyle doc objStyle)
  58.  
  59.  (setq TH:StartUnDo (vla-StartUndoMark doc))
  60.  (initget "Line Points")
  61.  (if (eq (setq TL-sel (getkword (strcat "\nSpecify line or point [Line/Points]: " "< Line >"))  )  "Points"      )
  62.    (progn
  63.      (setq p1 (getpoint "\n Specify 1 point : "))
  64.      (setq p2 (getpoint p1 "\n Specify 2 point : "))
  65.      (setq p12dist (distance p1 p2))
  66.      (setq ang (angle p1 p2))
  67.      (setq R-ang (LM:readable ang))
  68.      (setq p3 (polar p1 R-ang (/ p12dist 2.0)))
  69.      (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1))))
  70.      (setq myline (vla-addline spc (vlax-3d-point (trans p1 1 0)) (vlax-3d-point (trans p2 1 0))))
  71.      (vla-put-layer myline "_SLOPE")      
  72.      (setq txt (vla-AddText spc
  73.  (strcat (rtos (abs (* tan2 100)) 2 2) "%")
  74.  (vlax-3d-point (trans p3 1 0)) (/ (getvar 'TEXTSIZE) (getvar 'cannoscalevalue))))
  75.      (vla-put-rotation txt R-ang)
  76.      )
  77.    (progn
  78.      (prompt "\n Select line: ")
  79.      (setq TL-Line (ssget '((0 . "LINE"))))
  80.      (setq e (ssname TL-Line 0))
  81.      (setq p1 (cdr (assoc 10 (entget e))))
  82.      (setq p2 (cdr (assoc 11 (entget e))))
  83.      (setq p1 (trans p1 1 0 )
  84.    p2 (trans p2 1 0 )
  85.    p1X (min (nth 0 p1) (nth 0 p2))
  86.    p1Y (min (nth 1 p1) (nth 1 p2))
  87.    p2X (max (nth 0 p1) (nth 0 p2))
  88.    p2Y (max (nth 1 p1) (nth 1 p2))
  89.    )
  90.      (setq p1 (list p1X p1Y 0)
  91.    p2 (list p2X p2Y 0)
  92.    )
  93.      (setq p12dist (distance p1 p2))
  94.      (setq ang (angle p1 p2))
  95.      (setq R-ang (LM:readable ang))
  96.      (setq p3 (polar p1 R-ang (/ p12dist 2.0)))
  97.      (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1))))
  98.      (setq txt (vla-AddText spc (strcat (rtos (abs (* tan2 100)) 2 2) "%") (vlax-3d-point (trans p3 1 0)) (/ (getvar 'TEXTSIZE) (getvar 'cannoscalevalue))))
  99.      (vla-put-rotation txt R-ang)
  100.      (vla-put-textstyle txt "_TanLine")
  101.  
  102.    )
  103.  )
  104.  (setq TH:UnDo (vla-EndUndoMark Doc))
  105.  (princ "\n ")
  106.  (princ)
  107. )
  108.