帮助学习斜坡Lisp程序

prodromosm · 发表于 2022-7-5 16:07:26

你好我正在使用此代码，但我需要做一些更改

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-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)
)

谢谢

hanhphuc · 发表于 2022-7-5 16:13:27

类似的旧线程？
它有一个小错误，现在还没有修复不能测试，正在享受oldtown白咖啡

prodromosm · 发表于 2022-7-5 16:21:01

我想问一个问题。当我点击末端的点时，创建一条线和一个带有坡度的文本。我不想要这行，但我在代码中找不到要删除的内容。有人能帮忙吗？

我想是的

copy

 (entmake (list (cons 0 "LINE")
             (cons 10 (trans p1 1 0))
             (cons 11 (trans p2 1 0))
       )
     )

但不起作用

谢谢

BIGAL · 发表于 2022-7-5 16:24:33

我有一个版本的作品与线和普林斯。

copy


; 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