worknet Posted December 22, 2010 Posted December 22, 2010 Hello im new on this, i just whant help for a lisp routine that draw a slope. I already try a lot of them but doesnt work correctly. Thank´s Quote
ReMark Posted December 22, 2010 Posted December 22, 2010 Could you provide us with more detail please? And be as specific as possible. Thank you. Quote
worknet Posted December 22, 2010 Author Posted December 22, 2010 Ok, i try many routines but they bring the message "this is not a polyline" but in fact the line that i indicate was a polyline. Quote
asos2000 Posted December 22, 2010 Posted December 22, 2010 Give this a try Code: ;|--------------Inclination of line------------------- q_|_|| _\|| q_|| _\| يقوم بتحديد ميل الخط من خلال اختيار نقطتين عليه و من الممكن ان يختار المستخدم بين ان يرسم خط بين النقطتين او لا ------------------------------------------------------ Author: Hasan M. Asous, 2010 Copyright © 2010 by HasanCAD, All Rights Reserved. Contact: HasanCAD @ TheSwamp.org, asos2000 @ CADTutor.net [email="HasanCAD@gmail.com"]HasanCAD@gmail.com[/email] ------------------------------------------------------ Version: 1 20 Oct 2010 ____________________________________________________|; ; q_|_|| _\|| q_|| _\| ; ; Mainroutine Start ; (defun c:TanLine (/ p1 p2 p3) ; @ HasanCAD (vl-load-com) (HSN:DDwnMnuSetSysVar) (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))) ) (if (not TL-sel) (setq TL-sel "Points")) (initget "select Line or Points") (setq TL-sel (cond ( (getkword (strcat "\nChoose هل تريد تحديد خط او اختيار نقطتين [Line/Points] <" TL-sel ">: ") ) ) ( TL-sel ) )) (if (equal TL-sel "Points") (progn (and (setq p1 (trans (getpoint "\nFirst Point اختار النقطة الاولى على الخط ")1 0)) (setq p2 (trans (getpoint p1 "\nSecond Point اختار النقطة الثانية على الخط")1 0)) (setq p3 (trans (getpoint "\nText insertion Point قم بتحديد مكان النص")1 0)) ) (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1)))) (IF (< 1000 (ABS (- (cadr p2) (cadr p1)))) (setq h 220) (if (< 100 (ABS (- (cadr p2) (cadr p1)))) (setq h 22) (setq h 2.2))) (if (not TL-Line) (setq TL-Line "Yes")) (initget "Yes No") (setq TL-Line (cond ( (getkword (strcat "\nChoose هل تريد رسم خط بين النقطتين [Yes/No] <" TL-Line ">: ") ) ) ( TL-Line ) )) (if (equal TL-Line "Yes") (progn (HSN:TL-Text h) (HSN:TL-Line) ) (progn (HSN:TL-Text h) ) ) ) (progn (setq TL:SS (entget (car (entsel)))) (if (and (equal TL-sel "Line") (equal (cdr (assoc 0 TL:SS)) "LINE") ) (Progn (setq p1 (cdr (assoc 10 TL:SS))) (setq p2 (cdr (assoc 11 TL:SS))) (setq p3 (trans (getpoint "\nText insertion Point قم بتحديد مكان النص")1 0)) (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1)))) (HSN:TL-Text) ) (progn (princ "\n PLease Seect a line or Points") ) ) ) ) (HSN:ReDDwnMnuSetSysVar) (vla-EndUndoMark ActDoc) ) ; q_|_|| _\|| q_|| _\| ; ; Mainroutine End ; ; q_|_|| _\|| q_|| _\| ; ; Subroutine Start ; (defun *error* (msg) (and uFlag (vla-EndUndoMark doc)) (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\n** Error: " msg " **"))) (princ) ) (defun HSN:DDwnMnuSetSysVar () ; @ HasanCAD (setq OldOS (getvar "osmode")) (setq OldDynmode (getvar "dynmode")) (setq OldDynprompt (getvar "dynprompt")) (setvar "osmode" 33) (setvar "dynmode" 1) (setvar "dynprompt" 1) (setvar "cmdecho" 0) ) (defun HSN:ReDDwnMnuSetSysVar () ; @ HasanCAD (setq *error* TERR$) (setvar "osmode" OldOS) (setvar "dynmode" OldDynmode) (setvar "dynprompt" OldDynprompt) ) (defun HSN:TL-Text (H) ; @ HasanCAD (entmakex (list (cons 0 "TEXT") (cons 10 p3) (cons 40 H) (cons 1 (strcat (rtos (abs (* tan2 100))2 2) "%")) )) ) (defun HSN:TL-Line () ; @ HasanCAD (entmake (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2) )) ) ; q_|_|| _\|| q_|| _\| ; ; Subroutine End ; (princ "\n TanLine.lsp ~ Copyright © by HasanCAD") (princ "\n ...Type TanLine to Invoke... ") (princ) Quote
Tharwat Posted December 22, 2010 Posted December 22, 2010 asos2000 said: Give this a try Code: ;|--------------Inclination of line------------------- q_|_|| _\|| q_|| _\| يقوم بتحديد ميل الخط من خلال اختيار نقطتين عليه و من الممكن ان يختار المستخدم بين ان يرسم خط بين النقطتين او لا ------------------------------------------------------ Author: Hasan M. Asous, 2010 Copyright © 2010 by HasanCAD, All Rights Reserved. Contact: HasanCAD @ TheSwamp.org, asos2000 @ CADTutor.net [email="HasanCAD@gmail.com"]HasanCAD@gmail.com[/email] ------------------------------------------------------ Version: 1 20 Oct 2010 ____________________________________________________|; ; q_|_|| _\|| q_|| _\| ; ; Mainroutine Start ; (defun c:TanLine (/ p1 p2 p3) ; @ HasanCAD (vl-load-com) (HSN:DDwnMnuSetSysVar) (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))) ) (if (not TL-sel) (setq TL-sel "Points")) (initget "select Line or Points") (setq TL-sel (cond ( (getkword (strcat "\nChoose هل تريد تحديد خط او اختيار نقطتين [Line/Points] <" TL-sel ">: ") ) ) ( TL-sel ) )) (if (equal TL-sel "Points") (progn (and (setq p1 (trans (getpoint "\nFirst Point اختار النقطة الاولى على الخط ")1 0)) (setq p2 (trans (getpoint p1 "\nSecond Point اختار النقطة الثانية على الخط")1 0)) (setq p3 (trans (getpoint "\nText insertion Point قم بتحديد مكان النص")1 0)) ) (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1)))) (IF (< 1000 (ABS (- (cadr p2) (cadr p1)))) (setq h 220) (if (< 100 (ABS (- (cadr p2) (cadr p1)))) (setq h 22) (setq h 2.2))) (if (not TL-Line) (setq TL-Line "Yes")) (initget "Yes No") (setq TL-Line (cond ( (getkword (strcat "\nChoose هل تريد رسم خط بين النقطتين [Yes/No] <" TL-Line ">: ") ) ) ( TL-Line ) )) (if (equal TL-Line "Yes") (progn (HSN:TL-Text h) (HSN:TL-Line) ) (progn (HSN:TL-Text h) ) ) ) (progn (setq TL:SS (entget (car (entsel)))) (if (and (equal TL-sel "Line") (equal (cdr (assoc 0 TL:SS)) "LINE") ) (Progn (setq p1 (cdr (assoc 10 TL:SS))) (setq p2 (cdr (assoc 11 TL:SS))) (setq p3 (trans (getpoint "\nText insertion Point قم بتحديد مكان النص")1 0)) (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1)))) (HSN:TL-Text) ) (progn (princ "\n PLease Seect a line or Points") ) ) ) ) (HSN:ReDDwnMnuSetSysVar) (vla-EndUndoMark ActDoc) ) ; q_|_|| _\|| q_|| _\| ; ; Mainroutine End ; ; q_|_|| _\|| q_|| _\| ; ; Subroutine Start ; (defun *error* (msg) (and uFlag (vla-EndUndoMark doc)) (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*") (princ (strcat "\n** Error: " msg " **"))) (princ) ) (defun HSN:DDwnMnuSetSysVar () ; @ HasanCAD (setq OldOS (getvar "osmode")) (setq OldDynmode (getvar "dynmode")) (setq OldDynprompt (getvar "dynprompt")) (setvar "osmode" 33) (setvar "dynmode" 1) (setvar "dynprompt" 1) (setvar "cmdecho" 0) ) (defun HSN:ReDDwnMnuSetSysVar () ; @ HasanCAD (setq *error* TERR$) (setvar "osmode" OldOS) (setvar "dynmode" OldDynmode) (setvar "dynprompt" OldDynprompt) ) (defun HSN:TL-Text (H) ; @ HasanCAD (entmakex (list (cons 0 "TEXT") (cons 10 p3) (cons 40 H) (cons 1 (strcat (rtos (abs (* tan2 100))2 2) "%")) )) ) (defun HSN:TL-Line () ; @ HasanCAD (entmake (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2) )) ) ; q_|_|| _\|| q_|| _\| ; ; Subroutine End ; (princ "\n TanLine.lsp ~ Copyright © by HasanCAD") (princ "\n ...Type TanLine to Invoke... ") (princ) Your routine is not returning the Dynamic Input as it was adjusted before . And the option for Points is not working at the first time you start the routine . An error return at the end of the routine ... Quote Command: TANLINE Choose ?? ???? ????? ?? ?? ?????? ?????? [Line/Points] : P First Point ????? ?????? ?????? ??? ???? Second Point ????? ?????? ??????? ??? ???? Text insertion Point ?? ?????? ???? ???? Choose ?? ???? ??? ?? ??? ???????? [Yes/No] : ; error: bad argument type: VLA-OBJECT nil Why do not you rotate the insertion text according to line rotation slope or selected points . Quote
Tharwat Posted December 22, 2010 Posted December 22, 2010 And also all the following system variables are not re-set as they were before . (setvar "osmode" 33) (setvar "dynmode" 1) (setvar "dynprompt" 1) (setvar "cmdecho" 0) Please recheck your routine once again . Thanks. Tharwat Quote
asos2000 Posted December 23, 2010 Posted December 23, 2010 Thanks Tharwat for your reply Could you please help me for fixing this error Second comment I can handle Thanks Quote
Tharwat Posted December 23, 2010 Posted December 23, 2010 asos2000 said: Thanks Tharwat for your reply Could you please help me for fixing this error Second comment I can handle Thanks You're welcome . Check this out , Do not hesitate to ask if you have any question . (defun c:TanLine (/ doc spc *error* TH:UnDo TH:StartUnDo p1 p2 p3 tan2 TL-Line TH:UnDo) (vl-load-com) (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 "\nChoose [Line/Points]: " "< Line >"))) "Points") (progn (setq p1 (getpoint "\n First Point ")) (setq p2 (getpoint p1 "\n Second Point ")) (setq p3 (getpoint "\n Text insertion 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)))) (entmake (list (cons 0 "TEXT")(cons 10 (trans p3 1 0)) (cons 40 (getvar 'textsize)) (cons 1 (strcat (rtos (abs (* tan2 100))2 2) "%")))) ) (progn (prompt "\n please Select 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 "\nText insertion Point ")) (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1)))) (entmake (list (cons 0 "TEXT")(cons 10 (trans p3 1 0)) (cons 40 (getvar 'textsize)) (cons 1 (strcat (rtos (abs (* tan2 100))2 2) "%")))) ) ) (setq TH:UnDo (vla-EndUndoMark Doc)) (princ "\n Modified by Tharwat") (princ) ) Enjoy the codes. Tharwat Quote
Guest athabe Posted October 6, 2011 Posted October 6, 2011 (edited) The code is wonderful it give you the correct answer (slope reading) Can I wish to get the answer in 4 decimals and in option of inserting the text or showing message for the reading. Thanks Edited October 6, 2011 by athabe It is accurate Quote
Tharwat Posted October 6, 2011 Posted October 6, 2011 athabe said: The code is wonderful it give you the correct answer (slope reading) Can I wish to get the answer in 4 decimals and in option of inserting the text or showing message for the reading. Thanks Which routine you have used and worked for you ? ( the post number ) Quote
Guest athabe Posted October 6, 2011 Posted October 6, 2011 thanks for the quick reply it was #8 Quote
Tharwat Posted October 6, 2011 Posted October 6, 2011 athabe said: The code is wonderful it give you the correct answer (slope reading) Can I wish to get the answer in 4 decimals and in option of inserting the text or showing message for the reading. Thanks Here it goes with four decimals .. (defun c:TanLine (/ doc spc *error* TH:UnDo TH:StartUnDo p1 p2 p3 tan2 TL-Line TH:UnDo) ;;; Authour : Hasan Asos -> Modified by Tharwat (vl-load-com) (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 "\nChoose [Line/Points]: " "< Line >"))) "Points") (progn (setq p1 (getpoint "\n First Point ")) (setq p2 (getpoint p1 "\n Second Point ")) (setq p3 (getpoint "\n Text insertion 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)))) (entmake (list (cons 0 "TEXT")(cons 10 (trans p3 1 0)) (cons 40 (getvar 'textsize)) (cons 1 (strcat (rtos (abs (* tan2 100)) 2 4) "%")))) ) (progn (prompt "\n please Select 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 "\nText insertion Point ")) (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1)))) (entmake (list (cons 0 "TEXT")(cons 10 (trans p3 1 0)) (cons 40 (getvar 'textsize)) (cons 1 (strcat (rtos (abs (* tan2 100)) 2 4) "%")))) ) ) (setq TH:UnDo (vla-EndUndoMark Doc)) (princ "\n Modified by Tharwat") (princ) ) Quote
Organic Posted October 8, 2011 Posted October 8, 2011 In reality though no contractor is going to be able to grade a site to 4 d.p. accuracy even when using gps machine controlled technology. Quote
ketxu Posted October 8, 2011 Posted October 8, 2011 @Tharwat : you don't catch error with Divide by zero, if Line or two point is same x ^^ (may be 90degree slope or 100% ^^) Quote
Tharwat Posted October 8, 2011 Posted October 8, 2011 ketxu said: @Tharwat : you don't catch error with Divide by zero, if Line or two point is same x ^^ (may be 90degree slope or 100% ^^) You're right , I have just modified the code for the author to let it works only without paying any consideration to the code itself , and when athabe asked me to modify the decimal numbers , I have just corrected for him . So I do not have the right to play with code . Thank you Quote
Guest Posted November 11, 2013 Posted November 11, 2013 Tharwat said: You're welcome . Check this out , Do not hesitate to ask if you have any question . (defun c:TanLine (/ doc spc *error* TH:UnDo TH:StartUnDo p1 p2 p3 tan2 TL-Line TH:UnDo) (vl-load-com) (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 "\nChoose [Line/Points]: " "< Line >"))) "Points") (progn (setq p1 (getpoint "\n First Point ")) (setq p2 (getpoint p1 "\n Second Point ")) (setq p3 (getpoint "\n Text insertion 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)))) (entmake (list (cons 0 "TEXT")(cons 10 (trans p3 1 0)) (cons 40 (getvar 'textsize)) (cons 1 (strcat (rtos (abs (* tan2 100))2 2) "%")))) ) (progn (prompt "\n please Select 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 "\nText insertion Point ")) (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1)))) (entmake (list (cons 0 "TEXT")(cons 10 (trans p3 1 0)) (cons 40 (getvar 'textsize)) (cons 1 (strcat (rtos (abs (* tan2 100))2 2) "%")))) ) ) (setq TH:UnDo (vla-EndUndoMark Doc)) (princ "\n Modified by Tharwat") (princ) ) Enjoy the codes. Tharwat Tharwat can you change the the text style to wgsimpl.shx I try to add this command in your code but i do something wrong (command "style" "TanLine" "wgsimpl.shx" "" "" "" "" "") Quote
satishrajdev Posted November 11, 2013 Posted November 11, 2013 prodromosm try this :- (defun c:TanLine (/ doc spc *error* TH:UnDo TH:StartUnDo p1 p2 p3 tan2 TL-Line TH:UnDo) ;;; Authour : Hasan Asos -> Modified by Tharwat (vl-load-com) (command "-style" "wgsimpl.shx" 0 1 0 "N" "N") (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 "\nChoose [Line/Points]: " "< Line >"))) "Points") (progn (setq p1 (getpoint "\n First Point ")) (setq p2 (getpoint p1 "\n Second Point ")) (setq p3 (getpoint "\n Text insertion 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)))) (entmake (list (cons 0 "TEXT")(cons 10 (trans p3 1 0)) (cons 40 (getvar 'textsize)) (cons 7 "TanLine") (cons 1 (strcat (rtos (abs (* tan2 100)) 2 4) "%")))) ) (progn (prompt "\n please Select 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 "\nText insertion Point ")) (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1)))) (entmake (list (cons 0 "TEXT")(cons 10 (trans p3 1 0)) (cons 40 (getvar 'textsize)) (cons 7 "TanLine") (cons 1 (strcat (rtos (abs (* tan2 100)) 2 4) "%")))) ) ) (setq TH:UnDo (vla-EndUndoMark Doc)) (princ "\n Modified by Tharwat") (princ) ) Quote
Guest Posted November 11, 2013 Posted November 11, 2013 Thank you satishrajdev I use this (command "-style" "TanLine" "wgsimpl.shx" 0 1 0 "N" "N") and work fine Quote
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.