[LISP程序]：自已写的一个对齐文字的程序。请指交

xiagood

自已写的一个文字对齐程序。。
花了几天的时间。
希对大家有所帮助. 很好用。可提高作图效率。

(Defun TextsortX (texts)
  (setq n1 (sslength texts))
  (setq j1 0)
  (setq textinX nil)
  (while (< j1 n1)
    (setq TxtTmp1 (ssname texts j1))
    (setq ent1 (entget TxtTmp1))
    (setq insX (cadr (assoc 10 ent1)))
    (setq textinX (append textinX (list insX)))
    (setq j1 (+ j1 1))
  )
  (setq sortX1 (vl-sort-i textinX '>))
  (setq LX (length sortX1))
  (setq f 0)
  (setq obj1 (ssadd))
  (while (< f LX)
    (setq etg1 (ssname texts (nth f sortX1)))
    (setq obj1 (ssadd etg1 obj1))
    (setq f (+ f 1))
  )  
)

(Defun TextsortY (texts)
  (setq n2 (sslength texts))
  (setq j2 0)
  (setq textinY nil)
  (while (< j2 n2)
    (setq TxtTmp2 (ssname texts j2))
    (setq ent2 (entget TxtTmp2))
    (setq insY (caddr (assoc 10 ent2)))
    (setq textinY (append textinY (list insY)))
    (setq j2 (+ j2 1))
  )
  (setq sortY1 (vl-sort-i textinY '>))
  (setq LY (length sortY1))
  (setq i 0)
  (setq obj2 (ssadd))
  (while (< i LY)
    (setq etg2 (ssname texts (nth i sortY1)))
    (setq obj2 (ssadd etg2 obj2))
    (setq i (+ i 1))
  )
)


(Defun C:Agr ()
  (vl-load-com)
  (setq        AcadObject   (vlax-get-acad-Object)
        AcadDocument (vla-get-ActiveDocument AcadObject)
        mspace             (vla-get-Modelspace AcadDocument)
  )
  (setvar "cmdecho" 0)
  (setq Osmod1 (getvar "osmode"))
  (setvar "osmode" 15295)
  (command "undo" "BE")
  (Princ "\n调整文字间距. ")
  (princ "\n请选择单行文本：")
  (setq texts (ssget '((0 . "text"))))
  (while (= texts nil)
    (setq texts (ssget '((0 . "text"))))
  )
  (setq xTy (ssname texts 0))
  (setq AngxTy (cdr (assoc 50 (entget xTy))))
  (setq AngxTy (atof (angtos AngxTy 0 4)))
  (if (or (= AngxTy 90) (= AngxTy 270))
      (Progn
         (TextsortX texts)
         (setq StarTxt (ssname obj1 0))
         (setq SortX (cadr (assoc 10 (entget StarTxt))))
         (setq SortY (caddr (assoc 10 (entget StarTxt))))
         (setq SortZ 0)
         (setq between nil)
         (setq Htxt (cdr (assoc 40 (entget StarTxt))))
         (setq between (getstring "\n请输入:[间距(A)/字倍间距(D)] <0.1H>"))
         (if (/= between nil)
           (cond
            ((= between "A")
                 (progn
                   (setq between (getreal "\n请输入数值:"))
                   (if (= between nil)
                       (setq between (+ Htxt (* Htxt 0.1)))
                    )
                   )
             )
            ((= between "a")
                 (progn
                   (setq between (getreal "\n请输入数值:"))
                   (if (= between nil)
                       (setq between (+ Htxt (* Htxt 0.1)))
                    )
                   )
             )
            ((= between "D")
                 (progn
                   (setq between (getreal "\n请输入间距字倍数:"))
                   (if (= between nil)
                       (setq between (+ Htxt (* Htxt 0.1)))
                       (setq between (* Htxt between))
                    )
                   )
             )
            ((= between "d")
                 (progn
                   (setq between (getreal "\n请输入间距字倍数:"))
                   (if (= between nil)
                       (setq between (+ Htxt (* Htxt 0.1)))
                       (setq between (* Htxt between))
                    )
                   )
             )
             ((= between "") (setq between (+ Htxt (* Htxt 0.1))))
             (T  (setq between (atof between)))
            )
           (setq between (+ Htxt (* Htxt 0.1)))
           )          
         (setq S 1)
         (While (< S LX)
               (setq SortObj (ssname obj1 s))
               (setq MovePX (cadr (assoc 10 (entget SortObj))))
               (setq MovePY (caddr (assoc 10 (entget SortObj))))
               (setq MovePZ 0)
               (setq MoveP (list MovePX MovePY MovePZ))
               (if (= Ang1 90)
                   (setq SortX (+ SortX between))
                   (setq SortX (- SortX between))
               )
               (setq Points (list SortX SortY SortZ))
               (command "Move" SortObj "" MoveP Points)
               (setq S (+ S 1))
          )
         )
   
      (progn
         (TextsortY texts)
         (setq StarTxt (ssname obj2 0))
         (setq SortX (cadr (assoc 10 (entget StarTxt))))
         (setq SortY (caddr (assoc 10 (entget StarTxt))))
         (setq SortZ 0)
         (setq Htxt (cdr (assoc 40 (entget StarTxt))))
         (setq between (getstring "\n请输入:[间距(A)/字倍间距(D)] <0.1H>"))
         (if (/= between nil)
           (cond
            ((= between "A")
                 (progn
                   (setq between (getreal "\n请输入数值:"))
                   (if (= between nil)
                       (setq between (+ Htxt (* Htxt 0.1)))
                    )
                   )
             )
            ((= between "a")
                 (progn
                   (setq between (getreal "\n请输入数值:"))
                   (if (= between nil)
                       (setq between (+ Htxt (* Htxt 0.1)))
                    )
                   )
             )
            ((= between "D")
                 (progn
                   (setq between (getreal "\n请输入间距字倍数:"))
                   (if (= between nil)
                       (setq between (+ Htxt (* Htxt 0.1)))
                       (setq between (* Htxt between))
                    )
                   )
             )
            ((= between "d")
                 (progn
                   (setq between (getreal "\n请输入间距字倍数:"))
                   (if (= between nil)
                       (setq between (+ Htxt (* Htxt 0.1)))
                       (setq between (* Htxt between))
                    )
                   )
             )
            ((= between "") (setq between (+ Htxt (* Htxt 0.1))))
             (T  (setq between (atof between)))
            )          
           )          
         (setq S 1)
         (While (< S LY)
               (setq SortObj (ssname obj2 s))
               (setq MovePX (cadr (assoc 10 (entget SortObj))))
               (setq MovePY (caddr (assoc 10 (entget SortObj))))
               (setq MovePZ 0)
               (setq MoveP (list MovePX MovePY MovePZ))
               (setq Ang1 (cdr (assoc 50 (entget StarTxt))))
               (setq Ang2 (angtos Ang1 0 4))
               (setq Ang2 (atof Ang2))

           (if (= Ang2 0)
                    (setq SortY (- SortY between))
               )
               (if (and (> Ang2 0) (< Ang2 90))
                   (progn
                     (setq SortX (+ SortX (* between (sin Ang1))))
                     (setq SortY (- SortY (* between (cos Ang1))))
                   )
               )
               (if  (and (> Ang2 180) (< Ang2 270))
                   (Progn
                      (setq SortX (+ SortX (* between (cos (- (angtof "270") Ang1)))))
                      (setq SortY (- SortY (* between (sin (- (angtof "270") Ang1)))))
                    )
                )
              (if   (and (> Ang2 270) (< Ang2 360))
                   (progn                 
                      (setq SortX (- SortX (* between  (sin (- (angtof "360") Ang1)))))
                      (setq SortY (- SortY (* between  (cos (- (angtof "360") Ang1)))))
                    )
               )
             (setq Points (list SortX SortY SortZ))
             (command "Move" SortObj "" MoveP Points)
             (setq S (+ S 1))
            )
        )
    )      
  (Command "Undo" "E")
  (setvar "osmode" Osmod1)
  (setvar "cmdecho" 1)
)