(if(null vlax-dump-object)(VL-load-com))
(如果(null & ampmod)(setq & amp；mod(vla-get-model space(vla-get-active document(vlax-get-acad-object))))
(if(setq & amp；len(ent sel " \ n選擇要測量其斜率的線段"))
(程序
(setq @ pts(cadr & amp；len)& amp；len (vlax-ename->vla-對象(汽車& amplen)))
(setq @ PTO(vlax-curve-getclosestpointto & amp；len @pts))
(setq @ pt 1(vlax-curve-getclosestpointto & amp；len(polar @ pts(* pi 0.5)0.001)))
(setq @ pt2(vlax-curve-getclosestpointto & amp；len(polar @ pts(* pi 1.5)0.001)))
(setq #ang(最小(角度@pt1 @pt2)(角度@pt2 @pt1)))
(setq # j T & ampmte零& amp零)
(而#j
(setq @ jj(grread 1 4 1)# j(car @ jj)@ j(cadr @ jj))
(條件
((= #j 5) ($dq-moveaction))
((= #j 3) ($dq-clickleft))
((= #j 12) ($dq-clickright))
)
)
)
)
(princ)
)
(defun $dq-clickleft()
(setq # j nil)(princ“OK！”)
)
(defun $dq-clickright()
(如果(並且& ampmte(null(vlax-erased-p & amp；mte)))
(vla-erase & amp；mte)
)
(如果(並且& amplea(null(vlax-erased-p & amp；lea)))
(vla-erase & amp；lea)
)
(setq #j nil) (princ "取消！")
)
(defun $ dq-領先點(pts / lis dou)
(setq lis(apply ' append(mapcar)(lambda(x)(list(car x)(cadr x)(caddr x)))pts))
(setq dou(vlax-make-safe array vlax-VB double(cons 0(1-(* 3(長度pts)))))
(vlax-make-variant(vlax-safe array-fill dou lis))
)
(defun $dq-moveaction()
(如果(& gt(setq # ang(/(* # ang 180)pi))90)
(setq #ang (- 180 #ang))
)
(如果(或(null & ampvlax-erased-p & amp；mte))
(setq & ampmte(vla-addmtext & amp；mod(vlax-3d-point @ j)0(strcat(RTOS # ang 2 3)" % % D "))
(vla-put-insertion point & amp；mte (vlax-3d點@j))
)
(如果(& gt(car @j) (car @pto))
(如果(& lt(cadr @j) (cadr @pto))
(如果(& gt(角度@pto @j)(角度@j @pto))
(vla-put-attachment point & amp；mte 4)
(vla-put-attachment point & amp；mte 6)
)
(如果(& lt(角度@pto @j)(角度@j @pto))
(vla-put-attachment point & amp；mte 4)
(vla-put-attachment point & amp；mte 6)
)
)
(如果(& gt(cadr @j) (cadr @pto))
(如果(& gt(角度@pto @j)(角度@j @pto))
(vla-put-attachment point & amp；mte 4)
(vla-put-attachment point & amp；mte 6)
)
(如果(& lt(角度@pto @j)(角度@j @pto))
(vla-put-attachment point & amp；mte 4)
(vla-put-attachment point & amp；mte 6)
)
)
)
(如果(或(null & amp(vlax-erased-p & amp；lea))
(setq & amplea(vla-addleader & amp；mod($ dq-leader point(list @ PTO @ j))& amp；mte aclinewitharrow))
(vla-put-坐標& amplea ($dq-leaderpoint (list @pto @j)))
)
(vla-put-verticaltextposition & amp；lea 0)
(vla-更新& amplea)
)
；；；新建壹個記事本文件，復制上面的代碼，保存為dq.lsp，加載到CAD中，運行命令dq即可。樓上的節目可能更好，我自己發壹個來出醜。以上代碼可供親測，但必須在CAD版本CAD2000或以上運行。