[编程申请]：求实线虚线互相变换程序

ld80721

本人希望高手编个能在cad中应用的实线虚线互相变换程序,非常感谢,在线期盼您的好消息!

这是天正中的虚实变换lisp文件;
(defun chinslt (bn1 bn2 lt2 / e lt1 ll)
  (setq        lt2 (cons 6 lt2)
        ll  (tblsearch "block" bn1)
        e   (cdr (assoc -2 ll))
        ll  (subst (cons 2 bn2) (cons 2 bn1) ll)
  )
  (entmake ll)
  (while e
    (setq ll  (cdr (entget e))
          e   (entnext e)
          lt1 (assoc 6 ll)
          ll  (if lt1
                (subst lt2 lt1 ll)
                (append ll (list lt2))
              )
    )
    (entmake ll)
  )
  (entmake lbe)
)
(defun c:chdash        (/ lbe ss ssl e bn1 bn2 ll lbn tfbd tfbd1)
  (princ "\n请选取要变换线型的图元 <退出>: ")
  (if (setq ss (ssget))
    (progn
      (command ".undo" "a" "off" ".undo" "g")
      (setq lbe        '((0 . "ENDBLK"))
            ssl        (ssadd)
      )
      (getss ss 0)
      (setq e         (namess 0)
            bn2         (if (= "INSERT" (socas 0))
                   (car (xdout e "LT_MARK"))
                   (socas 6)
                 )
            tfbd (and bn2 (wcmatch bn2 "DASH*"))
      )
      (while e
        (if (= "INSERT" (socas 0))
          (progn
            (setq bn1        (socas 2)
                  ll        (xdout e "LT_MARK")
                  tfbd1        (and ll (wcmatch (car ll) "DASH*"))
            )
            (if        (equal tfbd tfbd1)
              (progn
                (if ll
                  (progn
                    (setq bn2 (cadr ll))
                    (if        (or (not (tblsearch "block" bn2)) (= bn1 bn2))
                      (chinslt bn1 bn2 "BYLAYER")
                    )
                    (xdin e "LT_MARK")
                  )
                  (progn (if (setq ll (assoc bn1 lbn))
                           (setq bn2 (cdr ll))
                           (progn (setq        bn2 (rndname)
                                        lbn (cons (cons bn1 bn2) lbn)
                                  )
                                  (chinslt bn1 bn2 "DASH")
                           )
                         )
                         (xdin e "LT_MARK" "DASH" bn1)
                  )
                )
                (modent 2 bn2)
              )
            )
          )
          (ssadd e ssl)
        )
        (setq e (namess 0))
      )
      (if (> (sslength ssl) 0)
        (command ".chprop"
                 ssl
                 ""
                 "lt"
                 (if tfbd
                   "bylayer"
                   "dash"
                 )
                 ""
        )
      )
      ;(setvar "ltscale" (* 1000 (schdim "normal")))
      (command ".undo" "e" ".undo" "a" "on")
    )
  )
  (princ)
)
(defun c:chltyp        (/     lbe   ss           ss1         e     bl    blc   na0         na1
                 n     d     str   fna         llt   llna  chna  getlt tfins
                )
  (defun chna ()
    (getss ss 0)
    (while (and (setq e (namess 0)) (not (setq na0 (getlt)))))
    (if        na0
      (progn (setq n (strlen na0))
             (while (= 'INT (type (read (substr na0 n))))
               (setq n (1- n))
             )
             (if (= "_" (substr na0 n 1))
               (setq blc (/ (atof (substr na0 (1+ n))) 100)
                     na0 (substr na0 1 (1- n))
               )
               (setq blc 1.)
             )
      )
    )
  )
  (defun getlt (/ lay ltn)
    (if        (and (setq tfins (= "INSERT" (socas 0)))
             (setq ltn (xdout e "LT_MARK"))
        )
      (car ltn)
      (if (and (not tfins) (setq ltn (socas 6)))
        (if (/= "CONTINUOUS" ltn)
          ltn
        )
        (progn (setq lay (socas 8))
               (if (setq ltn (assoc lay llna))
                 (setq ltn (cdr ltn))
                 (setq ltn  (cdr (assoc 6 (tblsearch "layer" lay)))
                       ltn  (if        (/= "CONTINUOUS" ltn)
                              ltn
                            )
                       llna (cons (cons lay ltn) llna)
                 )
               )
               ltn
        )
      )
    )
  )
  (princ "\n请选取要改变线型比例的图元 <退出>: ")
  (if (and (setq ss (ssget)) (chna))
    (progn
      (initget 6)
      (setq lbe        '((0 . "ENDBLK"))
            bl        (getreal
                  (strcat "\n要改变线型的放大系数 <" (rtos blc 2 2) ">: ")
                )
            bl        (if bl
                  bl
                  blc
                )
            blc        (rtos (* 100 bl) 2 0)
            fna        (strcat (getcd) "oo_o.lin")
      )
      (command ".undo" "a" "off" ".undo" "g")
      (getss ss 0)
      (while (setq e (namess 0))
        (if (setq na0 (getlt))
          (progn
            (setq n (strlen na0))
            (while (= 'INT (type (read (substr na0 n))))
              (setq n (1- n))
            )
            (if        (= "_" (substr na0 n 1))
              (setq na0 (substr na0 1 (1- n)))
            )
            (setq na1 (if (= 1 bl)
                        na0
                        (strcat na0 "_" blc)
                      )
                  llt (tblsearch "LTYPE" na1)
            )
            (if        (not llt)
              (progn
                (setq llt (tblsearch "LTYPE" na0)
                      n          (1- (cdr (assoc 73 llt)))
                      llt (member (assoc 49 llt) llt)
                      d          (* bl (cdar llt))
                      str (rtos d 2 4)
                )
                (repeat        n
                  (setq        llt (cdr llt)
                        d   (* bl (cdar llt))
                        str (strcat str "," (rtos d 2 4))
                  )
                )
                (setvar "expert" 3)
                (command ".linetype" "c" na1 fna "" str "l" na1 fna "")
                (setvar "expert" 0)
                (fdel fna)
              )
            )
            (if        tfins
              (progn
                (setq na0 (socas 2))
                (chinslt na0 na0 na1)
                (setq
                  ss1 (ssget "X" (list '(0 . "INSERT") (cons 2 na0)))
                )
                (getss ss1 1)
                (while (setq e (namess 1)) (xdin e "LT_MARK" na1 na0))
              )
              (modent 6 na1)
            )
          )
        )
      )
      (command ".undo" "e" ".undo" "a" "on")
    )
  )
  (princ)
)

hao3ren

我也很想知道，画水面线的时候应改很有用啊

ld80721

帮帮忙哦,老师们!