[LISP函数]：板柱及高手请进！！SOS！

petertian

我在在R14下编了个LISP程序，LOAD进来后，输入命令4110（我的4110函数没有参数）后，我的线就变成了铁路，但是每次执行只能将一条线变成铁路，并且要输入两个参数，是否有母线（Y/N），输入Y后，会让你选择要变的线，然后，这条线就变成了铁路；输入N后，他将会另划一条铁路。我现在图内有好多条铁路，我应该怎样才能使我的图内的铁路线全部变成铁路，批处理，只运行一次，铁路全部画出来，我的程序见附件！不胜感激！

petertian

上一个附件是我修改过的，现在的这个附件好了！代码如下：
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;交通及附属设施
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:4110()
   (if (GetLine "4110" "\n依比例铁路中线:")(progn
   (short_line blk_set centn 5 -1.2175 10 2.435 0.4 90 color 1)
   (setq centn xm)
   (parall blk_set centn 1.0 0.7175 0.2 color 1)
   (setq centn xm)
   (parall blk_set centn -1.0 0.7175 0.2 color 1)
   (creat_blk blk_set centn blk_name1)
   (chglayer centn)
))
)
(defun c:4111()
   (if (GetLine "4111" "\n不依比例铁路:")(progn
   (parall blk_set centn -1.0 0.4 0 color 1)
   (parall blk_set centn 1.0 0.4 0 color 1)
   (xuxian blk_set centn 0 5 0.8 10 10 color 1)
   (creat_blk blk_set centn blk_name1)
   (chglayer centn)
))
)
(DEFUN short_line(blk_set centn startlen off symdist slength width ang color inblk / S0 S4 dp pp fx sp ep r fx)
   (command "color" color)
   (setq BILICHI (GETVAR "LTSCALE"))
   (setq fx 0.0)
   (if (< off 0.0)(setq fx -1.0)(setq fx 1.0))
   (setq off (* (abs off) bilichi) startlen (* startlen bilichi) width (* width bilichi) slength (* slength bilichi) symdist (* symdist bilichi))
   (setq r (/ (* PI ang) 180))
   (command "pline" "0,0" "w" width "" "1,1" "")
   (command "erase" (entlast) "")
   (get_pt_tbl centn)
   (setq s4 startlen)
   (setq dp (car pt_tbl))
   (FOREACH PP pt_tbl
      (SETQ S0 (DISTANCE DP PP))
      (WHILE (> S0 S4)
         (IIPP DP PP S4)
         (setq sp (polar cp (+ (angle dp cp) (* fx (/ pi 2))) off))
         (setq ep (polar sp (+ r (ANGLE DP PP)) slength))
         (COMMAND "pline" sp ep "")
         (if (= inblk 1)
            (progn
               (setq tmp (entlast))
               (ssadd tmp blk_set)
               (addexdata)
            )
         )
         (SETQ DP CP S0 (DISTANCE CP PP) S4 symdist)
      )
      (SETQ S4 (- S4 S0) DP PP)
   )
   (command "pline" "0,0" "w" 0 "" "1,1" "")
   (command "erase" (entlast) "")
)
;画平行线
;( 块,线名,方向<+1.0---左 -1.0--右>,偏移宽,颜色)
(defun parall(blk_set centn ca d width color inblk / p pp)   
        (command "color" color)
        (setq bilich (getvar "ltscale"))
        (setq width (* width bilichi))
        (command "pline" "0,0" "w" width "" "1,1" "")
        (command "erase" (entlast) "")
        (setq d (* d bilichi))
        (setq ca (- 0.0 ca))
   (zaobiao centn cnn)
   (setq p (reverse cbiao))
   (setq l (length p))
        (setq f1 nil pnt4 nil f2 nil c 0)
        (setq pnt1 (nth 0 p) i 1)
        (while (< i l)
                (if (> c 0) (setq f1 pnt3 f2 pnt4))
                (setq pnt2 (nth i p))
                (setq c (+ c 1))
                (setq a (angle pnt1 pnt2))
                (setq pnt3 (polar pnt1 (+ a (* ca (dtr 90))) d))
                (setq pnt4 (polar pnt2 (+ a (* ca (dtr 90))) d))
                (if (= c 1) (setq pp (list pnt3)))
                (setq pnt1 pnt2)
                (if (/= f1 nil)
                        (progn
                                (setq ppp (inters f1 f2 pnt3 pnt4 nil))
                                (if (not ppp) (setq ppp f2))
                                (setq pp (cons ppp pp))
                        )
                )
                (if (= i (- l 1))
                        (progn
                                (setq pp (cons pnt4 pp))
                                (setq pp (reverse pp))
                        )
                )
                (setq i (1+ i))
        )
   (setq pp (reverse pp))
        (command "pline" (nth 0 pp))
        (setq i 1)
        (while (< i l)
                (command (nth i pp))
                (setq i (1+ i))
        )
        (command "")
   (if (= inblk 1)
                (progn
                        (setq tmp (entlast))
                        (ssadd tmp blk_set)
         (addexdata)
                )
        )
        (command "color" "bylayer")
        (command "pline" "0,0" "w" 0.0 0.0 "1,1" "")
        (command "erase" (entlast) "")
)
(defun getline(symcode msg / no pt1 hl tmp1 tmp2 tmp3 i il tab layer ltype color)
   (setq mapname (strcase (getvar "dwgname")))
   (setq mappath (getvar "dwgprefix"))
   (setq len1 (strlen mapname))
   (setq len2 (strlen mappath))
   (setq tmp1 (rtos (getvar "tdcreate")))
   (setq i 1 il (strlen tmp1) tmp3 "")
   (while (<= i il)
      (setq tmp2 (substr tmp1 i 1))
      (if (= tmp2 ".")(setq tmp2 ""))
      (setq tmp3 (strcat tmp3 tmp2))
      (setq i (+ i 1))
   )
   (setq blk_name (strcat "LINE-" symcode "-" tmp3 "-"))
   (setq blk_exist 1)
   (setq i 0)
   (while (/= blk_exist nil)
      (setq blk_name1 (strcat blk_name (itoa i)))
      (setq blk_exist (tblsearch "BLOCK" blk_name1))
      (setq i (+ i 1))
   )
   (if (/= Auto_Sym "AUTO")
      (progn
         (princ msg)
         (initget 1 "Y y N n")   
         (initget 128)
         (setq pt1 (getpoint "\n有母线吗(Y/N):"))
         (if (= 'STR (type pt1))
            (SETQ HL (STRCASE pt1))
         )
         (if (= (type pt1) 'LIST)
            (SETQ HL "Y")
         )
         (if (= (type pt1) nil)
            (SETQ HL "N")
         )
         (if (= hl "Y")
            (setq centn (car (entsel)))
            (progn
               (c:dbf)
               (setq centn (entlast))
            )
         )
         (setq blk_set nil)
      )
   )
   (setq xm centn)
   (setq blk_set (ssadd))
   (setq base_handel (cdr (assoc 5 (entget centn))))
   (regapp "LINE_SYMBOL")
   (regapp "CODE")
   (regapp "SYM_CODE")
   (regapp "DESCRIPTION")
   (setq SymFX 0)
   (setq code " ")
   (setq layer (cdr (assoc 8 (entget centn))))
   (setq description " ")
   (setq color (cdr (assoc 62 (entget centn))))
   (setq lst (assoc symcode sym_code))
   (if (/= lst nil)
      (progn
         (setq description (nth 0 (cdr lst)))
         (setq layer (nth 1 (cdr lst)))
         (setq code (nth 2 (cdr lst)))
         (setq color (nth 3 (cdr lst)))
      )
   )
   (if (or (= color nil)(= color 0)(= color "0"))(setq color "bylayer"))
   (setq cclayer (getvar "clayer"))
   (command "-layer" "m" layer "")
   (command "-layer" "s" cclayer "")
   (command "change" centn "" "p" "la" layer "c" color "")
   (setq entdata (entget centn))
   (setq exdata (list (list -3 (list "CODE" (CONS 1000 code))(list "SYM_CODE" (CONS 1000 symcode))(list "DESCRIPTION" (CONS 1000 description)))))
   (setq newent (append entdata exdata))
   (entmod newent)
   (setq tab (assoc symcode Lsym_Exchg_Tab))
   (if tab
      (progn
         (setq ltype (nth 1 tab))
         (if (/= ltype "0" )
            (progn
               (if (not (tblsearch "LType" ltype))
                  (command "-linetype" "l" ltype "acad.lin" "")
               )
               (if (tblsearch "LType" ltype)
                  (progn
                     (command "change" centn "" "p" "lt" ltype "")
                     (setq centn nil)
                  )
               )
            )
         )
      )
   )
   centn
)
(defun creat_blk(blk_set centn blk_name1 / mapname mappath len1 len2 inspt
                  i bl sent xd_data code symcode description layer color)
   (setq Layer (cdr (assoc 8 (entget centn))))
   (setq color (assoc 62 (entget centn)))
   (if (= color nil)
      (setq color "bylayer")
      (setq color (cdr color))
   )
   (if (or (= color 0)(= color "0"))(setq color "bylayer"))
   (command "change" blk_set "" "p" "la" layer "c" color "")
   (setq symfx (fix symfx))
   (if (and (/= blk_set nil) (= lsymblock 1))
      (progn
         (setq elist (entget centn '("*")))
         (zaobiao centn cnn)
         (setq inspt (car cbiao))
         (command "block" blk_name1 inspt blk_set "")
         (command "insert" blk_name1 inspt "" "" "")
         (command "change" (entlast) "" "p" "la" layer "c" color "")
         (setq code (GetFieldVAl centn "code"))
         (setq symcode (GetFieldVAl centn "sym_code"))
         (setq description (GetFieldVAl centn "description"))
         (IF (= CODE NIL)(setq code " "))
         (IF (= symCODE NIL)(setq symcode " "))
         (IF (= description NIL)(setq description " "))
         (setq entdata (entget (entlast)))
         (setq exdata
            (list (list -3 (list "LINE_SYMBOL" (cons 1000 blk_name1) (cons 1000 "ADD") (cons 1070 SymFX)) (list "CODE" (cons 1000 code)) (list "SYM_CODE" (cons 1000 symcode)) (list "DESCRIPTION" (CONS 1000 DESCRIPTION))))
         )
         (setq newent (append entdata exdata))
         (entmod newent)
      )
   )
)
(defun chglayer(ent / entdata fhname elist xd_data att_data app_list)
   (regapp "LINE_SYMBOL")
   (regapp "CODE")
   (setq lname (cdr (assoc 8 (entget ent))))
(if lname
(progn
   (if (= (substr baklayer 1 1) "+")
      (setq lname (strcat lname (substr baklayer 2 (- (strlen baklayer) 1))))
   )
   (if (= (substr baklayer (strlen baklayer) 1) "+")
      (setq lname (strcat (substr baklayer 1 (- (strlen baklayer) 1)) lname))
   )
   (if (and (/= (substr baklayer (strlen baklayer) 1) "+")(/= (substr baklayer 1 1) "+"))
      (setq lname baklayer)
   )
   (setq cclayer (getvar "clayer"))
   (command "-layer" "m" lname "")
   (command "-layer" "s" cclayer "")
   (if (/= bakcolor "0")
      (command "change" ent "" "p" "la" lname "c" bakcolor "")
      (command "change" ent "" "p" "la" lname "")
   )
   (command "layer" "off" lname "")
   (setq entdata (entget ent))
   (setq symfx (fix symfx))
   (setq exdata (list (list -3 (list "LINE_SYMBOL" (CONS 1000 blk_name1) (cons 1000 "BAK")(cons 1070 SymFX)))))
   (setq newent (append entdata exdata))
   (entmod newent)
   (princ)
)
)
)
   (DEFUN get_pt_tbl(ENTNAME / BIA SF Pn tmpbia)
      (setq pt_tbl '() tmpbia '())
      (setq bia (entget entname))
      (setq lorpl (cdr (assoc 0 bia)))
      (setq enttype lorpl)
      (IF (= LORPL "POLYLINE")
         (PROGN
            (SETQ BIA (ENTGET ENTNAME))
            (SETQ SF (CDR (ASSOC 70 BIA)))
            (WHILE (/= LORPL "SEQEND")
               (SETQ ENTNAME (ENTNEXT ENTNAME))
               (SETQ BIA (ENTGET ENTNAME))
               (SETQ LORPL (CDR (ASSOC 0  BIA)))
               (IF (/= LORPL "SEQEND")
                  (SETQ pt_tbl (CONS (CDR (ASSOC 10 BIA)) pt_tbl))
                  (IF (AND (/= LORPL "SEQEND") (/= (LOGAND SF 4) 0) (= (CDR (ASSOC 70  BIA)) 8))
                     (SETQ pt_tbl (CONS (CDR (ASSOC 10 BIA)) pt_tbl))
                     (IF (AND (/= LORPL "SEQEND") (= SF 0))
                        (SETQ pt_tbl (CONS (CDR (ASSOC 10 BIA)) pt_tbl))
                     );if end
                  );if end
               );if end
            );while end
            (IF (/= (LOGAND SF 1) 0)
               (SETQ pt_tbl (CONS (LAST pt_tbl) pt_tbl))
            );if end
         );progn end
      )   
      (IF (= LORPL "LWPOLYLINE")
         (PROGN
            (SETQ BIA (ENTGET ENTNAME))
            (SETQ SF (CDR (ASSOC 70 BIA)))
            (setq pn (cdr (assoc 90 bia)))
            (repeat pn
               (setq tmpbia (assoc 10 bia))
               (setq pt_tbl (cons (cdr tmpbia) pt_tbl))
               (setq bia (cdr (member tmpbia bia)))
            )
            (IF (= SF 1)
               (SETQ pt_tbl (CONS (LAST pt_tbl) pt_tbl))
             );if end

         )
      )
      (IF (= LORPL "LINE")
         (PROGN
            (SETQ BIA (ENTGET ENTNAME))
            (SETQ pt_tbl (CONS (CDR (ASSOC 10 BIA)) pt_tbl))
            (SETQ pt_tbl (CONS (CDR (ASSOC 11 BIA)) pt_tbl))
         );progn end
      );if end
      (IF (OR (= LORPL "TEXT") (= LORPL "INSERT") (= lorpl "POINT"))   
         (PROGN
            (SETQ BIA (ENTGET ENTNAME))
            (SETQ pt_tbl (CONS (CDR (ASSOC 10 BIA)) pt_tbl))
         );progn end
      );if end
      (SETQ pt_tbl (REVERSE pt_tbl))
         pt_tbl
   );defun end
   
(DEFUN IIPP(P1 P2 S / SS)
(SETQ X1 (NTH 0 P1))
(SETQ Y1 (NTH 1 P1))
(SETQ X2 (NTH 0 P2))
(SETQ Y2 (NTH 1 P2))
(SETQ SS (DISTANCE P1 P2))
(IF (/= SS 0.0)
   (SETQ CP (LIST (+ X1 (* (- X2 X1) (/ S SS))) (+ Y1 (* (- Y2 Y1) (/ S SS)))))
   (SETQ CP P1)
)
)
(defun addexdata()
         (regapp "LINE_SYMBOL")
         (setq entdata (entget (entlast)))
         (setq exdata
            (list (list -3 (list "LINE_SYMBOL" (cons 1000 blk_name1)(cons 1000 "ADD") (cons 1070 SymFX))))
         )
         (setq newent (append entdata exdata))
         (entmod newent)

)
(DEFUN ZAOBIAO(ENTNAME LORPL / BIA SF Pn tmpbia)
(setq cbiao '() tmpbia '())
(setq bia (entget entname))
(setq lorpl (cdr (assoc 0 bia)))
(setq enttype lorpl)
(IF (= LORPL "POLYLINE")
    (PROGN
        (SETQ BIA (ENTGET ENTNAME))
        (SETQ SF (CDR (ASSOC 70 BIA)))
        (WHILE (/= LORPL "SEQEND")
         (SETQ ENTNAME (ENTNEXT ENTNAME))
         (SETQ BIA (ENTGET ENTNAME))
         (SETQ LORPL (CDR (ASSOC 0  BIA)))
         (IF (/= LORPL "SEQEND")
          (SETQ CBIAO (CONS (CDR (ASSOC 10 BIA)) CBIAO))
      (IF (AND (/= LORPL "SEQEND") (/= (LOGAND SF 4) 0) (= (CDR (ASSOC 70  BIA)) 8))
        (SETQ CBIAO (CONS (CDR (ASSOC 10 BIA)) CBIAO))
        (IF (AND (/= LORPL "SEQEND") (= SF 0))
           (SETQ CBIAO (CONS (CDR (ASSOC 10 BIA)) CBIAO))
        );if end
     );if end
         );if end
        );while end
   (IF (/= (LOGAND SF 1) 0)
      (SETQ CBIAO (CONS (LAST CBIAO) CBIAO))
   );if end
  );progn end
)   
   (IF (= LORPL "LWPOLYLINE")
      (PROGN
         (SETQ BIA (ENTGET ENTNAME))
         (setq pn (cdr (assoc 90 bia)))
         (repeat pn
            (setq tmpbia (assoc 10 bia))
            (setq cbiao (cons (cdr tmpbia) cbiao))
            (setq bia (cdr (member tmpbia bia)))
         )
      )
   )

(IF (= LORPL "LINE")

  (PROGN
        (SETQ BIA (ENTGET ENTNAME))
        (SETQ CBIAO (CONS (CDR (ASSOC 10 BIA)) CBIAO))
        (SETQ CBIAO (CONS (CDR (ASSOC 11 BIA)) CBIAO))
  );progn end
);if end

(IF (OR (= LORPL "TEXT") (= LORPL "INSERT") (= lorpl "POINT"))   
  (PROGN
        (SETQ BIA (ENTGET ENTNAME))
        (SETQ CBIAO (CONS (CDR (ASSOC 10 BIA)) CBIAO))
  );progn end
);if end


(SETQ CBIAO (REVERSE CBIAO))
)
(defun dtr(b)
                 (setq b (* pi (/ b 180.0)))
)