[编程交流] 坡度例行程序

Code:
;|--------------Inclination of line-------------------
               q_|_|| _\|| q_|| _\|                  
                                                     
 يقوم بتحديد ميل الخط من خلال اختيار نقطتين عليه      
                  و من الممكن ان يختار المستخدم      
               بين ان يرسم خط بين النقطتين او لا      
                                                     
------------------------------------------------------
 Author: Hasan M. Asous, 2010                        
 Copyright © 2010 by HasanCAD, All Rights Reserved.  
 Contact: HasanCAD @ TheSwamp.org,                   
          asos2000 @ CADTutor.net                    
          [email="HasanCAD@gmail.com"]HasanCAD@gmail.com[/email]                         
------------------------------------------------------
 Version: 1     20 Oct 2010                          
____________________________________________________|;
;     q_|_|| _\|| q_|| _\|     ;
;       Mainroutine Start      ;
(defun c:TanLine (/ p1 p2 p3)
 ; @ HasanCAD
 (vl-load-com)
 (HSN:DDwnMnuSetSysVar)
 (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)))
   )
 
 (if (not TL-sel) (setq TL-sel "Points"))
 (initget "select Line or Points")
 (setq TL-sel (cond ( (getkword (strcat "\nChoose  هل تريد تحديد خط او اختيار نقطتين [Line/Points] <" TL-sel ">: ") ) ) ( TL-sel ) ))
 (if (equal TL-sel "Points")
   (progn
     (and
(setq p1 (trans (getpoint "\nFirst Point اختار النقطة الاولى على الخط ")1 0))
       (setq p2 (trans (getpoint p1 "\nSecond Point اختار النقطة الثانية على الخط")1 0))
       (setq p3 (trans (getpoint "\nText insertion Point قم بتحديد مكان النص")1 0))
       )
     (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1))))
     (IF (< 1000 (ABS (- (cadr p2) (cadr p1))))
(setq h 220)
(if (< 100 (ABS (- (cadr p2) (cadr p1))))
  (setq h 22)
  (setq h 2.2)))
     (if (not TL-Line) (setq TL-Line "Yes"))
     (initget "Yes No")
     (setq TL-Line (cond ( (getkword (strcat "\nChoose هل تريد رسم خط بين النقطتين [Yes/No] <" TL-Line ">: ") ) ) ( TL-Line ) ))
     (if (equal TL-Line "Yes")
(progn
  (HSN:TL-Text h)
         (HSN:TL-Line)
  )
(progn
  (HSN:TL-Text h)
  )
)
     )
   (progn
     (setq TL:SS (entget (car (entsel))))
     (if (and
    (equal TL-sel "Line")
    (equal (cdr (assoc 0 TL:SS)) "LINE")
    )
(Progn   
         (setq p1 (cdr (assoc 10 TL:SS)))
         (setq p2 (cdr (assoc 11 TL:SS)))
  (setq p3 (trans (getpoint "\nText insertion Point قم بتحديد مكان النص")1 0))
  (setq tan2 (/ (- (cadr p2) (cadr p1)) (- (car p2) (car p1))))
  (HSN:TL-Text)
  )
(progn
  (princ "\n  PLease Seect a line or Points")
  )
)
     )
   )
 (HSN:ReDDwnMnuSetSysVar)
 (vla-EndUndoMark ActDoc)
 )
;     q_|_|| _\|| q_|| _\|     ;
;       Mainroutine End        ;
;     q_|_|| _\|| q_|| _\|     ;
;       Subroutine Start       ;
(defun *error* (msg)
 (and uFlag (vla-EndUndoMark doc))
 (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
     (princ (strcat "\n** Error: " msg " **")))
 (princ)
 )
(defun HSN:DDwnMnuSetSysVar ()
 ; @ HasanCAD
 (setq OldOS (getvar "osmode"))
 (setq OldDynmode (getvar "dynmode"))
 (setq OldDynprompt (getvar "dynprompt"))
 
 (setvar "osmode" 33)
 (setvar "dynmode" 1)
 (setvar "dynprompt" 1)
 (setvar "cmdecho" 0)       
 )
(defun HSN:ReDDwnMnuSetSysVar ()
 ; @ HasanCAD
 (setq *error* TERR$)
 (setvar "osmode" OldOS)
 (setvar "dynmode" OldDynmode)
 (setvar "dynprompt" OldDynprompt)
 )
(defun HSN:TL-Text (H)
 ; @ HasanCAD
      (entmakex (list
    (cons 0 "TEXT")
                  (cons 10  p3)
                  (cons 40 H)
                  (cons 1 (strcat (rtos (abs (* tan2 100))2 2) "%"))
    ))
 )
(defun HSN:TL-Line ()
 ; @ HasanCAD
      (entmake (list
   (cons 0 "LINE")
                 (cons 10 p1)
                 (cons 11 p2)
   ))
 )
;     q_|_|| _\|| q_|| _\|     ;
;        Subroutine End        ;
(princ "\n  TanLine.lsp ~ Copyright © by HasanCAD")
(princ "\n     ...Type TanLine to Invoke...   ")
(princ)