+ Reply to Thread
Page 1 of 2 1 2 LastLast
Results 1 to 10 of 12
  1. #1
    Super Member prodromosm's Avatar
    Using
    AutoCAD 2014
    Join Date
    Jul 2010
    Posts
    604

    Default help with a slope lisp

    Registered forum members do not see this ad.

    Hi .I am useing this code , but i need to do some changes

    1) i want the text insert automatcaly in the midle of the line (above the line with a litle space)

    2) This code clculate the slope % . if the slope is 0,02 wrte 2% but if the slope is 0,002 % writes 0.2%. I ant to write 2‰ .


    Code:
    (defun c:TanLineanot(/	   doc	    spc	     *error*  TH:UnDo
    		  TH:StartUnDo	    p1	     p2	      p3       scl   ht
    		  tan2	   TL-Line  TH:UnDo
    		 )
    ;;; Authour : Hasan Asos    -> Modified by Tharwat 
      (vl-load-com)
     (COMMAND "_layer" "_m" "_slope" "_c" "140" "" "")
     (command "-style" "_TanLine" "wgsimpl.shx" "_annotative" "_yes" "_no" 1.75 1.0 0.0 "_no" "_no" "" "")
      (and (setq doc (cond (doc)
    		       ((vla-get-ActiveDocument (vlax-get-Acad-Object)))
    		 )
           )
           (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)
    		 )
           )
      )
      (defun *error* (msg)
        (and TH:UnDo (vla-EndUndoMark doc))
        (or	(wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
    	(princ (strcat "\n** Error: " msg " **"))
        )
        (princ)
      )
      (setq TH:StartUnDo (vla-StartUndoMark doc))
      (initget "Line Points")
      (if (eq (setq	TL-sel
    		 (getkword (strcat "\nselect line or points[Line/Points]: " "< Line >"))
    	  )
    	  "Points"
          )
        (progn
             (setq p1 (getpoint "\n select the first point : "))
          (setq p2 (getpoint p1 "\n select the second point : "))
          (setq p3 (getpoint "\n pick a point : "))
              (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1))))
          (entmake (list (cons 0 "LINE")
    		     (cons 10 (trans p1 1 0))
    		     (cons 11 (trans p2 1 0))
    	       )
          )
         (vla-AddText spc (strcat (rtos (abs (* tan2 100)) 2 2) "%") (vlax-3d-point (trans p3 1 0))  (/ (getvar 'TEXTSIZE) (getvar 'cannoscalevalue)))
    	
        )
        (progn
          (prompt "\n select a line : ")
          (setq TL-Line (ssget '((0 . "LINE"))))
          (setq e (ssname TL-Line 0))
          (setq p1 (cdr (assoc 10 (entget e))))
          (setq p2 (cdr (assoc 11 (entget e))))
          (setq p3 (getpoint "\n pick a point : "))
          (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1))))
          (vla-AddText spc (strcat (rtos (abs (* tan2 100)) 2 2) "%") (vlax-3d-point (trans p3 1 0))  (/ (getvar 'TEXTSIZE) (getvar 'cannoscalevalue)))
    	
        )
      )
      (setq TH:UnDo (vla-EndUndoMark Doc))
      (princ "\n ")
      (princ)
    )
    Thanks

  2. #2
    Super Member hanhphuc's Avatar
    Using
    AutoCAD 2007
    Join Date
    Apr 2013
    Location
    Happy Garden
    Posts
    529

    Default

    similar old thread?
    it has minor bug haven't fixed cant test now, enjoying oldtown white coffee at the moment
    lambda not optimized.. ( apply '= "hp" "happy" "hạnh phúc" "ハッピー" "幸福" "행복" ) ; error: too many arguments

  3. #3
    Super Member prodromosm's Avatar
    Using
    AutoCAD 2014
    Join Date
    Jul 2010
    Posts
    604

    Default

    I want to ask a question. when i piick points at the end create a line and a text with the slope.I don't want the line , but i can not find what to delete in the code.Can any one help?

    i think is

    Code:
     (entmake (list (cons 0 "LINE")
    		     (cons 10 (trans p1 1 0))
    		     (cons 11 (trans p2 1 0))
    	       )
          )
    but is not working

    thanks

  4. #4
    Luminous Being
    Using
    Civil 3D 2016
    Join Date
    Dec 2005
    Location
    GEELONG AUSTRALIA
    Posts
    9,508

    Default

    I have a version works with lines and plines.

    Code:
    ; xfall as a percentage 
    ; Modified to work with plines 
    ; By Alan H July 2017
    
    ;(defun trap (errmsg)
    ;  (prompt "\nAn error has occured.")
    ;  (command "undo" "b")
    ;  (setvar "osmode" os)
    ;  (setq *error* temperr)
    ;)
    
    (defun rtd (a)(/ (*  a 180.0) pi))
    (setvar "TEXTSTYLE" "STANDARD")
    ; cross fall as a percentage 
    ; modified to recognise a pline
    ; By Alan H July 2017
    (defun c:xfallper ( / pt1 pt2 pt3 pt4 )
    (setvar "cmdecho" 0)
    
    (SETQ ANGBASEE (GETVAR "ANGBASE"))
    (SETQ ANGDIRR (GETVAR "ANGDIR"))
    (SETQ LUNITSS (GETVAR "LUNITS"))
    (SETQ LUPRECC (GETVAR "LUPREC"))
    (SETQ AUNITSS (GETVAR "AUNITS"))
    (SETQ AUPRECC (GETVAR "AUPREC"))
    
    (SETVAR "LUNITS" 2)
    (SETVAR "ANGBASE" 0.0)
    (SETVAR "ANGDIR" 0)
    (SETVAR "LUPREC" 3)
    (SETVAR "AUNITS" 0)
    (SETVAR "AUPREC" 3)
    
    (setq os (getvar "osmode"))
    (setvar "osmode" 0)
    
    (if (= horiz nil)
    (progn
    (if (not AH:getval3)(load "getvals3"))
    (ah:getval3 "Enter Horizontal scale " 5 4 "100" "Enter Vertical scale" 5 4 "50" "Enter number of decimal places" 5 4 "2")
    (setq horiz (atof val1))
    (setq vert (atof val2))
    (setq prec (atoi val3))
    )
    )
    
    (alert "Pick lines or plines")
    
    (while (setq s (entsel "Select line"))
    (setq objname (cdr (assoc 0 (entget (car s)))))
    
    (if (=  objname  "LWPOLYLINE")
    (progn
    (setq pr (vlax-curve-getparamatpoint (car s) (setq p (vlax-curve-getclosestpointto (car s) (cadr s)))))
    (setq pt1 (vlax-curve-getpointatparam (car s) (fix pr)))
    (setq pt2 (vlax-curve-getpointatparam (car s) (1+ (fix pr))))
    (setq found "Y")
    )
    )
    
    (if (=  objname  "LINE")
    (progn
    (setq pt1 (cdr (assoc 10 (entget (car s)))))
    (setq pt2 (cdr (assoc 11 (entget (car s)))))
    (setq found "Y")
    )
    )
    
    (if (= Found nil)
    (progn
    (alert "Do again object has no slope")
    (exit)
    )
    )
    
    (setq pt1x (car pt1))
    (setq pt1y (cadr pt1))
    (setq pt2x (car pt2))
    (setq pt2y (cadr pt2))
    
    (setq ydist (abs (- pt1y pt2y)))
    (setq xdist (abs (- pt1x pt2x)))
    (setq xfall (strcat (rtos  (* (/ (* ydist vert) (* xdist horiz)) 100) 2 prec) "%") )
    (setq ang (angle pt1 pt2))
    (setq dist (distance pt1 pt2))
    (if (> dist 0)
    (progn 
    (setq halfdist (/ dist 2))
    (setq pt3 (polar pt1 ang halfdist))
    (if (> ang pi) (setq ang (- ang pi)))
    (if (> ang (/ pi 2)) (setq pt4ang (- ang (/ pi 2))) (setq pt4ang (+ ang (/ pi 2))))
    (setq pt4 (polar pt3 pt4ang 0.75))
    (if (> ang (/ pi 2)) (setq ang (+ ang pi)))
    (setq tang (rtd ang)) 
    )
    )
    (command "TEXT" pt4 2.5 tang xfall "")
    (setq s nil)
    
    ) ;while
    ;  (setvar "DIMZIN" dimz)
    (setvar "cmdecho" 1)
    (setvar "osmode" os)
    ;  (setq *error* temperr)
    (SETVAR "LUNITS" lunitss)
    (SETVAR "ANGBASE" angbasee)
    (SETVAR "ANGDIR" angdirr)
    (SETVAR "LUPREC" luprecc)
    (SETVAR "AUNITS" aunitss)
    (SETVAR "AUPREC" auprecc)
    
    
    (princ)
    ) ;defun
    Attached Files
    A man who never made mistakes never made anything

  5. #5
    Super Member prodromosm's Avatar
    Using
    AutoCAD 2014
    Join Date
    Jul 2010
    Posts
    604

    Default

    Sorry Biggal is not working

  6. #6
    Senior Member
    Using
    not applicable
    Join Date
    Oct 2014
    Posts
    148

    Default

    prodromosm, did you load the attached file (GETVALS3.lsp) that BIGAL shows above? The program won't work without it.
    BricsCAD V15

  7. #7
    Super Member prodromosm's Avatar
    Using
    AutoCAD 2014
    Join Date
    Jul 2010
    Posts
    604

    Default

    Yes i load them from tha same path.But is not working. I am using Autocad 2017

  8. #8
    Senior Member
    Using
    not applicable
    Join Date
    Oct 2014
    Posts
    148

    Default

    Hmmm... well, I'm sure BIGAL will respond to this thread when he gets time. In the meantime, I'll throw this one out there. I use it when I just want the slope between two points. Could be a line, pline or any two points selected.

    Just something else to look at.

    Code:
    ;; Run this program by picking two points and using them to define the slope of the line.
    ;;
    ;; Program by BKT (Sept. 2007)
    ;;
    ;; 8/7/2017 - Modified to use and reset current TEXTANGLE.
    ;; 8/13/2017 - Modified to use PER MILLE "\U+2030" symbol instead of "%" where applicable.
    ;;
    
    (defun C:slpe (/ osm pt1 pt2 d1 d2 rise run rmid1 rmid2 mid percenttext slope angdeg tngl)
    
    (setq tngl (getvar "TEXTANGLE"))
    (setq osm (getvar "osmode"))
    
    ;;Error handler
     (setq olderr *error*)
     (defun *error* (msg)
       (if (or
             (= msg "Function canceled")
             (= msg "quit / exit abort")
           )
         ;;if user canceled or program aborted, exit quietly
         (princ)
         ;;otherwise report error message
         (princ (strcat "\nError: " msg))
       )
      (prompt "\n Program Terminated")
      (setvar "osmode"osm)
      (princ)
    )
    
    (setvar "cmdecho" 0) 
       (setq pt1 (getpoint "\nPick Start Point: ")
             pt2 (getpoint "\nPick End Point: ")
             d1 (/ (distance pt1 pt2) 12)
             d2 (rtos d1 2 2)
             rise (- (cadr pt2) (cadr pt1)) run (- (car pt2) (car pt1))
             rmid1 (/ (+ (car pt2) (car pt1)) 2) rmid2 (/ (+ (cadr pt1) (cadr pt2)) 2)
             mid (strcat (rtos rmid1) "," (rtos rmid2))
       )
    
    (IF (= (- (car pt2) (car pt1)) 0.00) (alert "\nAngle Equals 90 Degrees!"))
    
    (setq slope (/ rise run)
          angdeg (angtos (atan rise run) 1 4)
    )
    
    (IF (< slope 0.01)
          (setq percenttext (strcat (rtos (* 1000 slope) 2 2) "\U+2030"))
          (setq percenttext (strcat (rtos (* 100 slope) 2 2) "%"))
    )
    
    (setvar "osmode" 0)
    
    (command "TEXT" "J" "BC" mid (getvar "TEXTSIZE") angdeg percenttext)
    
    (setvar "TEXTANGLE" tngl)
    (setvar "osmode" osm)
    (princ)
    )
    Edit: Never mind - recent changes make this only work properly in the positive quadrant. I'll look at it again when I get a minute.
    Last edited by BKT; 14th Aug 2017 at 05:23 pm. Reason: Code Change Pending
    BricsCAD V15

  9. #9
    Luminous Being
    Using
    Civil 3D 2016
    Join Date
    Dec 2005
    Location
    GEELONG AUSTRALIA
    Posts
    9,508

    Default

    I copied and pasted from the forum the code and it worked fine.

    Did this pop up ? The code allows for slopes on cross and long sections rather than 2 3d points. If its not scaled just set the hor and vertical to 100
    Attached Images
    A man who never made mistakes never made anything

  10. #10
    Luminous Being
    Using
    Civil 3D 2016
    Join Date
    Dec 2005
    Location
    GEELONG AUSTRALIA
    Posts
    9,508

    Default

    Registered forum members do not see this ad.

    BKT maybe look at the angle between the two points, if you set to say radians then zero direction right you know which quadrant your in so can reverse angle etc and then convert to slope. Other way is to reverse the two points using a check on x1-x2 is it + or -, went left or right, same with Y1-Y2.
    A man who never made mistakes never made anything

Similar Threads

  1. Slope+Batter+Slope+Sign
    By dunnixi in forum AutoLISP, Visual LISP & DCL
    Replies: 3
    Last Post: 6th Oct 2014, 09:36 am
  2. Replies: 6
    Last Post: 2nd Jul 2013, 02:37 pm
  3. Slope in MEP 2010 (no slope)
    By Don Collins in forum MEP
    Replies: 9
    Last Post: 12th Jan 2012, 08:59 pm
  4. slope lisp needed
    By NH3man! in forum AutoLISP, Visual LISP & DCL
    Replies: 70
    Last Post: 23rd Jun 2011, 07:17 pm
  5. Slope / Invert Lisp Routine?
    By mcklem in forum AutoLISP, Visual LISP & DCL
    Replies: 2
    Last Post: 20th Oct 2009, 12:50 am

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts