[求助]：如何实现线型的虚实变换？（LISP 程序）

52DWG

看到天正建筑中有一个虚实变换的命令，可以很方便的改变实体的线型，使用该命令可以将选择的实线转换为虚线（DASH），将虚线转换为实线。
不知晓东的高手们能不能帮忙写一个这样的LISP程序？先谢过了！！！

haibinpro

程序中，先加载，然后命令linestyle中给出线型就可以了。

52DWG

从装有天正的机器上拷出来的线型虚实变换的程序，但在没有装天正的机器上无法运行，郁闷！
[PHP]
(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)
)
[/PHP]

zhynt

研究了一下，除了块实体还没有弄好外，其他的已经可用了。
就是：XDOUT、XDIN、MODENT这三个函数还没搞懂。
[php]
;;;生成一个随机数（用来随机产生块名）代替原程序中的rndname函数，no2为随机字串长度
(defun rndname1 (no2 / l)
  (setq l (strlen (rtos (getvar "cputicks") 2 0)))
  (setq nb (rtos (getvar "cputicks") 2 0)
        l (strlen nb)
        nb (substr nb (- l (- no2 1)))
  )
  nb
)

(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)
      )
      (setq n 0)
      (setq e (ssname ss n)
            bn2 (if (= "INSERT" (cdr (assoc 0 (entget e))))
                  (car (xdout e "LT_MARK"))
                  (cdr (assoc 6 (entget e)))
                )
            tfbd (and
                   bn2
                   (wcmatch bn2 "DASHED*")
                 )
      )
      (while e
        (if (= "INSERT" (cdr (assoc 0 (entget e))))
          (progn
            (setq bn1 (cdr (assoc 2 (entget e)))
                  ll (xdout e "LT_MARK")
                  tfbd1 (and
                          ll
                          (wcmatch (car ll) "DASHED*")
                        )
            )
            (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 (rndname1 12)
                              lbn (cons (cons bn1 bn2) lbn)
                        )
                        (chinslt bn1 bn2 "DASHED")
                      )
                    )
                    (xdin e "LT_MARK" "DASHED" bn1)
                  )
                )
                (modent 2 bn2)
              )
            )
          )
          (ssadd e ssl)
        )
        (setq n (1+ n))
        (setq e (ssname ss n))
      )
      (if (> (sslength ssl) 0)
        (command ".chprop" ssl "" "lt" (if tfbd
                                         "bylayer"
                                         "dashed"
                                       ) ""
        )
      )
      (command ".undo" "e" ".undo" "a" "on")
    )
  )
  (princ)
)
[/php]

52DWG

最初由 zhynt 发布
[B]研究了一下，除了块实体还没有弄好外，其他的已经可用了。
[/B]

感谢 zhynt  ！程序很好用，要是可以支持块实体就完美了。
晓东真是一个卧虎藏龙，高手辈出的地方！！！

zhynt

图块的虚实变换已经可以用了。
[php]
(vl-load-com)
(defun xdout1 (se dict)
  (setq        bname (cdr (assoc 2 (entget se)))
        bh    (cdr (assoc 5 (entget se)))
        bhl   (list bh bname)
  )
  (if (setq bhlg (vlax-ldata-get "Userdict" dict))
    (if        (not (member bhl bhlg))
      (progn
        (setq n        (length bhlg)
              m        0
        )
        (while (< m n)
          (setq bbn (nth m bhlg))
          (if (/= bh (car bbn))
            (setq xy 1)
            (setq xy 2
                  m  n
            )
          )
          (setq m (1+ m))
        )
      )
      (setq xy 3)
    )
    (setq xy 4)
  )
  (cond
    ((= xy 1)
     (vlax-ldata-put "Userdict" dict (cons bhl bhlg))
     nil
    )
    ((= xy 2)
     (list "DASHED" (cadr bbn))
    )
    ((= xy 3)
     nil
    )
    ((= xy 4)
     (vlax-ldata-put "Userdict" dict (list bhl))
     nil
    )
  )
)



(defun rndname1        (no2 / l)
  (setq l (strlen (rtos (getvar "cputicks") 2 0)))
  (setq        nb (rtos (getvar "cputicks") 2 0)
        l  (strlen nb)
        nb (substr nb (- l (- no2 1)))
  )
  nb
)

(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:chdash1 (/ lbe ss ssl e bn1 bn2 ll lbn tfbd tfbd1)
  (if (not (tblsearch "LTYPE" "DASHED"))
    (command "linetype" "l" "DASHED" "" "")
    )
  (princ "\n请选取要变换线型的图元 <退出>: ")
  (if (setq ss (ssget))
    (progn
      (command ".undo" "a" "off" ".undo" "g")
      (setq lbe        '((0 . "ENDBLK"))
            ssl        (ssadd)
      )
      (setq n 0)
      (setq e          (ssname ss n)
            e_ent (entget e)
            bn2          (if (= "INSERT" (cdr (assoc 0 e_ent)))
                    (car (xdout1 e "LT_MARK"))
                    (cdr (assoc 6 e_ent))
                  )
            tfbd  (and
                    bn2
                    (wcmatch bn2 "DASHED*")
                  )
      )
      (while e
        (if (= "INSERT" (cdr (assoc 0 e_ent)))
          (progn
            (setq bn1        (cdr (assoc 2 e_ent))
                  ll        (xdout1 e "LT_MARK")
                  tfbd1        (and
                          ll
                          (wcmatch (car ll) "DASHED*")
                        )
            )
            (if        (equal tfbd tfbd1)
              (progn
                (if ll
                  (progn
                    (setq bn2 (cadr ll))
                    (if        (or
                          (not (tblsearch "block" bn2))
                          (= bn1 bn2)
                        )
                      (chinslt bn1 bn2 "BYLAYER")
                    )
                  )
                  (progn
                    (if        (setq ll (assoc bn1 lbn))
                      (setq bn2 (cdr ll))
                      (progn
                        (setq bn2 (rndname1 12)
                              lbn (cons (cons bn1 bn2) lbn)
                        )
                        (chinslt bn1 bn2 "DASHED")
                      )
                    )
                  )
                )
                (entmod (subst (cons 2 bn2) (assoc 2 e_ent) e_ent))
              )
            )
          )
          (ssadd e ssl)
        )
        (setq n (1+ n))
        (setq e (ssname ss n))
      )
      (if (> (sslength ssl) 0)
        (command ".chprop"
                 ssl
                 ""
                 "lt"
                 (if tfbd
                   "bylayer"
                   "dashed"
                 )
                 ""
        )
      )
      (command ".undo" "e" ".undo" "a" "on")
    )
  )
  (princ)
)
[/php]

userzhluserzhl

如果要变成灰虚线呢?

wang9411

请教下版主，上面那个图块虚实变换这个lsp，使用感觉图块得线型比例太小，希望改大，应该怎么改？
我对编写lsp一窍不通，只会简单使用

znchssy

挺好用的

userzhluserzhl

如何修改块内线的比例?

goodday01

学习中