[编程交流] 计算a的倾角

(defun c:DIP&Len ( / v^v unit mxv transptucs transptwcs ss pe pa ent p1 p2 l vd vx vy p1u p2u p1up p2up p1p p2p lp pl p ps ph dip )
 (vl-load-com)
 (defun v^v ( u v )
   (mapcar '(lambda ( s1 s2 a b ) (+ ((eval s1) (* (nth a u) (nth b v))) ((eval s2) (* (nth a v) (nth b u))))) '(+ - +) '(- + -) '(1 0 0) '(2 2 1))
 )
 (defun unit ( v )
   (mapcar '(lambda ( x ) (/ x (distance '(0.0 0.0 0.0) v))) v)
 )
 (defun mxv ( m v )
   (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
 )
 (defun transptucs ( pt p1 p2 p3 / ux uy uz )
   (setq uz (unit (v^v (mapcar '- p2 p1) (mapcar '- p3 p1))))
   (setq ux (unit (mapcar '- p2 p1)))
   (setq uy (unit (mapcar '- p3 p1)))
   
   (mxv (list ux uy uz) (mapcar '- pt p1))
 )
 (defun transptwcs ( pt pt1 pt2 pt3 / pt1n pt2n pt3n )
   (setq pt1n (transptucs '(0.0 0.0 0.0) pt1 pt2 pt3))
   (setq pt2n (transptucs '(1.0 0.0 0.0) pt1 pt2 pt3))
   (setq pt3n (transptucs '(0.0 1.0 0.0) pt1 pt2 pt3))
   (transptucs pt pt1n pt2n pt3n)
 )
 (prompt "\nPick Line entity or straight segment of polyline to calculate DIP (angle) to current view and Lenght of its projection & its real Length")
 (setq ss (ssget "_+.:E:S" '((0 . "LINE,*POLYLINE"))))
 (if (and ss (wcmatch (cdr (assoc 0 (entget (ssname ss 0)))) "*POLYLINE"))
   (progn
     (setq pe (vlax-curve-getclosestpointtoprojection (ssname ss 0) (cadr (cadddr (car (ssnamex ss)))) '(0.0 0.0 1.0)))
     (setq pa (vlax-curve-getparamatpoint (ssname ss 0) pe))
     (if (/= (vla-getbulge (vlax-ename->vla-object (ssname ss 0)) (float (fix pa))) 0.0)
       (setq ss nil)
     )
   )
 )
 (while (not ss)
   (prompt "\nMissed selection or picked arced segment... Please select again (LINE, POLYLINE) - only straight segment...")
   (setq ss (ssget "_+.:E:S" '((0 . "LINE,*POLYLINE"))))
   (if (and ss (wcmatch (cdr (assoc 0 (entget (ssname ss 0)))) "*POLYLINE"))
     (progn
       (setq pe (vlax-curve-getclosestpointtoprojection (ssname ss 0) (cadr (cadddr (car (ssnamex ss)))) '(0.0 0.0 1.0)))
       (setq pa (vlax-curve-getparamatpoint (ssname ss 0) pe))
       (if (/= (vla-getbulge (vlax-ename->vla-object (ssname ss 0)) (float (fix pa))) 0.0)
         (setq ss nil)
       )
     )
   )
 )
 (setq ent (ssname ss 0))
 (setq pe (vlax-curve-getclosestpointtoprojection ent (cadr (cadddr (car (ssnamex ss)))) '(0.0 0.0 1.0)))
 (setq pa (vlax-curve-getparamatpoint ent pe))
 (if (wcmatch (cdr (assoc 0 (entget ent))) "*POLYLINE")
   (progn
     (setq p1 (vlax-curve-getpointatparam ent (float (fix pa))))
     (setq p2 (vlax-curve-getpointatparam ent (float (1+ (fix pa)))))
   )
   (progn
     (setq p1 (vlax-curve-getstartpoint ent))
     (setq p2 (vlax-curve-getendpoint ent))
   )
 )
 (setq l (distance p1 p2))
 (setq vd (trans (getvar 'viewdir) 1 0 t))
 (if (not (equal (unit vd) '(0.0 0.0 1.0) 1e-6))
   (progn
     (setq vx (unit (v^v vd '(0.0 0.0 1.0))))
     (setq vy (unit (v^v vd vx)))
   )
   (setq vx '(1.0 0.0 0.0) vy '(0.0 1.0 0.0))
 )
 (setq p1u (transptucs p1 '(0.0 0.0 0.0) vx vy))
 (setq p2u (transptucs p2 '(0.0 0.0 0.0) vx vy))
 (setq p1up (list (car p1u) (cadr p1u) 0.0))
 (setq p2up (list (car p2u) (cadr p2u) 0.0))
 (setq lp (distance p1up p2up))
 (setq p1p (transptwcs p1up '(0.0 0.0 0.0) vx vy))
 (setq p2p (transptwcs p2up '(0.0 0.0 0.0) vx vy))
 (setq p (inters p1 p2 p1p p2p nil))
 (if (and p (> (distance p p2) (distance p p1))) (setq ps p2p ph (distance p2 p2p)) (setq ps p1p ph (distance p1 p1p)))
 (if p
   (progn
     (setq pl (distance p ps))
     (setq dip (cvunit (atan ph pl) "radian" "degree"))
   )
   (if (equal l lp 1e- (setq dip 0.0))
 )
 (prompt "\n.................................................")
 (prompt "\nReal length is : ") (princ (rtos l 2 15))
 (prompt "\nLength of projection is : ") (princ (rtos lp 2 15))
 (prompt "\nDIP (angle) in decimal degrees is : ") (princ (rtos dip 2 15))
 (princ)
)