自编CAD小工具插件

【实例简介】自编CAD小工具插件

cad绘图小工具，批量打印，自动绘图，自定义标注，批量更换图框，编号，编页码。。。。。。

【核心代码】

;AUTOMATION PROGRAMMES
(princ "\nAUTOMATION utilities ")
(DEFUN c:bR1 ()
  (setq s1  (car (entsel "Select the object :"))
lay (getpoint "Pick point to Break :")
  )
  (command "break" s1 lay lay)

)
(defun C:vf ()
  (setq s1 (entget (car (entsel "Select the object :")))
n  (cdr (assoc 1 s1))
  )
  (command "-layout" "R" "" n)
)
(DEFUN c:AR1 ()
  (setq s1  (entget (car (entsel "Select the object :")))
lay (Cdr (assoc 8 s1))
  )
  (COMMAND "LAYER" "OFF" "*" "Y" "")
  (command "layer" "on" lay "")
)
(DEFUN c:AR2 ()
  (setq s1  (entget (car (entsel "Select the object :")))
lay (Cdr (assoc 8 s1))
  )

  (command "layer" "off" lay "")
)

(defun c:grr ()
  (setq sel    (entsel "\nSelect the Line for Gradient :")
pro    (entget (car sel))
co1    (cdr (assoc 10 pro))
x1     (car co1)
y1     (car (cdr co1))
co2    (cdr (assoc 11 pro))
x2     (car co2)
y2     (car (cdr co2))
len    (- x1 x2)
vert   (/ (- y2 y1) 10)
gradi  (* (/ vert len) 1000)
gradie (rtos gradi 2 3)
  )
  (print "The Gradient of line Selected  :")
  (princ gradie)
  (print)
)

(defun c:grd ()
  (setq sel    (entsel "\nSelect the Line for Gradient :")
pro    (entget (car sel))
co1    (cdr (assoc 10 pro))
x1     (car co1)
y1     (car (cdr co1))
co2    (cdr (assoc 11 pro))
x2     (car co2)
y2     (car (cdr co2))
len    (- x1 x2)
vert   (/ (- y2 y1) 10)
gradi  (* (/ vert len) 100)
gradie (rtos gradi 2 3)
  )
  (print "The Gradient of line Selected  :")
  (princ gradie)
  (print)
)
(defun c:de ()
  (setq p1 (getpoint "\nSpecify first Point: ")
p2 (getpoint "\nSpecify opposite Point:")
d  (rtos (/ (distance p1 p2) 5) 2 3)
  )
  (print d)
  (princ)
)
(defun c:dee ()
  (setq p1 (getpoint "\nSpecify first Point: ")
p2 (getpoint "\nSpecify opposite Point:")
d  (rtos (/ (distance p1 p2) 10) 2 3)
  )
  (print d)
  (princ)
)
(defun c:a1 ()
  (setq name (getstring "\nEnter the Layout Name:")
  )
  (command "-layout" "n" name)
  (command "-layout" "s" name)
  (command "-layout" "d" "layout1")
  (command "-layout" "d" "layout2")
  (setq p1 (getpoint "\nSpecify first corner: ")
p2 (getpoint "\nSpecify opposite corner:")
  )
  (command "-plot"     "y"      ""
   "HP DesignJet 500 42 by HP.pc3"
   "ISO A1 - 594 x 841 mm. (portrait)"
   "m"     "l"      "n"
   "w"     p1      p2
   "fit"     "centre"      "yes"
   "monochrome.ctb" "yes"      "no"
   "no"     "no"      "no"
   "yes"     "no"
  )
  (command "-layout" "s" "model")
)

;A2plot
(defun c:a2 ()
  (setq name (getstring "\nEnter the Layout Name:")
  )
  (command "-layout" "n" name)
  (command "-layout" "s" name)
  (setq p1 (getpoint "\nSpecify first corner: ")
p2 (getpoint "\nSpecify opposite corner:")
  )

  (command "-plot"      "y"        ""
   "HP DesignJet 500 42 by HP.pc3"
   "ISO A2 - 420 x 594 mm. (landscape)"
   "m"      "l"        "n"
   "w"      p1        p2
   "fit"      "centre"        "yes"
   "monochrome.ctb"  "yes"        "no"
   "no"      "no"        "no"
   "yes"      "no"
  )

  (command "-layout" "s" "model")
)

;A3plot
(defun c:a3 ()
  (setq name (getstring "\nEnter the Layout Name:")
  )
  (command "-layout" "n" name)
  (command "-layout" "s" name)
  (setq p1 (getpoint "\nSpecify first corner: ")
p2 (getpoint "\nSpecify opposite corner:")
  )
  (command "-plot" "y"        ""
   "hp deskjet 1180c printer.pc3"      "A3 (297 x 420 mm)"
   "m" "l"        "n"      "w"
   p1 p2        "fit"      "centre"
   "yes" "monochrome.ctb"      "yes"
   "no" "no"        "no"      "no"
   "yes" "no"
  )

  (command "-layout" "s" "model")
)
;A4plot

(defun c:a4 ()
  (setq name (getstring "\nEnter the Layout Name:")
  )
  (command "-layout" "n" name)
  (command "-layout" "s" name)
  (setq p1 (getpoint "\nSpecify first corner: ")
p2 (getpoint "\nSpecify opposite corner:")
  )
  (command "-plot" "y"        ""
   "hp deskjet 1180c printer.pc3"      "A4 (210 x 297 mm)"
   "m" "l"        "n"      "w"
   p1 p2        "fit"      "centre"
   "yes" "monochrome.ctb"      "yes"
   "no" "no"        "no"      "no"
   "yes" "no"
  )

  (command "-layout" "s" "model")
)

;A3LAYOUT_plot
(defun c:a33 ()

  (setq p1 (getpoint "\nSpecify first corner: ")
p2 (getpoint "\nSpecify opposite corner:")
  )
  (command "-plot" "y"        ""
   "hp deskjet 1180c printer.pc3"      "A4 (210 x 297 mm)"
   "m" "l"        "n"      "w"
   p1 p2        "fit"      "centre"
   "yes" "monochrome.ctb"      "yes"
   "no" "no"        "no"      "no"
   "yes" "N"
  )
  (command "zoom" "e")
  (command "zoom" "0.8x")
  (command "qsave")
)
;A4LAYOUT_plot
(defun c:a44 ()

  (setq p1 (getpoint "\nSpecify first corner: ")
p2 (getpoint "\nSpecify opposite corner:")
  )
  (command "-plot" "y"        ""
   "hp deskjet 1180c printer.pc3"      "A3 (297 x 420 mm)"
   "m" "l"        "n"      "w"
   p1 p2        "fit"      "centre"
   "yes" "monochrome.ctb"      "yes"
   "no" "no"        "no"      "no"
   "yes" "N"
  )
  (command "zoom" "e")
  (command "zoom" "0.8x")
  (command "qsave")
)

;fast previous plot
(defun c:pl ()
  (command "-plot" "" "" "<previous plot>" "" "" "yes" "")
)

(defun c:aas ()
  (setq lay (layoutlist)
a   (- (length lay) 3)
x   3
  )
  (repeat a
    (setq lana (nth x lay))

    (command "-plot" "" lana "<previous plot>" "" "" "y" "y")
    (setq x ( x 1))
  )

)
(defun c:lc ()
  (setq n (getint "\nEnter the no. of Layout :")
  )
  (repeat n
    (command "-layout" "c" "" "")
  )
)

(defun c:sav ()
  (command "saveas" "2000" "" "y")
  (command "close")

)



(DEFUN C:AB ()
  (ALERT "IT GIVES AREA OF THE SELECTED AREA")
  (command "LAYER" "N" "BO" "")
  (COMMAND "LAYER" "SET" "BO" "")
  (COMMAND "LAYER" "OFF"   "*"    "Y"    ""    "LAYER" "ON"
   "OGL"   "ON"    "QL"    "ON"    "BO"    "ON"    "MCL"
   ""
  )
  (SETQ A (GETPOINT "Select the Internal point.."))
  (COMMAND "BOUNDARY" A "")
  (COMMAND "AREA" "O" "LAST")
  (COMMAND "ERASE" "LAST" "" "")
  (TEXTSCR)
  (PRINC)
)

(DEFUN C:AB3 ()
  (ALERT "IT GIVES AREA OF THE SELECTED POINT")
  (command "LAYER" "N" "BO" "")
  (COMMAND "LAYER" "SET" "BO" "")
  (COMMAND "LAYER" "OFF" "*" "Y" "" "LAYER" "ON" "OGL" "ON" "QL" "ON"
   "BO" "")
  (SETQ A (GETPOINT "Select the Internal point.."))
  (COMMAND "BOUNDARY" A "")
  (setq en (entlast))
  (SETQ b (GETPOINT "Select the Internal point.."))
  (command "boundary" b "")
  (setq en1 (entlast))
  (SETQ c (GETPOINT "Select the Internal point.."))
  (command "boundary" c "")
  (setq en2 (entlast))
  (COMMAND "AREA" "a" "o" en en1 en2 "" "")
  (princ "**********************")
  (princ)
  (command "erase" en en1 en2 "")
  (TEXTSCR)
  (command "onn")
)

(DEFUN C:AB2 ()
  (ALERT "IT GIVES AREA OF THE SELECTED POINT")
  (command "LAYER" "N" "BO" "")
  (COMMAND "LAYER" "SET" "BO" "")
  (COMMAND "LAYER" "OFF" "*" "Y" "" "LAYER" "ON" "OGL" "ON" "QL" "ON"
   "BO" "")
  (SETQ A (GETPOINT "Select the Internal point.."))
  (COMMAND "BOUNDARY" A "")
  (setq en (entlast))
  (SETQ b (GETPOINT "Select the Internal point.."))
  (command "boundary" b "")
  (setq en1 (entlast))
  (COMMAND "AREA" "a" "o" en en1 "" "")
  (princ "**************************")
  (princ)
  (command "erase" en en1 "")
)
(DEFUN C:ONN ()
  (COMMAND "LAYER" "ON" "*" "")
)

(DEFUN C:OFF ()
  (COMMAND "LAYER" "OFF" "*" "Y" "")
)

(DEFUN C:ON ()
  (COMMAND "LAYER" "ON")
)

(defun c:lse1 ()
  (command "layer" "set" "ql" "")
)

(DEFUN C:OF ()
  (COMMAND "LAYER" "OFF")
)

(DEFUN C:AO ()
  (ALERT "IT GIVES AREA OF THE SELECTED AREA")
  (command "LAYER" "N" "BO" "")
  (COMMAND "LAYER" "SET" "BO" "")
  (command "layer" "of" "ogl" "of" "hat" "")
  (SETQ A (GETPOINT "PICK THE POINT TO CREATE BOUNDARY AND AREA.."))
  (COMMAND "BOUNDARY" A "")
  (COMMAND "AREA" "O" "LAST")
  (COMMAND "ERASE" "LAST" "" "")
  (TEXTSCR)
  (PRINC)
)

(defun c:cl ()
  (setq a (getpoint "select objects.."))
  (command "chprop" a "" "la")
)
(defun c:cl ()
  (setq a (ssget))
  (command "chprop" a "" "la")
)

(defun c:cc ()
  (setq a (ssget))
  (command "chprop" a "" "c")
)
(DEFUN C:AO ()
  (ALERT "IT GIVES AREA OF THE SELECTED AREA")
  (COMMAND "LAYER" "OF" "HAT" "OF" "OGL" "")
  (command "LAYER" "N" "BO" "")
  (COMMAND "LAYER" "SET" "BO" "")
  (SETQ A (GETPOINT "Select the Internal point.."))
  (COMMAND "BOUNDARY" A "")
  (COMMAND "AREA" "O" "LAST")
  (COMMAND "ERASE" "LAST" "" "")
  (TEXTSCR)


  (PRINC)
)


(DEFUN C:C7 ()
  (COMMAND "LAYER" "OF" "OGL" "OF" "HAT" "")
  (SETQ A (SSGET))
  (COMMAND "CHPROP" A "" "C" "7" "")
  (COMMAND "LAYER" "ON" "*" "")
  (SETQ B (SSGET))
  (COMMAND "MOVE" B "")
)

(defun c:z8x ()
  (command "zoom" "e")
  (command "zoom" "0.8x")
)
(defun c:irh ()
  (command "insert" "rh" "" "" "")
)
(defun c:i2 ()
  (command "insert" "2" "" "" "")
)
(defun c:ipc ()
  (command "insert" "pc" "" "" "")
)
(DEFUN C:MY ()
  (command "style" "standard" "monotype corsiva" "" "" "" "" "" "")
  (COMMAND "LAYER" "Of" "*" "y" "")
  (COMMAND "LAYER" "On" "hat" "on" "text" "")
  (setq a (ssget))
  (command "erase" a "" "")
  (COMMAND "LAYER" "ON" "*" "")
  (setq b (ssget))
  (command "erase" b "" "")
  (setq c (getpoint "pick the insertion point.."))
  (command "insert" "ti" c "" "" "")
  (command "qsave")
  ;;(defun c:pua()
  (command "purge" "all" "*" "n" "")
  (COMMAND "QSAVE")
  (command "purge" "all" "*" "n" "")
  (COMMAND "QSAVE")
  (command "zoom" "e")
  (command "zoom" "0.8x")
  (command "qsave")
  (command "close")
)

(defun c:rek ()
  (command "style" "standard" "ARIAL" "" "" "" "" "" "")
  (ALERT "CHANGE THE GROUND LEVEL LINE TO OGL LAYER")
  (setq AA (ssget))
  (command "chprop" Aa "" "LA" "OGL" "" "")
  (ALERT "ERASE UNWANTED OBJECTS")
  (setq a (ssget))
  (command "erase" a "")
  (ALERT
    "SELECT BASE POINT AND SECOND POINT FOR INSERTING THE COPIED OBJECTS"
  )
  (setq c
(getpoint
   "select the insertion point of copying objects like drian,row..."
)
  )
  (setq d
(getpoint
   "select the insertion point of copied objects like drian,row..."
)
  )
  (alert "select the objects to copy")
  (setq b (ssget))
  (command "copy" b "" c d)
  (setq F (getpoint "select the insertion point FOR DIM BLOCK..."))
  (command "insert" "DIM" F "" "" "")
  (COMMAND "EXPLODE" "L" "")
  (setq G (getpoint "select the insertion point FOR RH BLOCK..."))
  (command "insert" "RH" G "" "" "")
  (COMMAND "EXPLODE" "L" "")
  (setq H (getpoint "select the insertion point FOR LH BLOCK..."))
  (command "insert" "LH" H "" "" "")
  (COMMAND "EXPLODE" "L" "")
  (COMMAND "LAYER" "SET" "QL" "")
)



(defun c:pcl ()
  (command "style" "standard" "ARIAL" "" "" "" "" "" "")
  (command "purge" "all" "*" "n" "")
  (COMMAND "QSAVE")
  (command "purge" "all" "*" "n" "")
  (COMMAND "QSAVE")
  (command "zoom" "e")
  (command "zoom" "0.8x")
  (command "qsave")
  (command "LAYER" "N" "legend" "")
  (setq a (ssget))
  (command "chprop" a "" "la" "legend" "")
  (command "layer" "of" "legend" "")
  (command "zoom" "e")
  (command "zoom" "0.8x")
  (command "qsave")
  (command "close")
)


(DEFUN C:IDIM ()
  (setq F (getpoint "select the insertion point FOR DIM BLOCK..."))
  (command "insert" "DIM" F "" "" "")
  (COMMAND "EXPLODE" "L" "")
)



(DEFUN C:ITEXT ()
  (setq F (getpoint "select the insertion point FOR DIM BLOCK..."))
  (command "insert" "TEXT" F "" "" "")
  (COMMAND "EXPLODE" "L" "")
)


(DEFUN C:ITIT ()
  (setq F (getpoint "select the insertion point FOR DIM BLOCK..."))
  (command "insert" "TIT" F "" "" "")
  (COMMAND "EXPLODE" "L" "")
)



(DEFUN C:ILEG ()
  (setq F (getpoint "select the insertion point FOR DIM BLOCK..."))
  (command "insert" "LEG" F "" "" "")
)




(DEFUN C:IRR ()
  (setq F (getpoint "select the insertion point FOR DIM BLOCK..."))
  (command "insert" "RR" F "" "" "")
)


(DEFUN C:ITITR ()
  (setq F (getpoint "select the insertion point FOR DIM BLOCK..."))
  (command "insert" "TITR" F "" "" "")
  (COMMAND "EXPLODE" "L" "")
)


(Defun c:ol ()
  (COMMAND "LAYER" "ON" "*" "")
  (command "qsave")
  (command "close")
)


(defun c:ct ()
  (SETQ A (SSGET))
  (COMMAND "ERASE" A "" "")
  (setq p (getpoint "select base point"))
  (setq r (getpoint "select next point"))
  (SETQ B (SSGET))
  (COMMAND "MOVE" B "" p r)
  (setq d (ssget))
  (command "erase" d "")
  (command "qsave")
  (command "close")
)


(defun c:ext ()
  (setq f (open "c:\\123.txt" "a")
  )
  (setq a (entsel "select the entity..")
b (entget (car a))
c (assoc 1 b)
d (atof (cdr c))
  )
  (print d f)

  (setq a (entsel "select the entity..")
b (entget (car a))
c (assoc 1 b)
d (atof (cdr c))
  )

  (princ "          " f)
  (princ d f)

  (setq a (entsel "select the entity..")
b (entget (car a))
c (assoc 1 b)
d (atof (cdr c))
  )
  (princ "           " f)
  (princ d f)

  (setq a (entsel "select the entity..")
b (entget (car a))
c (assoc 1 b)
d (atof (cdr c))
  )
  (princ "           " f)
  (princ d f)
  (close f)
)


(defun c:CRRI ()
  (setq g (getpoint "select the insertion point"))
  (SETQ A (gETSTRING "Enter the Block name.."))
  (if (= a "rec")
    (command "insert" "R" G "" "" "")
    (command "insert" "pcC" G "" "" "")
  )
  (COMMAND "EXPLODE" "L" "")
  (setq b (ssget))
  (command "LAYER" "N" "mcl" "")
  (command "chprop" b "" "LA" "mcl" "" "")
  (ALERT "IT GIVES AREA OF THE SELECTED AREA")
  (command "LAYER" "N" "BO" "")
  (COMMAND "LAYER" "SET" "BO" "")
  (COMMAND "LAYER" "OFF"   "*"    "Y"    ""    "LAYER" "ON"
   "OGL"   "ON"    "QL"    "ON"    "BO"    "ON"    "mcl"
   ""
  )
  (SETQ A (GETPOINT "Select the Internal point.."))
  (COMMAND "BOUNDARY" A "")
  (COMMAND "AREA" "O" "LAST")
  (COMMAND "ERASE" "LAST" "" "")
  (TEXTSCR)
)



(defun c:cd ()
  (command "" "purge" "all" "*" "n")
  (command "purge" "all" "*" "n")
  (command "purge" "all" "*" "n")
  (command "purge" "all" "*" "n")
  (command "zoom" "e")
  (command "qsave")
  (command "close")
)

(DEFUN C:aw ()
  (setq F (getpoint "select the insertion point FOR Legend..."))
  (command "insert" "leg" F "" "" "" "" "" "" "" "" "" "")
  (setq a (getreal "Enter the Scale Value :"))
  (command "scale" "last" "" f a)
)

(DEFUN C:ABR ()
  (SETQ A (GETPOINT "Select the Internal point.."))
  (COMMAND "BOUNDARY" A "")
  (COMMAND "AREA" "O" "LAST")
  (COMMAND "ERASE" "LAST" "" "")
  (TEXTSCR)
)
(defun c:tchhh ()
  (setq A (SSGET)
l (sslength a)
k 0
  )
  (repeat l
    (progn
      (setq ss (ssname a k)
    text (entget ss)
    x (atof (cdr (assoc 1 text)))
    x1 (- x 200)
    text (subst (cons 1 (rtos x1 2 3)) (assoc 1 text) text)
    text (subst (cons 62 2) (assoc 62 text) text)
      )
      (entmod text)
      (setq k ( k 1))
    )
  )
)


(defun c:tch ()
  (setq text (entget (car (entsel "Select the Text :")))
x    (atof (cdr (assoc 1 text)))
x1   ( x 1.01)
text (subst (cons 1 (rtos x1 2 3)) (assoc 1 text) text)
text (subst (cons 62 2) (assoc 62 text) text)
  )
  (entmod text)
)


(defun C:ttch ()
  (setq text (entget (car (entsel "Select the Text :"))))
  (setq text1 (entget (car (entsel "Select the Text :")))
x     (cdr (assoc 1 text))
text1 (subst (cons 1 x) (assoc 1 text1) text1)
  )
  (entmod text1)

)


(defun C:tRR ()
  (setq text  (entget (car (entsel "Select the Text :")))
TEXT1 (GETREAL "Enter the Value :")
y     (atof (cdr (assoc 1 text)))
text  (subst (cons 1 (rtos text1 2 3)) (assoc 1 text) text)
text  (subst (cons 62 2) (assoc 62 text) text)
  )
  (entmod text)

  (setq text (entget (car (entsel "Select the Text :")))
X    (atof (cdr (assoc 1 text)))
y    (- y text1)
x1   ( X y)
text (subst (cons 1 (rtos x1 2 3)) (assoc 1 text) text)
text (subst (cons 62 2) (assoc 62 text) text)
  )
  (entmod text)
)

(defun c:SEE2 ()
  (setq e  (entget (car (entsel "Select the Base Line")))
a  (substr (cdr (assoc 1 e)) 29 5)
ll (cdr (assoc 1 e))
l  (strlen ll)
  )


  (setq f  (cdr (assoc 10 e))
a2 (substr a 1 2)
a3 (substr a 3 3)
a6 " "
a4 "/"
a5 (strcat a2 a4 a3)
a1 (strcat a2 a6 a3)
  )
  (command "insert" "BLR" F "" "" "" a1 a5)
)

(defun c:SEE ()
  (setq e  (entget (car (entsel "Select the Text")))
a  (substr (cdr (assoc 1 e)) 29 5)
ll (cdr (assoc 1 e))
l  (strlen ll)
f  (cdr (assoc 11 e))
y  (car (cdr f))
n  0
  )

  (command "zoom" "E")
  (setq p1    (list 0.0 y)
p2    (list 1000000.0 y)
ss    (ssget "F" (LIST p1 p2))
sslen (sslength ss)

  )
  (repeat sslen
    (progn
      (setq tn (entget (ssname ss n))

    a  (substr (cdr (assoc 1 tn)) 29 5)
    f  (cdr (assoc 11 tn))
    a2 (substr a 1 2)
    a3 (substr a 3 3)
    a6 " "
    a4 "/"
    a5 (strcat a2 a4 a3)
    a1 (strcat a2 a6 a3)
    n  ( n 1)

      )
      (command "insert" "BLR1" F "" "" "" a1 a5)
    )
  )

)



(defun c:fcs ()
  (setq ei   (entget (car (entsel "Select the Text")))
fi   (cdr (assoc 11 ei))
yi   (car (cdr fi))
fx   (getvar "DWGPREFIX")
fy   (getvar "DWGNAME")
fx   (strcat fx fy)
fi   (vl-string-subst ".txt" ".dwg" fx)
file (open fi "a")
  )
  (princ "\n" file)
  (princ
    "CHAINAGE              EXCVN              EMB              GRNSH            AGGBASE             B.C               W.C               C&G"
    file
  )
  (command "zoom" "E")
  (setq p1  (list -100.0 yi 0.0)
p2  (list 1000000.0 yi 0.0)
ss  (ssget "F" (LIST p1 p2) '((0 . "TEXT")))
ssl (sslength ss)
ni  0
  )
  (repeat ssl
    (setq e   (entget (ssname ss ni))
  a11 (substr (cdr (assoc 1 e)) 29)
  a22 (vl-string-position (ascii ".") a11)
  a   (substr a11 1 ( a22 4))
    )
    (setq f (cdr (assoc 11 e))
  x (car f)
  y (car (cdr f))
  p1 (list (- x 10.0) (- y 1.65) 0.0)
  p2 (list ( x 10.0) (- y 1.65) 0.0)
  sst (ssget "f" (list p1 p2) '((0 . "TEXT")))
  sstl (sslength sst)
  pa1 (list (- x 10.0) (- y 2.15) 0.0)
  pa2 (list ( x 10.0) (- y 2.15) 0.0)
  ssta (ssget "f" (list pa1 pa2) '((0 . "TEXT")))
  sstal (sslength ssta)
  n 0
    )
    (princ "\n" file)
    (princ a file)
    (repeat sstl
      (setq tn (entget (ssname sst n))
    fa (cdr (assoc 1 tn))
    sl (strlen fa)
      )
      (if (< sl 7)
(progn
  (princ "            " file)
  (princ fa file)
)
      )
      (if (< n sstal)
(progn
  (setq tni (entget (ssname ssta n))
fai (cdr (assoc 1 tni))
sli (strlen fai)
  )
  (if (< sli 7)
    (progn
      (princ "            " file)
      (princ fai file)
    )
  )
)
      )
      (setq n ( n 1))
    )
    (setq ni ( ni 1))
  )
  (close file)
)


(defun c:fcs1 ()
  (setq ei   (entget (car (entsel "Select the Text")))
fi   (cdr (assoc 11 ei))
yi   (car (cdr fi))
fx   (getvar "DWGPREFIX")
fy   (getvar "DWGNAME")
fx   (strcat fx fy)
fi   (vl-string-subst ".txt" ".dwg" fx)
file (open fi "a")
  )

  (command "zoom" "E")

  (setq p1  (list -100.0 yi 0.0)
p2  (list 1000000.0 yi 0.0)
ss  (ssget "F" (LIST p1 p2) '((0 . "TEXT")))
ssl (sslength ss)
ni  0
  )
  (repeat ssl
    (setq e   (entget (ssname ss ni))
  a11 (substr (cdr (assoc 1 e)) 29)
  a22 (vl-string-position (ascii ".") a11)
  a   (substr a11 1 ( a22 4))
    )
    (setq f (cdr (assoc 11 e))
  x (car f)
  y (car (cdr f))
  p1 (list (- x 10.0) (- y 1.65) 0.0)
  p2 (list ( x 10.0) (- y 1.65) 0.0)
  sst (ssget "f" (list p1 p2) '((0 . "TEXT")))
  sstl (sslength sst)
  pa1 (list (- x 10.0) (- y 2.15) 0.0)
  pa2 (list ( x 10.0) (- y 2.15) 0.0)
  ssta (ssget "f" (list pa1 pa2) '((0 . "TEXT")))
  sstal (sslength ssta)
  n 0
  na 0
    )
    (princ "\n" file)
    (princ a file)
    (repeat sstl
      (setq tn (entget (ssname sst n))
    fa (cdr (assoc 1 tn))
      )
      (princ "      " file)
      (princ fa file)

      (setq n ( n 1))
    )
    (repeat sstal
      (setq tn (entget (ssname ssta na))
    fa (cdr (assoc 1 tn))
      )
      (princ "      " file)
      (princ fa file)

      (setq na ( na 1))
    )
    (setq ni ( ni 1))
  )
  (close file)
)

(defun c:SEF ()
  (setq e (entget (car (entsel "Select the Text")))
f (cdr (assoc 11 e))
y (car (cdr f))
n 0
  )
  (command "zoom" "E")
  (setq p1    (list 0.0 y)
p2    (list 1000000.0 y)
ss    (ssget "F" (LIST p1 p2))
sslen (sslength ss)

  )
  (setq p1     (list 0.0 (- y 0.65))
p2     (list 1000000.0 (- y 0.65))
ssl    (ssget "F" (LIST p1 p2) '((0 . "TEXT")))
ssllen (sslength ssl)

  )
  (COMMAND "-STYLE" "" "VERDANA" "" "" "" "" "")
  (repeat sslen
    (progn
      (setq tn   (entget (ssname ss n))
    tn1   (entget (ssname ssl n))
    fa   (cdr (assoc 11 tn))
    fb   (cdr (assoc 11 tn1))
    fbx   (car fb)
    fay   (car (cdr fa))
    fax   (car fa)
    x   (- fax fbx)
    fxyz  (list fbx fay 0.0)
    a11   (substr (cdr (assoc 1 tn)) 29)
    a22   (vl-string-position (ascii ".") a11)
    a   (substr a11 1 a22)
    a2   (substr a 1 (- a22 3))
    a3   (substr a (- a22 2) 3)
    a6   " "
    a4   "/"
    a5   (strcat a2 a4 a3)
    a1   (strcat a2 a6 a3)
    tn   (subst (cons 11 fxyz) (assoc 11 tn) tn)
    p1x   (car fxyz)
    p1y   (car (cdr fxyz))
    p1   (list (- p1x 15) (- p1y 6) 0.0)
    p2   (list ( p1x 15) ( p1y 15) 0.0)
    orgin (list 0.0 0.0 0.0)
    shift (list x 0.0 0.0)
    n   ( n 1)
      )
      (entmod tn)
      (command "insert" "BLR1" Fxyz "" "" "" a5 a1)
      (command "move" "w" p1 p2 "" orgin shift)

    )

  )
)


(defun c:ser ()
  (setq e (entget (car (entsel "Select the Text")))
f (cdr (assoc 11 e))
y (car (cdr f))
n 0
  )

  (command "zoom" "E")

  (setq p1 (list -100.0 ( y 1.0))
p2 (list 1000000.0 ( y 1.0))
ssl2 (ssget "F" (LIST p1 p2) '((0 . "LINE")))
ssllen2 (sslength ssl2)
ssllen21 (/ ssllen2 3)
na 0
nx 0.0
  )

  (repeat ssllen21
    (progn
      (setq tna1 (entget (ssname ssl2 na))
    tna2 (entget (ssname ssl2 ( na 2)))
    f1 (cdr (assoc 10 tna1))
    f2 (cdr (assoc 10 tna2))
    fx1 (car f1)
    fx2 (car f2)
    fy (car (cdr f1))
    x (/ ( fx2 fx1) 2)
    pm1 (list nx 0.0 0.0)
    pm2 (list x 0.0 0.0)
    p1x (car pm2)
    p1y (car (cdr pm2))
    p11 (list (- p1x 15) (- p1y 10) 0.0)
    p12 (list ( p1x 15) ( p1y 15) 0.0)
    na ( na 3)
    nx ( nx 100.0)
      )
      (command "move" "w" p11 p12 "" pm2 pm1)
    )
  )

  (setq p1    (list -100.0 y)
p2    (list 1000000.0 y)
ss    (ssget "F" (LIST p1 p2))
sslen (sslength ss)

  )
  (setq p1     (list -100.0 (- y 0.65))
p2     (list 1000000.0 (- y 0.65))
ssl    (ssget "F" (LIST p1 p2) '((0 . "TEXT")))
ssllen (sslength ssl)

  )


  (COMMAND "-STYLE" "" "VERDANA" "" "" "" "" "")
  (repeat sslen
    (progn
      (setq tn (entget (ssname ss n))
    tn1 (entget (ssname ssl n))
    fa (cdr (assoc 11 tn))
    fb (cdr (assoc 11 tn1))
    fbx (car fb)
    fay (car (cdr fa))
    fax (car fa)
    x (- fax fbx)
    fxyz (list fbx fay 0.0)
    a11 (substr (cdr (assoc 1 tn)) 29)
    a22 (vl-string-position (ascii ".") a11)
    a (substr a11 1 a22)
    a2 (substr a 1 (- a22 3))
    a3 (substr a (- a22 2) 3)
    a6 " "
    a4 "/"
    a5 (strcat a2 a4 a3)
    a1 (strcat a2 a6 a3)
    tn (subst (cons 11 fxyz) (assoc 11 tn) tn)
    n ( n 1)
      )
      (entmod tn)
      (command "insert" "BLR1" Fxyz "" "" "" a5 a1)
    )

  )
)


(defun c:SEE11 ()
  (setq e  (entget (car (entsel "Select the Base Line")))
a  (substr (cdr (assoc 8 e)) 4 5)
f  (cdr (assoc 10 e))
a2 (substr a 1 2)
a3 (substr a 3 3)
a6 " "
a4 "/"
a5 (strcat a2 a4 a3)
a1 (strcat a2 a6 a3)
  )
  (command "insert" "BLR" F "" "" "" a1 a5)
)

(defun c:leg ()
  (setq a  (getvar 'dwgname)
a1 (substr a 1 6)
a2 (substr a 1 2)
a3 (substr a 4 3)
a4 "/"
a5 (strcat a2 a4 a3)
  )
  (setq F (getpoint "select the insertion point FOR DIM BLOCK..."))
  (command "insert" "BLR" F "" "" "" a1 a5)
)

(defun c:css ()
  (setq p1  (getpoint "\nPick the First Corner First Plot :")
p2  (getpoint "\nPick the Other Corner First Plot :")
p3  (getpoint "\nPick the First Corner Second Plot :")
p4  (getpoint "\nPick the Other Corner Last Plot :")
p1x (car p1)
p1y (car (cdr p1))
p2x (car p2)
p2y (car (cdr p2))
p3x (car p3)
p3y (car (cdr p3))
p4x (car p4)
l   (- p2x p1x)
B   (- p2y p1y)
o   (- p3x p1x)
tl  (- p4x p1x)
np  (fix (- (/ ( tl (- o l)) o) 1.0))
  )
  (repeat np
    (setq pp1x ( p1x o)
  pp2x ( p2x o)
  pp1  (list pp1x p1y)
  pp2  (list pp2x p2y)
    )
    (command "-plot" "y"     ""      ""      ""      "m"     "l"
     "n"     "w"     pp1     pp2     "fit"   "centre"
     "yes"   "acad.ctb"      "yes"   "no"    "no"    "no"
     "yes"
    )
    (princ)
    (print pp1)
    (print pp2)
    (princ)

    (setq p1x pp1x
  p2x pp2x
    )
  )

)


(defun c:gsh ()
  (vl-load-com)
  (SETQ X 4
c 0
  )
  (repeat x
    (SETQ a (car (entsel "\nSelect the Shoulder Object :")))
    (setq b (vlax-ename->vla-object a)
  c ( c (vlax-get-property b 'area))
    )
  )
  (setq C    (- C 0.002)
text (entget (car (entsel "\nSelect the Text :")))
text (subst (cons 1 (strcat " " (rtos c 2 3)))
    (assoc 1 text)
    text
     )
  )
  (entmod text)
)

(defun c:ab ()
  (vl-load-com)
  (SETQ X 2
c 0
  )
  (repeat x
    (SETQ A (GETPOINT "\nSelect the Internal point Aggregate Base..."))
    (COMMAND "BOUNDARY" A "")
    (setq a (entlast)
  b (vlax-ename->vla-object a)
  c ( c (vlax-get-property b 'area))
    )
    (command "erase" a "")
  )
  (COMMAND "LAYER" "ON" "*" "")
  (setq text (entget (car (entsel "Select the Text :")))
text (subst (cons 1 (STRCAT " " (rtos c 2 3)))
    (assoc 1 text)
    text
     )
  )
  (entmod text)
)
(defun c:EE ()
  (COMMAND "LAYER" "SET" "0" "")
  (command "layer" "off" "sh" "")
  (vl-load-com)
  (SETQ X (getint "\nEnter No. of Area Excavation / Embankement... :")
c 0
  )
  (repeat x
    (SETQ A
   (GETPOINT
     "\nSelect the Internal point for Excavation / Embankement..."
   )
    )
    (COMMAND "BOUNDARY" A "")
    (setq a (entlast)
  b (vlax-ename->vla-object a)
  c ( c (vlax-get-property b 'area))
    )
    (command "erase" a "")
  )
  (COMMAND "LAYER" "ON" "*" "")
  (setq text (entget (car (entsel "Select the Text :")))
text (subst (cons 1 (STRCAT " " (rtos c 2 3)))
    (assoc 1 text)
    text
     )
  )
  (entmod text)
  (COMMAND "LAYER" "ON" "*" "")

)
(defun c:DDD ()
  (setq a      (getpoint "\n 选取相对点:")
dt     (entget (car (entsel "\n 选取相对点高程")))
b      (getpoint "\n 选取测量点:")
off    (entget (car (entsel "\n 选取测量点偏移距离 :")))
RLt    (entget (car (entsel "\n 选取测量点高程距离 :")))
ax     (car a)
ay     (car (cdr a))
bx     (car b)
by     (car (cdr b))
offset (- bx ax)
RL     (- by ay)
Dat    (atof (cdr (assoc 1 dt)))
Rl     ( dat RL)
rlt    (subst (cons 1 (STRCAT " " (rtos RL 2 2) " "))
      (assoc 1 rlt)
      rlt
       )
off    (subst (cons 1 (STRCAT " " (rtos offset 2 2) "m "))
      (assoc 1 off)
      off
       )
  )
  (entmod Rlt)
  (entmod off)
)

(defun c:lse ()
  (setq e (entget (car (entsel "Select the Text")))
f (cdr (assoc 11 e))
y (car (cdr f))
n 0
  )

  (command "zoom" "E")

  (setq p1 (list -100.0 ( y 1.0))
p2 (list 1000000.0 ( y 1.0))
ssl2 (ssget "F" (LIST p1 p2) '((0 . "LINE")))
ssllen2 (sslength ssl2)
ssllen21 (/ ssllen2 3)
na 0
nx 0.0
  )

  (repeat ssllen21
    (progn
      (setq tna1 (entget (ssname ssl2 na))
    tna2 (entget (ssname ssl2 ( na 2)))
    f1 (cdr (assoc 10 tna1))
    f2 (cdr (assoc 10 tna2))
    fx1 (car f1)
    fx2 (car f2)
    fy (car (cdr f1))
    x (/ ( fx2 fx1) 2)
    pm1 (list nx 0.0 0.0)
    pm2 (list x 0.0 0.0)
    p1x (car pm2)
    p1y (car (cdr pm2))
    p11 (list (- p1x 15) (- p1y 10) 0.0)
    p12 (list ( p1x 15) ( p1y 15) 0.0)
    na ( na 3)
    nx ( nx 100.0)
    DD (ssget "W" p11 p12 '((0 . "POLYLINE") (62 . 6)))
    ddl (sslength dd)
    DD1 (ssget "W" p11 p12 '((0 . "POLYLINE") (62 . 4)))
    n1 0
      )
      (command "LAYER" "N" "SH" "")
      (command "LAYER" "N" "SHT" "")
      (repeat ddl
(progn
  (setq x1 (entget (ssname dd n1))
x2 (entget (ssname dd1 n1))
x1 (subst (cons 8 "SH") (assoc 8 x1) x1)
x2 (subst (cons 8 "SHT") (assoc 8 x2) x2)
n1 ( n 1)
  )
  (entmod x1)
  (entmod x2)
)
      )
    )
  )
)
(defun C:arr ()
  (vl-load-com)
  (SETQ X (getint "\nEnter No. of Area :")
c 0
  )
  (repeat x
    (SETQ A (GETPOINT "\nSelect the Internal point.."))
    (COMMAND "BOUNDARY" A "")
    (setq a (entlast)
  b (vlax-ename->vla-object a)
  c ( c (vlax-get-property b 'area))
    )
    (command "erase" a "")
  )
  (COMMAND "LAYER" "ON" "*" "")
  (setq text (entget (car (entsel "Select the Text :")))
text (subst (cons 1 (rtos c 2 3)) (assoc 1 text) text)
  )
  (entmod text)
)
(defun C:arT ()
  (SETQ X 2
c 0
  )
  (vl-load-com)
  (repeat x
    (SETQ A (GETPOINT "\nSelect the Internal point.."))
    (COMMAND "BOUNDARY" A "")
    (setq a (entlast)
  b (vlax-ename->vla-object a)
  c ( c (vlax-get-property b 'area))
    )
    (command "erase" a "")
  )
  (command "textscr")
  (print)
  (print "**********************")
  (print)
  (princ (strcat " " (rtos c 2 3)))
  (print "**********************")
  (print)
)

(defun C:arTt ()
  (SETQ X 3
c 0
  )
  (repeat x
    (SETQ A (GETPOINT "\nSelect the Internal point.."))
    (COMMAND "BOUNDARY" A "")
    (setq a (entlast)
  b (vlax-ename->vla-object a)
  k (vlax-get-property b 'area)

  c ( c k)
    )
    (command "erase" a "")
    (print)
    (print "**********************")
    (print)
    (princ (rtos k 2 3))
    (print "**********************")
    (print)
  )
  (command "textscr")
  (print)
  (print "**********************")
  (print)
  (princ (rtos c 2 3))
  (print "**********************")
  (print)
)

(defun C:are ()
  (SETQ c 0
  )

  (SETQ A (GETPOINT "\nSelect the Internal point.."))
  (COMMAND "BOUNDARY" A "")
  (setq a (entlast)
b (vlax-ename->vla-object a)
c ( c (vlax-get-property b 'area))
  )
  (command "erase" a "")

  (command "textscr")
  (print)
  (print "**********************")
  (print)
  (princ (rtos c 2 3))
  (print "**********************")
  (print)
)

(defun c:act ()
  (setq text (entget (car (entsel "Select the Text :")))
a    "Actual "
x    (cdr (assoc 1 text))
l    (strlen x)
l    (- l 6)
s    (substr x l)
k    (getreal "Enter the tolerence :")
x2   (vl-string-right-trim s x)
f    (atof s)
g    (/ k 1000)
s1   (rtos (- f g) 2 3)
x1   (strcat a x2 s1)
text (subst (cons 1 x1) (assoc 1 text) text)
text (subst (cons 62 2) (assoc 62 text) text)
  )
  (entmod text)
)
(defun c:ac ()
  (setq text (car (entsel "Select the Text :"))
p    (getpoint "Pick Point :")
k    (getreal "Enter the tolerence :")
  )
  (command "scale" text "" p "0.7" "")
  (command "copy" text "" "0,0" "@1.5<-90")
  (SETQ text1 (entlast)
text  (entget text)
a     "Actual "
x     (cdr (assoc 1 text))
l     (strlen x)
l     (- l 6)
s     (substr x l)

x2    (vl-string-right-trim s x)
f     (atof s)
g     (/ k 1000)
s1    (rtos (- f g) 2 3)
x1    (strcat a x2 s1)
text  (subst (cons 1 x1) (assoc 1 text) text)
text  (subst (cons 62 2) (assoc 62 text) text)
  )
  (entmod text)
  (setq text (entget text1)
a    "Design "
x    (cdr (assoc 1 text))
x1   (strcat a x)
text (subst (cons 1 x1) (assoc 1 text) text)
text (subst (cons 62 2) (assoc 62 text) text)
  )
  (entmod text)
)
(defun c:des ()
  (setq text (entget (car (entsel "Select the Text :")))
a    "Design "
x    (cdr (assoc 1 text))
x1   (strcat a x)
text (subst (cons 1 x1) (assoc 1 text) text)
text (subst (cons 62 2) (assoc 62 text) text)
  )
  (entmod text)
)

(DEFUN C:drr ()
  (setq F (getpoint "select the insertion point FOR DIM BLOCK..."))
  (command "insert" "dR" F "" "" "")
  (COMMAND "EXPLODE" "L" "")
)

(DEFUN C:dLL ()
  (setq F (getpoint "select the insertion point FOR DIM BLOCK..."))
  (command "insert" "dl" F "" "" "")
  (COMMAND "EXPLODE" "L" "")
)

(DEFUN C:QTY ()
  (setq F (getpoint "select the insertion point FOR DIM BLOCK..."))
  (command "insert" "QTY" F "" "" "")
  (COMMAND "EXPLODE" "L" "")
)

(defun c:CF ()
  (setq AA (entSEL "Select OGL :"))
  (command "chprop" Aa "" "LA" "OGL" "" "")
  (setq AB (entSEL "Select QL :"))
  (command "chprop" AB "" "LA" "QL" "C" "WHITE" "")
)
(princ "loaded.")
(princ)

(defun c:sert ()
  (setq e (entget (car (entsel "Select the Text")))
f (cdr (assoc 11 e))
y (car (cdr f))
n 0
  )

  (command "zoom" "E")

  (setq p1 (list -100.0 ( y 1.0))
p2 (list 1000000.0 ( y 1.0))
ssl2 (ssget "F" (LIST p1 p2) '((0 . "LINE")))
ssllen2 (sslength ssl2)
ssllen21 (/ ssllen2 3)
na 0
nx 0.0
  )

  (repeat ssllen21
    (progn
      (setq tna1 (entget (ssname ssl2 na))
    tna2 (entget (ssname ssl2 ( na 2)))
    f1 (cdr (assoc 10 tna1))
    f2 (cdr (assoc 10 tna2))
    fx1 (car f1)
    fx2 (car f2)
    fy (car (cdr f1))
    x (/ ( fx2 fx1) 2)
    pm1 (list nx 0.0 0.0)
    pm2 (list x 0.0 0.0)
    p1x (car pm2)
    p1y (car (cdr pm2))
    p11 (list (- p1x 15) (- p1y 10) 0.0)
    p12 (list ( p1x 15) ( p1y 15) 0.0)
    na ( na 3)
    nx ( nx 100.0)
      )
      (command "move" "w" p11 p12 "" pm2 pm1)
    )
  )

  (setq p1    (list -100.0 y)
p2    (list 1000000.0 y)
ss    (ssget "F" (LIST p1 p2))
sslen (sslength ss)

  )
  (setq p1     (list -100.0 (- y 0.65))
p2     (list 1000000.0 (- y 0.65))
ssl    (ssget "F" (LIST p1 p2) '((0 . "TEXT")))
ssllen (sslength ssl)

  )


  (COMMAND "-STYLE" "" "VERDANA" "" "" "" "" "")
  (repeat sslen
    (progn
      (setq tn (entget (ssname ss n))
    tn1 (entget (ssname ssl n))
    fa (cdr (assoc 11 tn))
    fb (cdr (assoc 11 tn1))
    fbx (car fb)
    fay (car (cdr fa))
    fax (car fa)
    x (- fax fbx)
    fxyz (list fbx fay 0.0)
    a11 (substr (cdr (assoc 1 tn)) 29)
    a22 (vl-string-position (ascii ".") a11)
    a (substr a11 1 a22)
    a2 (substr a 1 (- a22 3))
    a3 (substr a (- a22 2) 3)
    a6 " "
    a4 "/"
    a5 (strcat a2 a4 a3)
    a1 (strcat a2 a6 a3)
    tn (subst (cons 11 fxyz) (assoc 11 tn) tn)
    n ( n 1)
      )
      (entmod tn)
      (command "insert" "BLR1T" Fxyz "" "" "" a5 a1)
    )

  )
)

(defun c:pldy ()
  (setq p1  (getpoint "\n选取第一张图纸左上点 :")
p2  (getpoint "\n选取第一张图纸右下点 :")
p3  (getpoint "\n选取第二张图纸左上点 :")
p4  (getpoint "\n选取最后一张图纸右下点 :")
p1x (car p1)
p1y (car (cdr p1))
p2x (car p2)
p2y (car (cdr p2))
p3x (car p3)
p3y (car (cdr p3))
p4x (car p4)
l   (- p2x p1x)
B   (- p2y p1y)
o   (- p3x p1x)
tl  (- p4x p1x)
np  (fix (- (/ ( tl (- o l)) o) 1.0))
  )
  (repeat np
    (setq pp1x ( p1x o)
  pp2x ( p2x o)
  pp1  (list pp1x p1y)
  pp2  (list pp2x p2y)
    )
    (command "-plot"    "y"   "" "" ""     "m"    "l"
     "n"    "w"    pp1   pp2 "1=2"    ""     ""
     "acad.ctb"    "y"   "A" "N" "N"    "Y"
    )
    (princ)
    (print pp1)
    (print pp2)
    (princ)

    (setq p1x pp1x
  p2x pp2x
    )
  )
)