我想我会扔掉我的一个旧的，关于方位、距离、三角洲海拔和坡度：
- ;| By Tom Beauford:
- Dst.lsp will prompt the user to pick the first point, then pick the next point,
- then display the distance picked by with a colored line, every distance measured
- shows a different color. the bearing & horizontal distance will be displayed in
- the left corner of the status line and the bearing, horizontal distance, difference
- in elevation and slope will be displayed on the command line.
- Macro: ^P(or C:DST (load "DST.lsp"));DST
- Command line: (load "DST.lsp") DST
- |;
- (defun C:DST ( / *ERROR* 2DIST fact str1 tw CNTR PT1 PT2 ang DST PDST Pang)
- (defun *ERROR* (s) ; If an error (such as CTRL-C) occurs
- ; while this command is active...
- (if (/= s "Function cancelled")
- (princ (strcat "\nError: " s))
- )
- (grtext -1 "") ; Clear status line.
- (vl-cmdf "redraw")
- (princ)
- )
- (defun 2DIST (PT)
- (list (car pt)(cadr pt))
- ) ;defun
- (setq fact nil)
- (if(and(= 1 (getvar "cvport"))(trans '(1 0 0) 2 3 0))
- (progn
- (setq fact (car (trans '(1 0 0) 2 3 0)))
- (princ "\nPS:MS == 1:")
- (princ(/ 1 fact))
- (setvar "NOMUTT" 1)
- (command "mspace")
- (setq tw (- (* 2 pi)(cdr(assoc 51(entget(acet-currentviewport-ename))))))
- (command "pspace")
- (setvar "NOMUTT" 0)
- )
- )
- (setq CNTR 0 ;INITIALIZE COUNTER
- PT1 (getpoint "\nPick First Point") ;PROMPT FOR FIRST POINT
- PT2 PT1
- )
- (while PT2 ;IF YES OR ENTER
- (setq PT2 (getpoint "\nPick Next Point" PT1)) ;PROMPT FOR NEXT POINT
- (if PT2
- (progn
- (if fact
- (progn
- (setq DST (/ (distance (2DIST PT1)(2DIST PT2))fact) ;CONVERT TO STRING
- PDST (distance (2DIST PT1)(2DIST PT2)) ;CONVERT TO STRING
- CNTR (1+ CNTR) ;ADD TO COUNTER FOR COLOR CHANGE
- Pang (angtos (angle pt1 pt2)4 4)
- ang (angtos (+(angle pt1 pt2)tw)4 4)
- deltaz (/ (- (car(cddr pt2)) (car(cddr pt1)))fact)
- slope (/ deltaz DST)
- )
- (if(eq Pang ang)
- (setq DST(strcat "MS Bearing= "ang ", Dist= " (rtos DST 2 2) "', PS Dist= " (rtos PDST 2 2) """))
- (setq DST(strcat "MS Bearing= "ang ", Dist= " (rtos DST 2 2) "', PS Bearing= "Pang ", Dist= " (rtos PDST 2 2) """))
- );if
- );progn
- (setq DST (distance (2DIST PT1)(2DIST PT2))
- CNTR (1+ CNTR)
- ang (angtos (angle pt1 pt2)4 4)
- deltaz (- (car(cddr pt2)) (car(cddr pt1)))
- slope (/ deltaz DST)
- DST (strcat "Bearing= "ang ", Dist= " (rtos DST 2 2) "'")
- )
- );if fact
- (if (/= 0 deltaz)
- (progn
- (cond
- ((equal (abs slope) (/ 1.0 2) 0.0001)(setq slope "2:1"))
- ((equal (abs slope) (/ 1.0 3) 0.0001)(setq slope "3:1"))
- ((equal (abs slope) (/ 1.0 4) 0.0001)(setq slope "4:1"))
- ((equal (abs slope) (/ 1.0 5) 0.0001)(setq slope "5:1"))
- ((equal (abs slope) (/ 1.0 6) 0.0001)(setq slope "6:1"))
- ((equal (abs slope) (/ 1.0 7) 0.0001)(setq slope "7:1"))
- ((equal (abs slope) (/ 1.0 0.0001)(setq slope "8:1"))
- ((equal (abs slope) (/ 1.0 9) 0.0001)(setq slope "9:1"))
- ((equal (abs slope) (/ 1.0 10) 0.0001)(setq slope "10:1"))
- ((equal (abs slope) (/ 1.0 12) 0.0001)(setq slope "12:1"))
- ((equal (abs slope) (/ 1.0 15) 0.0001)(setq slope "15:1"))
- ((equal (abs slope) (/ 1.0 20) 0.0001)(setq slope "20:1"))
- ((equal (abs slope) (/ 1.0 30) 0.0001)(setq slope "30:1"))
- ((equal (abs slope) (/ 1.0 40) 0.0001)(setq slope "40:1"))
- ((equal (abs slope) (/ 1.0 50) 0.0001)(setq slope "50:1"))
- ((equal (abs slope) (/ 1.0 100) 0.0001)(setq slope "100:1"))
- ; ((equal (abs slope) (/ 0.25 12) 0.0001)(setq slope "1/4"=1'"))
- (T(setq slope (strcat (rtos (* slope 100) 2 4) "%")))
- )
- (setq DST (strcat DST " Delta elev= "(rtos deltaz) " Slope= " slope))
- );progn
- );if
- (prompt (strcat "\n" DST)) ;Print the distance to command line
- (grtext -1 DST) ;Print distance in status line
- (grdraw PT1 PT2 CNTR 2) ;Draw a colored line between points
- (setq PT1 PT2) ;Change start point
- ) ;end progn
- ) ;end if PT2
- ) ;end while PT2
- (grtext -1 "") ;Clear status line
- (vl-cmdf "redraw")
- (princ)
- ) ;end fun
| 
置顶卡
