帮助学习斜坡口齿不清
你好我正在使用此代码，但我需要做一些更改1） 我希望文本自动插入到行的中间（在带有小空格的行上方）
2） 该代码计算斜率%。如果斜率为0.02 wrte 2%，但如果斜率为0002%，则写入0.2%。我想写2‰。
(defun c:TanLineanot(/ doc spc *error*TH:UnDo
TH:StartUnDo p1 p2 p3 scl ht
tan2 TL-LineTH: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"
)
(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)
)
谢谢 类似的旧线程？
它有一个小错误，现在还没有修复不能测试，正在享受oldtown白咖啡 我想问一个问题。当我点击末端的点时，创建一条线和一个带有坡度的文本。我不想要这行，但我在代码中找不到要删除的内容。有人能帮忙吗？
我想是的
(entmake (list (cons 0 "LINE")
(cons 10 (trans p1 1 0))
(cons 11 (trans p2 1 0))
)
)
但不起作用
谢谢 我有一个版本的作品与线和普林斯。
; 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
GETVALS3.lsp 抱歉Biggal不工作 prodromosm，你加载了上面显示的附加文件（GETVALS3.lsp）了吗？没有它，这个程序就无法运行。 是的，我从同一条路径加载它们。但不起作用。我正在使用Autocad 2017 六羟甲基三聚氰胺六甲醚。。。嗯，我相信比格尔有时间的时候会回复这个帖子。同时，我会把这个扔出去。当我只需要两点之间的斜率时，我就使用它。可以是一条直线、一条直线或任意选定的两点。
只是看看别的。
编辑：没关系-最近的更改使其仅在正象限中正常工作。等我有时间再看一遍。 我从论坛上复制并粘贴了代码，效果很好。
这个出现了吗？该代码允许横截面和长截面上的坡度，而不是2个3d点。如果没有缩放，只需将hor和vertical设置为100
BKT可能会看两点之间的角度，如果你设置为弧度，那么零方向正确，你知道你在哪个象限，所以可以反转角度等，然后转换为斜率。另一种方法是使用x1-x2上的检查反转这两个点，它是+还是-，向左还是向右，与Y1-Y2相同。
页:
[1]
2