Jump to content

Recommended Posts

I Have lisp for placing slope and arrow with polyline 

and i want enhance this to what i need mention in my drawing file..so i have attached lisp & sample drawing file .

and also want to enhance lisp for select all polyline at once, currently lisp select on object at once.

thanks. 

 

Slope.lsp SLOPE SAMPLE.dwg

Edited by Prageeth
Link to post
Share on other sites

Have a look at this, yes it does 1 at a time now but could be changed pretty easy to do all pline sections. Needs multi getvals takes into account hor and ver scales.Multi GETVALS.lsp

 

; 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 ans pr pt1x pt1y pt2x pt2 ans) 
(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" 3)
(SETVAR "AUPREC" 3)
 
(setq os (getvar "osmode"))
(setvar "osmode" 0)
 
(if (= horiz nil)
(progn
(if (not AH:getvalsm)(load "Multi getvals"))
(setq ans (ah:getvalsm (list "Xfall per by %" "Enter Horizontal scale " 5 4 "100" "Enter Vertical scale" 5 4 "50" "Enter number of decimal places" 5 4 "2")))
(setq horiz (atof (nth 0 ans)))
(setq vert (atof (nth 1 ans)))
(setq prec (atoi (nth 2 ans)))
)
)
 
(alert "Pick lines or plines")
 
(while (setq s (entsel "Select line pick nothing to exit"))
(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 cursty (getvar 'textstyle))
(setq tsty (vla-get-textstyles (vla-get-activedocument (vlax-get-acad-object))))
(vlax-for ent tsty
(if (= (vla-get-name ent) cursty)
(setq txtht (vla-get-height ent))
)
)

(if (= txtht 0.0)
(command "TEXT" pt4 2.5 ang xfall)
(command "TEXT" pt4 ang xfall )
)

(setq s nil)
 
) 
;  (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

 

Link to post
Share on other sites

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.

Guest
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...