[LISP程序]：[蜜蜂软体]编号程序For R2002（源代码公开）

netbee

;;说明：setclayer 函数为设置图层，setstyle 为设置字体;详见后面帖子
　　本程序需要CAD的扩展工具库，若没有请下载本文附件

[php]
;;;        ======================================
;;;        ‖        [基础绘图系统2.5]         ‖
;;;        ‖          桩位编号程序            ‖
;;;        ‖              V2.5                ‖
;;;        ‖      蜜蜂软体工作室 杨明峰       ‖
;;;        ======================================
;;;
;;;
;;;

(setq bh_began 1)
(setq text_offset 200.0)
;;(setq Newtextsize (getvar "textsize"))
(setq Newtextsize 350)
(setq texthome "")
(setq textend "")
(setq prog_dimzh T)
(defun c:DimStake_n (/                   setini         err_new
                     setclose           textstyle_old zbh_ok
                     bho           dimzin_old         TEXTSIZE_old
                     err_old           tmp　pt         pt1
                     zbh_zw           textoffset         settexthome
                     settextend           settextbegan         setclose_bh
                     settexth ss ee Drawtxt
                    )
;;;--------------------------------------------------------
;;;桩位编号初始化
  (defun setini        ()
    (setq textstyle_old (getvar "textstyle"))
    (setvar "cmdecho" 0)
    (setq dimzin_old (getvar "Dimzin"))
    (setvar "dimzin" 8)
    (setq err_old *error*)
    (setq *error* err_new)
    (gc)
;;以下为设置图层，因该函数已经整合在我的函数库中，所以在这里取消
   ;; (setclayer (list *Stake_num_layer* 3))
    ;;判断有无字类型ZBH
   ;; (setstyle (list
;;                (cons 2 "ZBH")
;;                '(3 . "txt")
;;                '(41 . 0.6)
;;
;;              ) ;_ 结束list
;;    ) ;_ 结束setstyle
    (command "_.undo" "be")

  ) ;_结束defun
;;;--------------------
  (defun err_new (msg)
    (setclose)
    (princ msg)
  ) ;_ 结束defun
  ;;-----------------
;;;恢复环境
  (defun setclose ()
    (setq *error* err_old)
    (setclayer '())
    (command "_.erase"ss "")
    (setvar "textstyle" textstyle_old)
    (setvar "dimzin" dimzin_old)
    (command "_.undo" "e")
    (setvar "cmdecho" 1)
    (Princ)
  ) ;_结束defun

;;;  -----------------------------------------------------
;;;--------------------------------------------
;;;按桩位编号
  (defun zbh_zw
         (/ sszwd sszwd1 sszw sslen loop_i loop_j ee pt0 ty bn pt)
    (defun zbh_draw (slist / slen loop_i)
      ;;给表sszwd根据从左到右,从上到下的规则排序(插入法).
      (setq slist (NetBee_px slist (list 1 < >))
            slen  (length slist)
      ) ;_ 结束setq
      ;;逐一从表sszwd中提取坐标进行标注
      (setq osmode_old (getvar "osmode"))
      (setvar "osmode" 0)
      (setq loop_i 0)
      (while (<= loop_i (1- slen))
        ;;关闭捕捉方式
        (setq pt (nth loop_i slist))
        (setq
          pt1
           (list (+ (car pt) text_offset) (+ (cadr pt) text_offset))
        ) ;_结束setq

        ;;将编号加上前后缀
        (setq zbh_ok (strcat texthome (itoa bh_began) textend))

        (command "_.text" "s" "ZBH" pt1 Newtextsize "0d" zbh_ok)
        ;;(setq bho (entlast))
        ;;(command "move" bho "" pt pt1)
        (setq bh_began (1+ bh_began))

        ;;恢复捕捉方式
        (setq loop_i (1+ loop_i))
      ) ;_结束while
      (setvar "osmode" osmode_old)
    ) ;_ 结束defun
    ;;-------------------
    (INITGET "A C")
    (setq
      tmp (getstring
            "\n请选择编号方式[统一编号(A)/按承台编号(C)]<统一编号>:"
          ) ;_ 结束getstring
    ) ;_ 结束setq
    (if        (or (= tmp "C")
            (= tmp "c")
        ) ;_ 结束or
      (progn
        (prompt "\n选择承台边线(多义线)：")
        (if (setq sszw
                   (ssget
                     (list '(0 . "LWPOLYLINE") (cons 8 *Stake_bx_style*))
                   ) ;_ 结束ssget
            ) ;_ 结束setq
          (setq sslen (sslength sszw))
          (setq sslen 0)
        ) ;_ 结束if
        (setq
          sszwd        '()
          loop_i 0
        ) ;_ 结束setq
        (while (< loop_i sslen)
          (setq ee (ssname sszw loop_i))
          (cond
            ((= (dxf 0 ee) "LWPOLYLINE")
             (setq tmp          (entget ee)
                   loop_j 0
                   sszwd  '()
             ) ;_ 结束setq
             (while (< loop_j (length tmp))
               (if (= (car (nth loop_j tmp)) 10)
                 (setq
                   sszwd (append sszwd (list (cdr (nth loop_j tmp))))
                 ) ;_ 结束setq
               ) ;_ 结束if
               (setq loop_j (1+ loop_j))
             ) ;_ 结束while
             (setq tmp          (ssget "_CP" sszwd (list (cons 8 *Stake_layer*)))
                   loop_j 0
                   sszwd  '()
             ) ;_ 结束setq
             (while (and tmp (< loop_j (sslength tmp)))
               (setq ee            (ssname tmp loop_j)
                     loop_j (1+ loop_j)
               ) ;_ 结束setq
               (if (not (member (dxf 10 ee) sszwd))
                 (setq sszwd (append sszwd (list (dxf 10 ee))))
               ) ;_ 结束if
             ) ;_ 结束while
             (setq bh_began 1)
             (zbh_draw sszwd)
            )
            ((= (dxf 0 ee) "INSERT")
             (setq pt0          (dxf 10 ee)
                   ty          (dxf 2 ee)
                   bn          (tblobjname "block" ty)
                   sszwd  '()
                   sszwd1 '()
             ) ;_ 结束setq
             (if (not (or (= ty "_FZ_K")
                          (= ty "_FZ_S")
                          (= ty "_YZ_K")
                          (= ty "_YZ_S")
                      ) ;_ 结束or
                 ) ;_ 结束not
               (progn (setq ee bn
                            pt (dxf 10 ee)
                      ) ;_ 结束setq
                      (while (= (type (setq ee (entnext ee))) 'ENAME)
                        (setq ty (dxf 2 ee))
                        (if (and (= (dxf 0 ee) "INSERT")
                                 (or (= ty "_FZ_K")
                                     (= ty "_FZ_S")
                                     (= ty "_YZ_K")
                                     (= ty "_YZ_S")
                                 ) ;_ 结束or
                            ) ;_ 结束and
                          (setq
                            sszwd (append
                                    sszwd
                                    (list (list        (+ (- (car (dxf 10 ee))
                                                      (car pt)
                                                   ) ;_ 结束-
                                                   (car pt0)
                                                ) ;_ 结束+
                                                (+ (- (cadr (dxf 10 ee))
                                                      (cadr pt)
                                                   ) ;_ 结束-
                                                   (cadr pt0)
                                                ) ;_ 结束+
                                                (+ (- (caddr (dxf 10 ee))
                                                      (caddr pt)
                                                   ) ;_ 结束-
                                                   (caddr pt0)
                                                ) ;_ 结束+
                                          ) ;_ 结束list
                                    ) ;_ 结束list
                                  ) ;_ 结束append
                          ) ;_ 结束setq
                        ) ;_ 结束if
                      ) ;_ 结束while
               ) ;_ 结束progn
             ) ;_ 结束if
             (setq bh_began 1)
             (zbh_draw sszwd)
            )
          ) ;_ 结束cond
          (setq loop_i (1+ loop_i))
        ) ;_ 结束while

      ) ;_ 结束progn
      (progn
        (setq sszw (ssget '(
                            ;;(8 . "桩位")
                           )
                   ) ;_ 结束ssget
        ) ;_ 结束setq
        (if sszw
          (setq sslen (sslength sszw))
          (setq sslen nil)
        ) ;_ 结束if
        (setq loop_i 1)
        (if (< sslen 5000)
          (prompt "\n 正在进行计算,请稍等...\n")
          (prompt
            "\n 数据过多，计算时间可能需要几分钟，请等待......\n"
          ) ;_ 结束prompt
        ) ;_ 结束if
        ;;提取所有桩位坐标到表sszwd
        (while (<= loop_i sslen)
          (setq ee (ssname sszw (1- loop_i)))

          (cond
            ((= (dxf 0 ee) "INSERT")
             (setq pt0 (dxf 10 ee)
                   ty  (dxf 2 ee)
                   bn  (tblobjname "block" ty)
             ) ;_ 结束setq
             (if (or (= ty "_FZ_K")
                     (= ty "_FZ_S")
                     (= ty "_YZ_K")
                     (= ty "_YZ_S")
                 ) ;_ 结束or
               (if (not (member (dxf 10 ee) sszwd))
                 (setq sszwd (append sszwd (list (dxf 10 ee))))
               ) ;_ 结束if
               (progn
                 (setq ee bn
                       pt (dxf 10 ee)
                 ) ;_ 结束setq
                 (while        (= (type (setq ee (entnext ee))) 'ENAME)
                   (setq ty (dxf 2 ee))
                   (if (and (= (dxf 0 ee) "INSERT")
                            (or        (= ty "_FZ_K")
                                (= ty "_FZ_S")
                                (= ty "_YZ_K")
                                (= ty "_YZ_S")
                            ) ;_ 结束or
                       ) ;_ 结束and
                     (if (not (member (list (+ (- (car (dxf 10 ee))
                                                  (car pt)
                                               ) ;_ 结束-
                                               (car pt0)
                                            ) ;_ 结束+
                                            (+ (- (cadr (dxf 10 ee))
                                                  (cadr pt)
                                               ) ;_ 结束-
                                               (cadr pt0)
                                            ) ;_ 结束+
                                            (+ (- (caddr (dxf 10 ee))
                                                  (caddr pt)
                                               ) ;_ 结束-
                                               (caddr pt0)
                                            ) ;_ 结束+
                                      ) ;_ 结束list
                                      sszwd
                              ) ;_ 结束member
                         ) ;_ 结束not
                       (setq
                         sszwd (append
                                 sszwd
                                 (list (list (+        (- (car (dxf 10 ee))
                                                   (car pt)
                                                ) ;_ 结束-
                                                (car pt0)
                                             ) ;_ 结束+
                                             (+        (- (cadr (dxf 10 ee))
                                                   (cadr pt)
                                                ) ;_ 结束-
                                                (cadr pt0)
                                             ) ;_ 结束+
                                             (+        (- (caddr (dxf 10 ee))
                                                   (caddr pt)
                                                ) ;_ 结束-
                                                (caddr pt0)
                                             ) ;_ 结束+
                                       ) ;_ 结束list
                                 ) ;_ 结束list
                               ) ;_ 结束append
                       ) ;_ 结束setq
                     ) ;_ 结束if
                   ) ;_ 结束if
                 ) ;_ 结束while
               ) ;_ 结束progn
             ) ;_ 结束if
            )
            ((= (dxf 8 ee) *Stake_layer*)
             (if (not (member (dxf 10 ee) sszwd))
               (setq
                 sszwd
                  (append
                    sszwd
                    (list (dxf 10 ee))
                  ) ;_ 结束append
               ) ;_ 结束setq
             ) ;_ 结束if
            )
          ) ;_ 结束cond
          (setq loop_i (1+ loop_i))
        ) ;_结束while
        (zbh_draw sszwd)
      ) ;_ 结束progn
    ) ;_ 结束if
  ) ;_ 结束defun

;;;------------------------------------------------------------
  (defun textoffset (/ tmp)
    (setq tmp text_offset)
    (prompt "\n请输入标注偏移量<")
    (princ tmp)
    (prompt ">:")
    (if        (setq tmp (getreal))
      (progn(setq text_offset tmp))
    ) ;_结束if
  ) ;_结束defun
;;;--------------------------------------------------------------
  (defun settexthome (/ tmp)
    (if        (/=
          (setq
            tmp        (getstring
                  (strcat "\n请输入编号前缀(无前缀请输入\"*\")<"
                          texthome
                          ">:"
                  ) ;_ 结束strcat
                ) ;_ 结束getstring
          ) ;_ 结束setq
        ) ;_ 结束/=
      (setq texthome tmp)
    ) ;_ 结束if
    (if        (= texthome "*")
      (SETQ texthome "")
    ) ;_结束if
  ) ;_结束defun

;;;--------------------------------------------------------
  (defun settextend (/ tmp)
    (if        (/=
          (setq
            tmp        (getstring
                  (strcat "\n请输入编号后缀(无后缀请输入\"*\")<"
                          textend
                          ">:"
                  ) ;_ 结束strcat
                ) ;_ 结束getstring
          ) ;_ 结束setq
        ) ;_ 结束/=
      (setq textend tmp)
    ) ;_结束if
    (if        (= textend "*")
      (SETQ textend "")
    ) ;_结束if
  ) ;_结束defun
;;;--------------------------------------------------------
  (defun settextbegan (/ tmp)
    (if        (setq tmp
               (getint
                 (strcat "\n起始编号:1/2/3...<" (itoa bh_began) ">:")
               ) ;_结束getint
        ) ;_结束setq
      (setq bh_began tmp)
    ) ;_结束if
  ) ;_结束defun

;;;-----------------------------
;;;删除原文字，并重新绘制文字
(defun Drawtxt()
      ;;关闭捕捉方式
     (if ss(command "_.erase"ss""))
     (setq osmode_old (getvar "osmode"))
     (setvar "osmode" 0)
     (setq pt '(0 0)
       pt1 (list (+ (car pt) text_offset) (+ (cadr pt) text_offset))
     ) ;_结束setq

     ;;将编号加上前后缀
     (setq zbh_ok (strcat texthome (itoa bh_began) textend))

     (command "_.text" "s" "ZBH" pt1 Newtextsize "0d" zbh_ok)
     (redraw (entlast) 2)
     (setvar "osmode" osmode_old)
     (setq ss (ssadd))
  (ssadd (entlast) ss)
  )
;;;-------------------------------------------------------
;;;设置字高函数
  (defun settexth (/ tmp)
    (if        (setq
          tmp (getreal (strcat "\n输入字高:<" (rtos Newtextsize) ">:"))
        ) ;_ 结束setq
      (setq Newtextsize tmp)
    ) ;_结束if

  ) ;_结束defun
;;;-------------------------------------------------------
  ;;(defun *error* (msg)
  ;; (setclose_bh)
  ;;) ;_结束defun

;;;----------------------------------------

  (prompt "\n桩位自动编号标注程序")

  ;;初始化
  (setini)
  ;;用while控制标注的循环,回车退出标注
  (while
    (progn
      
     ;;(setq bho (entlast))
     ;;(command "move" bho "" pt pt1)
      (while
        (progn
          ;;绘制文字
          (Drawtxt)
          (setq        tmp
                 (strcat "\n选择标注点"
                         " [前缀(M):"
                         texthome
                         "/后缀(E):"
                         textend
                         "/字高(H):"
                         (rtos Newtextsize)
                         "/偏移量(O):"
                         (rtos text_offset)
                         "/编号(N):"
                         (itoa bh_began)
                         "/选择工程桩(Z)]:"

                 ) ;_结束strcat
          ) ;_结束setq
          (initget "M E H O N Z")
         ; (setq pt (getpoint tmp))
          (setq pt (acet-ss-drag-move ss '(0 0 0) tmp))
          (if (= (type pt) 'STR)
            (cond ((= pt "M") (settexthome) (not nil))
                  ((= pt "E") (settextend) (not nil))
                  ((= pt "H") (settexth) (not nil))
                  ((= pt "O") (textoffset) (not nil))
                  ((= pt "N") (settextbegan) (not nil))
                  ((= pt "Z") (zbh_zw) (not nil))
                  (t t)
            ) ;_结束cond
            (not t)
          ) ;_结束if

        ) ;_结束progn
      ) ;_结束while
      (if (not pt)
        (not t)
        (not nil)
      ) ;_结束if
    ) ;_结束progn
    (setq osmode_old (getvar "osmode"))
     (setvar "osmode" 0)
     (command "Move" ss "" '(0 0) pt)
     (setq bh_began (1+ bh_began)
           ss(ssadd)
           )

     ;;恢复捕捉方式
     (setvar "osmode" osmode_old)
  ) ;_结束while
  (command "_.erase" ss "")
  (setclose)
) ;_结束defun
[/php]

tywsc

我做室外管线设计，也用到多义线，希望您提供有关承台边线(多义线)的图纸简图一张。多谢了。

netbee

这里把函数也附上吧

2. 
   
3. ;;;====================================================
   
4. (defun setclayer (slist / cname cor ctmp tmp lsty)
   
5.   (setq        ctmp (strcat "\n(setclayer '(层名 颜色))！"
   
6.                      "\n(setclayer "轴线")设置当前图层"
   
7.              ) ;_ end of strcat
   
8.   ) ;_ end of setq
   
9.   (cond        ((= (type slist) 'LIST)
   
10.          (setq cname (car slist)
    
11.                cor   (cadr slist)
    
12.                lsty (caddr slist)
    
13.          ) ;_ end of setq
    
14.          (if (not lsty)(setq lsty "CONTINUOUS"))
    
15.         )
    
16.         ((= (type slist) 'STR)
    
17.          (setq cname slist)
    
18.         )
    
19.   ) ;_ end of cond
    
20.   (cond        ((= slist '?)
    
21.          (alert ctmp)
    
22.         )
    
23.         ((not slist)
    
24.          (if clayer_old
    
25.            (setvar "clayer" clayer_old)
    
26.            (setvar "clayer" "0")
    
27.          ) ;_ end of if
    
28.         )
    
29.         ((and cname cor (= (type cname) 'STR) (= (type cor) 'INT))
    
30.          (if (and (tblobjname "LAYER" cname)
    
31.                   (setq tmp (entget (tblobjname "LAYER" cname)))
    
32.              ) ;_ 结束and
    
33.            (progn (setq        tmp (subst (cons 62 cor)
    
34.                                    (assoc 62 tmp)
    
35. 
    
36.                                    tmp
    
37.                             ) ;_ 结束subst
    
38.                         tmp (subst (cons 70 0) (assoc 70 tmp) tmp)
    
39.                   ) ;_ 结束setq
    
40.                   (entmod tmp)
    
41.            ) ;_ 结束progn
    
42.            (entmake (list
    
43.                       '(0 . "LAYER")
    
44.                       '(100 . "AcDbSymbolTableRecord")
    
45.                       '(100 . "AcDbLayerTableRecord")
    
46.                       (cons 6 lsty)
    
47.                       (cons 62 cor)
    
48.                       '(70 . 0)
    
49.                       (cons 2 cname)
    
50.                     ) ;_ end of list
    
51.            ) ;_ end of entmake
    
52. 
    
53.          ) ;_ end of if
    
54.          (setq clayer_old (getvar "clayer"))
    
55.          (setvar "clayer" cname)
    
56.         )
    
57.         ((and (= (type cname) 'STR))
    
58.          (if (setq tmp (entget (tblobjname "LAYER" cname)))
    
59.            (progn (setvar "clayer" cname)
    
60.                   (setq        tmp (subst (cons 62 cor)
    
61.                                    (assoc 62 tmp)
    
62.                                    tmp
    
63.                             ) ;_ 结束subst
    
64.                         tmp (subst (cons 70 0) (assoc 70 tmp) tmp)
    
65.                   ) ;_ 结束setq
    
66.                   (entmod tmp)
    
67.            ) ;_ 结束progn
    
68.            (progn (entmake (list
    
69.                              '(0 . "LAYER")
    
70.                              '(100 . "AcDbSymbolTableRecord")
    
71.                              '(100 . "AcDbLayerTableRecord")
    
72.                              (cons 6 lsty)
    
73.                              (cons 62 7)
    
74.                              '(70 . 0)
    
75.                              (cons 2 cname)
    
76.                            ) ;_ end of list
    
77.                   ) ;_ end of entmake
    
78.            ) ;_ end of progn
    
79.          ) ;_ end of if
    
80.          (setq clayer_old (getvar "clayer"))
    
81.          (setvar "clayer" cname)
    
82.         )
    
83.         (T (progn (alert (strcat "\n数据错误：" ctmp))))
    
84.   ) ;_ end of cond
    
85.   (princ)
    
86. ) ;_ end of defun
    
87. 
    
88. ;;;========================================
    
89. (defun setstyle        (slist / tlist textn textf ctmp tf)
    
90.   (setq        ctmp (strcat
    
91.                "\n(setstyle '((2. "宋体")(3 . "SIMSUN.TTF")(40 . 0)(41 . 0.8)...)！"
    
92.                "\n(setstyle "宋体")设置当前字体"
    
93.                "\n各参数意义如下："
    
94.                "\n2        样式名称"
    
95.                "\n40        固定文字高度；如果高度不固定则值为 0"
    
96.                "\n41        宽度因子"
    
97.                "\n50        倾斜角"
    
98.                "\n71        文字生成标志："
    
99.                "\n        2 = 文字反向（X 轴方向镜像）"
    
100.                "\n        4 = 文字倒置（Y 轴方向镜像）"
     
101.                "\n42        最后使用的高度"
     
102.                "\n3        主字体文件名"
     
103.                "\n4        大字体文件名；如果没有则为空"
     
104.               ) ;_ 结束strcat
     
105. ;_ end of strcat
     
106.         tf   nil
     
107.   ) ;_ end of setq
     
108. 
     
109.   (if (= (type slist) 'LIST)
     
110.     (setq textn        (if (assoc 2 slist)
     
111.                   (cdr (assoc 2 slist))
     
112.                 ) ;_样式名称
     
113.           textf        (if (assoc 3 slist)
     
114.                   (cdr (assoc 3 slist))
     
115.                 ) ;_主字体名称
     
116. ;_文字生成标志2＝文字反向（X轴方向镜像）4＝文字倒置（Y轴方向）
     
117.           slist        (if (not (assoc 3 slist))
     
118.                   (progn (setq textf "txt") (append slist '((3 . "txt"))))
     
119.                   slist
     
120.                 ) ;_ end of if
     
121.           slist        (if (not (assoc 40 slist))
     
122.                   (append slist '((40 . 0.0)))
     
123.                   slist
     
124.                 ) ;_ end of if
     
125.           slist        (if (not (assoc 41 slist))
     
126.                   (append slist '((41 . 1.0)))
     
127.                   slist
     
128.                 ) ;_ end of if
     
129.           slist        (if (not (assoc 50 slist))
     
130.                   (append slist '((50 . 0.0)))
     
131.                   slist
     
132.                 ) ;_ end of if
     
133.           slist        (append        '((0
     
134.                            .
     
135.                            "STYLE"
     
136.                           )
     
137.                          )
     
138.                         '((100
     
139.                            .
     
140.                            "AcDbSymbolTableRecord"
     
141.                           )
     
142.                          )
     
143.                         '((100
     
144.                            .
     
145.                            "AcDbTextStyleTableRecord"
     
146.                           )
     
147.                          )
     
148.                         '((70
     
149.                            .
     
150.                            0
     
151.                           )
     
152.                          )
     
153.                         slist
     
154.                 ) ;_ end of append
     
155. 
     
156.     ) ;_ end of setq
     
157.   ) ;_ end of if
     
158.   (if (= (type slist) 'STR)
     
159.     (setq textn        slist
     
160.     ) ;_ end of setq
     
161.   ) ;_ end of if
     
162.   (cond        ((= slist '?)
     
163.          (alert ctmp)
     
164.         )
     
165.         ((not slist)
     
166.          (if style_old
     
167.            (setvar "TEXTSTYLE" clayer_old)
     
168.            (setvar "TEXTSTYLE" "standard")
     
169.          ) ;_ end of if
     
170.          (setq tf t)
     
171.         )
     
172.         ((and textn textf (= (type slist) 'LIST))
     
173.          (if (tblobjname "STYLE" textn)
     
174.            (progn (setq
     
175.                     slist (append
     
176.                             (list (assoc -1 (entget (tblobjname "style" textn))))
     
177.                             slist
     
178.                           ) ;_ end of append
     
179.                     test  slist
     
180.                   ) ;_ end of setq
     
181. 
     
182.                   (entmod slist)
     
183.                   (setq tf t)
     
184.            ) ;_ end of progn
     
185.            (progn (entmake slist) (setq tf t))
     
186.          ) ;_ end of if
     
187.          (setq style_old (getvar "TEXTSTYLE"))
     
188.          (setvar "TEXTSTYLE" textn)
     
189.         )
     
190.         ((and (= (type slist) 'STR))
     
191.          (if (tblobjname "STYLE" textn)
     
192.            (progn (setvar "TEXTSTYLE" textn)
     
193.                   (setq tf T)
     
194.                   (setq style_old (getvar "TEXTSTYLE"))
     
195.                   (setvar "TEXTSTYLE" textn)
     
196.            ) ;_ 结束progn
     
197.          ) ;_ 结束if
     
198.         )
     
199.         (T
     
200.          t
     
201.         )
     
202.   ) ;_ end of cond
     
203.   tf
     
204. ) ;_ end of defun
     

<br /> ;;;====================================================<br /> (defun setclayer (slist / cname cor ctmp tmp lsty)<br />   (setq        ctmp (strcat "\n(setclayer '(层名 颜色))！"<br />                      "\n(setclayer "轴线")设置当前图层"<br />              ) ;_ end of strcat<br />   ) ;_ end of setq<br />   (cond        ((= (type slist) 'LIST)<br />          (setq cname (car slist)<br />                cor   (cadr slist)<br />                lsty (caddr slist)<br />          ) ;_ end of setq<br />          (if (not lsty)(setq lsty "CONTINUOUS"))<br />         )<br />         ((= (type slist) 'STR)<br />          (setq cname slist)<br />         )<br />   ) ;_ end of cond<br />   (cond        ((= slist '?)<br />          (alert ctmp)<br />         )<br />         ((not slist)<br />          (if clayer_old<br />            (setvar "clayer" clayer_old)<br />            (setvar "clayer" "0")<br />          ) ;_ end of if<br />         )<br />         ((and cname cor (= (type cname) 'STR) (= (type cor) 'INT))<br />          (if (and (tblobjname "LAYER" cname)<br />                   (setq tmp (entget (tblobjname "LAYER" cname)))<br />              ) ;_ 结束and<br />            (progn (setq        tmp (subst (cons 62 cor)<br />                                    (assoc 62 tmp)<br /> <br />                                    tmp<br />                             ) ;_ 结束subst<br />                         tmp (subst (cons 70 0) (assoc 70 tmp) tmp)<br />                   ) ;_ 结束setq<br />                   (entmod tmp)<br />            ) ;_ 结束progn<br />            (entmake (list<br />                       '(0 . "LAYER")<br />                       '(100 . "AcDbSymbolTableRecord")<br />                       '(100 . "AcDbLayerTableRecord")<br />                       (cons 6 lsty)<br />                       (cons 62 cor)<br />                       '(70 . 0)<br />                       (cons 2 cname)<br />                     ) ;_ end of list<br />            ) ;_ end of entmake<br /> <br />          ) ;_ end of if<br />          (setq clayer_old (getvar "clayer"))<br />          (setvar "clayer" cname)<br />         )<br />         ((and (= (type cname) 'STR))<br />          (if (setq tmp (entget (tblobjname "LAYER" cname)))<br />            (progn (setvar "clayer" cname)<br />                   (setq        tmp (subst (cons 62 cor)<br />                                    (assoc 62 tmp)<br />                                    tmp<br />                             ) ;_ 结束subst<br />                         tmp (subst (cons 70 0) (assoc 70 tmp) tmp)<br />                   ) ;_ 结束setq<br />                   (entmod tmp)<br />            ) ;_ 结束progn<br />            (progn (entmake (list<br />                              '(0 . "LAYER")<br />                              '(100 . "AcDbSymbolTableRecord")<br />                              '(100 . "AcDbLayerTableRecord")<br />                              (cons 6 lsty)<br />                              (cons 62 7)<br />                              '(70 . 0)<br />                              (cons 2 cname)<br />                            ) ;_ end of list<br />                   ) ;_ end of entmake<br />            ) ;_ end of progn<br />          ) ;_ end of if<br />          (setq clayer_old (getvar "clayer"))<br />          (setvar "clayer" cname)<br />         )<br />         (T (progn (alert (strcat "\n数据错误：" ctmp))))<br />   ) ;_ end of cond<br />   (princ)<br /> ) ;_ end of defun<br /> <br /> ;;;========================================<br /> (defun setstyle        (slist / tlist textn textf ctmp tf)<br />   (setq        ctmp (strcat<br />                "\n(setstyle '((2. "宋体")(3 . "SIMSUN.TTF")(40 . 0)(41 . 0.8)...)！"<br />                "\n(setstyle "宋体")设置当前字体"<br />                "\n各参数意义如下："<br />                "\n2        样式名称"<br />                "\n40        固定文字高度；如果高度不固定则值为 0"<br />                "\n41        宽度因子"<br />                "\n50        倾斜角"<br />                "\n71        文字生成标志："<br />                "\n        2 = 文字反向（X 轴方向镜像）"<br />                "\n        4 = 文字倒置（Y 轴方向镜像）"<br />                "\n42        最后使用的高度"<br />                "\n3        主字体文件名"<br />                "\n4        大字体文件名；如果没有则为空"<br />               ) ;_ 结束strcat<br /> ;_ end of strcat<br />         tf   nil<br />   ) ;_ end of setq<br /> <br />   (if (= (type slist) 'LIST)<br />     (setq textn        (if (assoc 2 slist)<br />                   (cdr (assoc 2 slist))<br />                 ) ;_样式名称<br />           textf        (if (assoc 3 slist)<br />                   (cdr (assoc 3 slist))<br />                 ) ;_主字体名称<br /> ;_文字生成标志2＝文字反向（X轴方向镜像）4＝文字倒置（Y轴方向）<br />           slist        (if (not (assoc 3 slist))<br />                   (progn (setq textf "txt") (append slist '((3 . "txt"))))<br />                   slist<br />                 ) ;_ end of if<br />           slist        (if (not (assoc 40 slist))<br />                   (append slist '((40 . 0.0)))<br />                   slist<br />                 ) ;_ end of if<br />           slist        (if (not (assoc 41 slist))<br />                   (append slist '((41 . 1.0)))<br />                   slist<br />                 ) ;_ end of if<br />           slist        (if (not (assoc 50 slist))<br />                   (append slist '((50 . 0.0)))<br />                   slist<br />                 ) ;_ end of if<br />           slist        (append        '((0<br />                            .<br />                            "STYLE"<br />                           )<br />                          )<br />                         '((100<br />                            .<br />                            "AcDbSymbolTableRecord"<br />                           )<br />                          )<br />                         '((100<br />                            .<br />                            "AcDbTextStyleTableRecord"<br />                           )<br />                          )<br />                         '((70<br />                            .<br />                            0<br />                           )<br />                          )<br />                         slist<br />                 ) ;_ end of append<br /> <br />     ) ;_ end of setq<br />   ) ;_ end of if<br />   (if (= (type slist) 'STR)<br />     (setq textn        slist<br />     ) ;_ end of setq<br />   ) ;_ end of if<br />   (cond        ((= slist '?)<br />          (alert ctmp)<br />         )<br />         ((not slist)<br />          (if style_old<br />            (setvar "TEXTSTYLE" clayer_old)<br />            (setvar "TEXTSTYLE" "standard")<br />          ) ;_ end of if<br />          (setq tf t)<br />         )<br />         ((and textn textf (= (type slist) 'LIST))<br />          (if (tblobjname "STYLE" textn)<br />            (progn (setq<br />                     slist (append<br />                             (list (assoc -1 (entget (tblobjname "style" textn))))<br />                             slist<br />                           ) ;_ end of append<br />                     test  slist<br />                   ) ;_ end of setq<br /> <br />                   (entmod slist)<br />                   (setq tf t)<br />            ) ;_ end of progn<br />            (progn (entmake slist) (setq tf t))<br />          ) ;_ end of if<br />          (setq style_old (getvar "TEXTSTYLE"))<br />          (setvar "TEXTSTYLE" textn)<br />         )<br />         ((and (= (type slist) 'STR))<br />          (if (tblobjname "STYLE" textn)<br />            (progn (setvar "TEXTSTYLE" textn)<br />                   (setq tf T)<br />                   (setq style_old (getvar "TEXTSTYLE"))<br />                   (setvar "TEXTSTYLE" textn)<br />            ) ;_ 结束progn<br />          ) ;_ 结束if<br />         )<br />         (T<br />          t<br />         )<br />   ) ;_ end of cond<br />   tf<br /> ) ;_ end of defun<br />

sfjlx

镇无私！谢谢！

0451doctor

这个软件是干什么用的！

ss1025

是不是存成.lsp文件就可以用啊。
斑竹能不能说的更明确些。

netbee

是的。
这是最基本的知识呀!

GPTDDLJH

请问,这个程序是编那种类型号,适用于哪种行业!
多多包涵!!!!!!

netbee

主要常用于带固定前缀的顺序编号，由于我是从事工程测量，所以针对本行业中的基础竣工图中的桩位编号做了一些专门的优化。
其他用法，可以编电信设计中的杆号之类的。

li809

好用,编电气\给排水等图纸时也用得到的

kill99

对于我做总图的太方便啦。谢谢

ss1025

请教楼主：为什么我用的时候总是错误提示呢？
命令: yy
桩位自动编号标注程序
选择标注点
[前缀(M):/后缀(E):/字高(H):350/偏移量(O):200/编号(N):1/选择工程桩(Z)]:z
请选择编号方式[统一编号(A)/按承台编号(C)]<统一编号>:
选择对象: 指定对角点: 找到 6 个
选择对象:
正在进行计算,请稍等...
no function definition: DXF

netbee

呵呵，这是我针对基础竣工平面图中的桩位图块（我所编写的基础绘图系统）而写！它只认图块名为"_YZ_K"之类的块。

2. 
   
3. ;;;=====================
   
4. ;;;返回实体指定的表项
   
5. (DEFUN dxf (st ss) (CDR (ASSOC st (ENTGET ss))))
   

<br /> ;;;=====================<br /> ;;;返回实体指定的表项<br /> (DEFUN dxf (st ss) (CDR (ASSOC st (ENTGET ss))))<br />

ss1025

楼主，还是错误提示啊!
命令: yy
桩位自动编号标注程序
选择标注点
[前缀(M):/后缀(E):/字高(H):350/偏移量(O):200/编号(N):1/选择工程桩(Z)]:z
请选择编号方式[统一编号(A)/按承台编号(C)]<统一编号>:
选择对象: 指定对角点: 找到 6 个
选择对象:
正在进行计算,请稍等...
no function definition: NETBEE_PX

netbee

呵呵，老是忘记将函数从库中取出。你从这里下载吧
netbee_px