Jump to content
InfoFile
Tác giả: phamthanhbinh
Bài viết gốc: 405454
Tên lệnh: upat
Lisp Thay Đổi Giá Trị Att Theo Điều Kiện

Cảm ơn bác rất nhiều.bác có thể ghi chú từng dòng trong lisp giúp e xem nó có ý nghĩa ntn đc ko?e đang mày mò về lisp,nên muốn hiểu mấy cái thực tế như thế này.hì

Hề hề hề,

Bạn có thể tham khảo cái này chăng;

 

Cảm ơn bác rất nhiều.bác có thể ghi chú từng dòng trong lisp giúp e xem nó có ý nghĩa ntn đc ko?e đang mày mò về lisp,nên muốn hiểu mấy cái thực tế như thế này.hì

Hề hề hề,

Bạn có thể tham khảo cái này chăng;

 

http://www.cadviet.com/upfiles/6/5194_updateattribute.lsp

(defun c:upat (/ elst e a als) 
(setq elst (acet-ss-to-list (ssget (list (cons 0 "insert") (cons 2 "haba"))))) ;;;; Lấy danh sách tên các block có tên HABA
(foreach e elst                                                                                          ;;;; Duyệt qua danh sách này
    (setq a (entnext e) als (entget a))                                                        ;;;;; Lấy các đối tượng thuộc block
    (while (and a (/= (cdr (assoc 0 als)) "SEQEND"))
            (if (and (= (cdr (assoc 2 als)) "E") (/= (substr (cdr(assoc 1 als)) 1 1) "F") ) ;;;;; Chon thuộc tính cần xủ lý
                (progn
                    (setq a nil)
                    ( cond 
                          ((< (atof (cdr (assoc 1 als))) 40) (setq als (subst (cons 1 "F07") (assoc 1 als) als)))
                          (( and (>= (atof (cdr (assoc 1 als))) 40) (< (atof (cdr (assoc 1 als))) 95)  ) (setq als (subst (cons 1 "F12") (assoc 1 als) als)))
                          (( and (>= (atof (cdr (assoc 1 als))) 95) (< (atof (cdr (assoc 1 als))) 150) ) (setq als (subst (cons 1 "F18") (assoc 1 als) als)))
                          (( and (>= (atof (cdr (assoc 1 als))) 150) (< (atof (cdr (assoc 1 als))) 200) ) (setq als (subst (cons 1 "F23") (assoc 1 als) als)))
                          (T nil)
                    )
                 )
                 (progn 
                     (setq a (entnext a) )
                     (setq als (entget a))
                 )
             )
       )
       (entmod als) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Cập nhật thuộc tính đã xử lý
       (entupd e)    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Cập nhật block
)
)

<<

Filename: 405454_upat.lsp
Tác giả: gia_bach
Bài viết gốc: 184337
Tên lệnh: sstest
Các lỗi thường gặp trong lập trình Lisp

Bác thử đoạn Lisp này xem sao :

(defun c:sstest(/ ss ss1)
(setq ss (ssadd) ss1 (ssadd))
(while (setq e (car (entsel "\nChon doi tuong :")))
(setq ss (ssadd e ss))
(princ (strcat "\nSo luong ss = " (itoa(sslength ss))))
(ssadd e ss1)
(princ (strcat "\nSo luong ss1 = " (itoa(sslength ss1))))
)
(princ) )

Filename: 184337_sstest.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 405712
Tên lệnh: ha
Nhờ Các Cao Thủ Giúp Mình Thêm Point Vào Giao Điểm Các Pline

Này bạn!

(defun C:HA(/ ss ln lst)
 (defun #Inter:1SS(ss / a b i j l)
  (repeat (setq i (sslength ss))
   (setq a (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
   (repeat (setq j i)
    (setq b (vlax-ename->vla-object (ssname ss (setq j (1- j)))) l (cons (#Inter:2Obj a b acExtendNone) l))))
  (apply 'append (reverse l)))
 (defun #Inter:2Obj(obj1 obj2 flag / l r)
  (setq l...
>>

Này bạn!

(defun C:HA(/ ss ln lst)
 (defun #Inter:1SS(ss / a b i j l)
  (repeat (setq i (sslength ss))
   (setq a (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
   (repeat (setq j i)
    (setq b (vlax-ename->vla-object (ssname ss (setq j (1- j)))) l (cons (#Inter:2Obj a b acExtendNone) l))))
  (apply 'append (reverse l)))
 (defun #Inter:2Obj(obj1 obj2 flag / l r)
  (setq l (vlax-invoke obj1 'intersectwith obj2 flag))
  (repeat (/ (length l) 3)
   (setq r (cons (list (car l) (cadr l) (caddr l)) r) l (cdddr l)))
  (reverse r))
 (defun MPoint (pt) (entmake (list (cons 0 "POINT") (cons 10 pt))))
 (princ "\nChon cac Pline...")
 (if
  (and
   (setq ss (ssget '((0 . "*line"))))
   (setq ln (car (entsel "\nChon Line de chieu hoac move: "))))
  (progn 
   (initget "C M")
   (setq wd (getkword "\nChon hinh thuc [Chieu/Move] <M>: "))
   (setq lst (#Inter:1SS ss))
   (cond
    ((or (= wd "M") (not wd)) (mapcar '(lambda(pt) (Mpoint (vlax-curve-getClosestPointTo ln pt))) lst))
    ((= wd "C") (mapcar '(lambda(pt) (Mpoint pt) (Mpoint (vlax-curve-getClosestPointTo ln pt))) lst)))))
 (princ))

<<

Filename: 405712_ha.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 405787
Tên lệnh: tt
Lisp Hỗ Trợ Tính Toán Khối Lượng Trên Bản Vẽ
Lsp ở đây:
(defun c:tt (/ Text mid_point FixTextAngle ||| ang dis hei mid poi pt ptt sty tal)
(defun Text (pt hgt str ang sty)
(entmakex (mapcar '(lambda (x y) (cons x y))
'(0 7 10 40 50 1 72 11 73)
(list "TEXT" sty pt hgt ang str 1 pt 2))))
(defun mid_point (p1 p2) (mapcar '(lambda (x y) (* (+ x y) 0.5)) p1 p2))
(defun FixTextAngle (ang)
(if (and (> ang (* 0.5 pi)) (<= ang (* 1.5 pi)))
(+ ang pi)
ang))
(setq hei 250 ;Thay doi chieu cao chu o...
>>
Lsp ở đây:
(defun c:tt (/ Text mid_point FixTextAngle ||| ang dis hei mid poi pt ptt sty tal)
(defun Text (pt hgt str ang sty)
(entmakex (mapcar '(lambda (x y) (cons x y))
'(0 7 10 40 50 1 72 11 73)
(list "TEXT" sty pt hgt ang str 1 pt 2))))
(defun mid_point (p1 p2) (mapcar '(lambda (x y) (* (+ x y) 0.5)) p1 p2))
(defun FixTextAngle (ang)
(if (and (> ang (* 0.5 pi)) (<= ang (* 1.5 pi)))
(+ ang pi)
ang))
(setq hei 250 ;Thay doi chieu cao chu o day
tal 0
sty (getvar 'TEXTSTYLE))
(if (setq poi (getpoint "\nChon diem: "))
(progn (while (setq ptt (getpoint "\nChon diem tiep theo: " poi))
(setq dis (distance poi ptt)
ang (FixTextAngle (angle poi ptt))
mid (mid_point poi ptt))
(Text (polar mid (+ ang (* 0.5 pi)) hei) hei (rtos dis 2 0) ang sty); 0 -> so chu so thap phan
(setq tal (+ tal dis))
(setq poi ptt))
(and (> tal 0)
(setq pt (getpoint "\nChon diem chen text: "))
(Text pt hei (rtos tal 2 0) 0 sty))));(rtos tal 2 0) 0-> so chu so thap phan
(princ))
<<

Filename: 405787_tt.lsp
Tác giả: hellocadviet
Bài viết gốc: 23866
Tên lệnh: nn
Viết Lisp theo yêu cầu
Tình hình là mình hay phải tính cao độ và khoảng cách của các điểm trong mặt cắt ngang. Mình đã tìm được lisp tính cao độ tự động khi tích vào các điểm và đã thêm vào một số lệnh để nó có thể dóng đường thẳng xuống tự động, nhưng mình chưa biết làm sao để tính khoảng cách giữa các điểm đã tích vào. Các bác giúp giùm em nhé. Cảm ơn các bác nhiều.

Filename: 23866_nn.lsp
Tác giả: quanghuy181
Bài viết gốc: 405833
Tên lệnh: toado capnhat
Sửa Lisp Xuất Tọa Độ

Em mới xin được cái Lisp này phục vụ công tác xuất tọa độ và cạnh các thửa đất để in GCN. Nhờ các bác chỉnh sửa lại cho em một xíu:

1. Chiều dài cạnh để đến dm là được:   0.1 không cần đến 2 chữ số như trong lisp đang chạy.

2. Chiều dài các cạnh xuất thành 1 Layer mới.

Em xin cảm ơn nhiều nhiều!

(defun *error* (msg)
  (princ "error:...
>>

Em mới xin được cái Lisp này phục vụ công tác xuất tọa độ và cạnh các thửa đất để in GCN. Nhờ các bác chỉnh sửa lại cho em một xíu:

1. Chiều dài cạnh để đến dm là được:   0.1 không cần đến 2 chữ số như trong lisp đang chạy.

2. Chiều dài các cạnh xuất thành 1 Layer mới.

Em xin cảm ơn nhiều nhiều!

(defun *error* (msg)
  (princ "error: ")
  (princ msg)
  (princ)
)


(defun Wdis (p1 p2 / dis ang point)
  (setq dis (distance p1 p2))
  (setq ang (angle p1 p2))
  (if (and (> ang (/ Pi 2)) (< ang (* Pi 1.5)) )
    (progn
      (setq ang (+ Ang Pi)) 
      (setq Point (polar p2 ang (/ dis 2.0)))
    )
    (setq Point (polar p1 ang (/ dis 2.0)))
  )
  (command "Text" "S" "vaptimn" "c" point (/ TileBdHT 500) (* (/ ang Pi) 180) (rtos dis 2 2) )
)
(defun ssgetLayer( La1 La2 / ss)
  (setq ss (ssget "X" (list
                         (cons -4  "<OR")  
                           (cons -4  "<AND")  
                             (cons 8 La1)  
                             (cons 0  "LWPOLYLINE")
                           (cons -4  "AND>")  
                           (cons -4  "<AND")  
                             (cons 8 La1)  
                             (cons 0  "LINE")
                           (cons -4  "AND>")  
                           (cons -4  "<AND")  
                             (cons 8 La2)  
                             (cons 0  "LWPOLYLINE")
                           (cons -4  "AND>")  
                           (cons -4  "<AND")  
                             (cons 8 La2)  
                             (cons 0  "LINE")
                           (cons -4  "AND>")  
                         (cons -4  "OR>")  
                       )
  ))
  ss
)
(defun pointpl (name tt k / namem i bien t1 p1 diem)
(setq namem name)
(setq i 1)
(while (<= i k)
(progn
(setq bien (assoc tt namem))
(setq t1 (member bien namem))
(setq p1 (car t1))
(setq namem (cdr t1))
(setq diem (cdr p1))
(setq i (+ 1 i))
)
)
diem
)
(defun c:Toado( / i k luuxy st p xoa)
(setvar "cmdecho" 0)
(setq st (ssgetLayer "Rtd" "10") )
(if (/= st  nil)
(progn
(if (null (tblsearch "style" "vaptimn"))
(command "_style" "vaptimn" "vaptimn.ttf" "" "" "" "" ""))
(if (null (tblsearch "style" "vhelveb"))
(command "_style" "vhelveb" "vhelveb.ttf" "" "" "" "" ""))
(if (null (tblsearch "layer" "sohieu_diem"))
(command "_layer" "n" "sohieu_diem" ""))
(command "_layer" "c" "2" "sohieu_diem" "")
(if (null (tblsearch "layer" "bang_toado"))
(command "_layer" "n" "bang_toado" ""))
(command "_layer" "c" "7" "bang_toado" "")
(command "_layer" "c" "5" "10" "")
(command "_layer" "c" "4" "Rtd" "")
(if (null (tblsearch "layer" "Polygon"))
(command "_layer" "n" "Polygon" ""))
(command "_layer" "c" "8" "Polygon" "")
(setq r1 (getvar "USERR1"))
(setq TileBdHT (getreal (strcat "\nMau So Ti Le Cua BDHT" "(" (rtos r1 2 0) "):")))
(if (= TileBdHT nil)
(setq TileBdHT r1))
(setvar "USERR1" TileBdHT)


(setvar "blipmode" 0)
(setq old (getvar "osmode"))
(setvar "osmode" 0)
(setq p (getpoint "\n Pick"))
(command "_layer" "s" "Polygon" "")
(if (/= p nil)
(command "-Boundary" "a" "b" "n" st "" "" p "" )
)
(setq luuxy (entget (entlast)))
(setq p (getpoint "\n Diem dat bang toa do :"))
; (entdel (entlast))
(setq k (cdr (assoc 90 luuxy)))
(if (/= p nil)
(progn
(setq p01 p)
(setq p02 (mapcar '+ p '(10.0  0.0 0.0)))
(setq p03 (mapcar '+ p '(22.5 -2.5 0.0)))
(setq p04 (mapcar '+ p '(35.0  0.0 0.0)))
(setq p05 (mapcar '+ p '(45.0  0.0 0.0)))
(setq p06 (mapcar '+ p '(0.0 -5.0 0.0)))
(setq p07 (mapcar '+ p '(10.0 -2.5 0.0)))
(setq p08 (mapcar '+ p '(35.0 -2.5 0.0)))
(setq p09 (mapcar '+ p '(45.0 -5.0 0.0)))
(if (<= k 10) 
(progn
(setq p10 (mapcar '+ p '(0.0 -40.0 0.0)))
(setq p11 (mapcar '+ p '(10.0 -40.0 0.0)))
(setq p12 (mapcar '+ p '(22.5 -40.0 0.0)))
(setq p13 (mapcar '+ p '(35.0 -40.0 0.0)))
(setq p14 (mapcar '+ p '(45.0 -40.0 0.0)))
)
(progn
(setq ty (* -1 (+ 10.0 (* k 3))))
(setq t0 (list 0.0 ty 0.0))
(setq t1 (list 10.0 ty 0.0))
(setq t2 (list 22.5 ty 0.0))
(setq t3 (list 35.0 ty 0.0))
(setq t4 (list 45.0 ty 0.0))
(setq p10 (mapcar '+ p t0))
(setq p11 (mapcar '+ p t1))
(setq p12 (mapcar '+ p t2))
(setq p13 (mapcar '+ p t3))
(setq p14 (mapcar '+ p t4))
)
)
(command "layer" "s" "bang_toado" "")
(command "Line" p01 p05 "")
(command "Line" p01 p10 "")
(command "Line" p02 p11 "")
(command "Line" p03 p12 "")
(command "Line" p04 p13 "")
(command "Line" p05 p14 "")
(command "Line" p07 p08 "")
(command "Line" p06 p09 "")
(command "Line" p10 p14 "")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ p '(22.5 2.0 0.0)) 1.25 0 "BAÛNG LIEÄT KEÂ TOÏA ÑOÄ GOÙC RANH")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ p '(5.0 -1.5 0.0)) 1.15 0 "Soá hieäu")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ p '(5.0 -3.5 0.0)) 1.15 0 "ñieåm")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ p '(22.5 -1.25 0.0)) 1.15 0 "Toïa ñoä")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ p '(16.25 -3.75 0.0)) 1.15 0 "X(m)")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ p '(28.75 -3.75 0.0)) 1.25 0 "Y(m)")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ p '(40.0 -2.5 0.0)) 1.25 0 "Caïnh")
)
)
(setq i 1)
(while (<= i k)
(progn
(setq toado (pointpl luuxy 10 i))
(setq x (rtos (car toado) 2 2))
(setq y (rtos (cadr toado) 2 2))
(command "layer" "s" "sohieu_diem" "")
(setq doi (list (* 0.2 (/ TileBdHT 500)) (* 0.2 (/ TileBdHT 500)) 0.0))
(command "Text" "S" "vaptimn" (mapcar '+ toado doi) (/ TileBdHT 500) 0 i)
(command "donut" "0.0" (* 0.25 (/ TileBdHT 500)) toado "") 
(setq tsh (list 5.0 (- (* -3 i) 4.5) 0.0))
(setq txx (list 16.25 (- (* -3 i) 4.5) 0.0))
(setq tyy (list 28.75 (- (* -3 i) 4.5) 0.0))
(setq tgc (list 40.0 (- (* -3 i) 3.0) 0.0))
(setq psh (mapcar '+ p tsh))
(setq pxx (mapcar '+ p txx))
(setq pyy (mapcar '+ p tyy))
(setq pgc (mapcar '+ p tgc))
(if (= i 1)
(progn
(setq toado1 toado)
(setq x1 (rtos (car toado1) 2 2))
(setq y1 (rtos (cadr toado1) 2 2))
)
)
(if (>= i 2)
(progn
(setq canh (distance toado0 toado))
(command "layer" "s" "bang_toado" "")
(command "Text" "S" "vaptimn" "j" "M" pgc 1.2 0 (rtos canh 2 2) )
(command "layer" "s" "sohieu_diem" "")
(wdis toado0 toado)
)
)
(command "layer" "s" "bang_toado" "")
(command "Text" "S" "vaptimn" "j" "M" psh 1.2 0 i)
(command "Text" "S" "vaptimn" "j" "M" pxx 1.2 0 y)
(command "Text" "S" "vaptimn" "j" "M" pyy 1.2 0 x)
(setq toado0 toado)
(setq i (+ i 1))
)
)
(command "layer" "s" "sohieu_diem" "")
(wdis toado toado1)
(setq canh (distance toado toado1))
(setq tsh (list 5.0 (- (* -3 (+ k 1)) 4.5) 0.0))
(setq txx (list 16.25 (- (* -3 (+ k 1)) 4.5) 0.0))
(setq tyy (list 28.75 (- (* -3 (+ k 1)) 4.5) 0.0))
(setq tgc (list 40.0 (- (* -3 (+ k 1)) 3.0) 0.0))
(setq psh (mapcar '+ p tsh))
(setq pxx (mapcar '+ p txx))
(setq pyy (mapcar '+ p tyy))
(setq pgc (mapcar '+ p tgc))
(command "layer" "s" "bang_toado" "")
(command "Text" "S" "vaptimn" "j" "M" pgc 1.2 0 (rtos canh 2 2) )
(command "Text" "S" "vaptimn" "j" "M" psh 1.2 0 "1")
(command "Text" "S" "vaptimn" "j" "M" pxx 1.2 0 y1)
(command "Text" "S" "vaptimn" "j" "M" pyy 1.2 0 x1)
(setvar "osmode" old)
) ;(end progn)
) ;(end if)
(if (= st nil)
(progn
(setvar "cmdecho" 1)
(princ "Khong co layer Ranh_toado")
)
)
(command "_layer" "s" "0" "")


)
(defun c:capnhat()
(setq is (ssgetLayer "Polygon" "Polygon") )
(setq namecn (getfiled "FILE CAP NHAT" "" "DWG" 3))
(command "Wblock" namecn "" '(0 0) is "")
(command "oops")
(command "save")
; (setq namegoc (getfiled "FILE BAN DO GOC" "" "DWG" 3))
(setq TenQuan (strcat " " (getString T "\nTen Quan : ")))
(setq TenPhuong (strcat " " (getString T "\nTen Phuong : ")))
(setq TenTo (strcat " " (getString T "\nTo So : ")))
(setq namegoc (strcat "q" TenQuan "-" TenPhuong "-" TenTo ".dwg"))
(command "open" namegoc)
)

<<

Filename: 405833_toado_capnhat.lsp
Tác giả: hoangkimoanh
Bài viết gốc: 402103
Tên lệnh: qqq
Lisp hatch nhanh.

Nhờ các anh sửa giúp em sau khi thực hiện hatch xong muốn chuyển về Layer: 0 và lineweight : Bylayer mà em không chuyển được với!

(defun c:qqq ()
(command "lweight" 0.09)
(command "-layer" "m" "Hatch" "c" "8" "" "")
(command "-bhatch" "p" "ansi31" "5" "" ) 
(command "-layer" "s" "0"  "")
(princ))

Filename: 402103_qqq.lsp
Tác giả: Tot77
Bài viết gốc: 405913
Tên lệnh: cop
Hoi List Copy Chu Va So Tang Dan

Dùng thử cái này.

Sau khi chon text, nó hỏi:

Chu so can tang giam : 01 (trong M-01)

Tang giam: 1 (nếu giảm thì thêm dấu - , nhưng không giảm dưới 0)

(defun c:cop(/ A B B1 C F CHUMOI D E PT)
(setq a (car (entsel "\nChon text de copy:")) 
b (getstring "\nChu so can tang giam:") 
c (getint "\nTang giam:")
pt (getpoint "\nDiem goc:")
)
(setvar 'cmdecho 0)
(while pt
(command "copy" a "" pt (setq pt (getpoint...
>>

Dùng thử cái này.

Sau khi chon text, nó hỏi:

Chu so can tang giam : 01 (trong M-01)

Tang giam: 1 (nếu giảm thì thêm dấu - , nhưng không giảm dưới 0)

(defun c:cop(/ A B B1 C F CHUMOI D E PT)
(setq a (car (entsel "\nChon text de copy:")) 
b (getstring "\nChu so can tang giam:") 
c (getint "\nTang giam:")
pt (getpoint "\nDiem goc:")
)
(setvar 'cmdecho 0)
(while pt
(command "copy" a "" pt (setq pt (getpoint pt)) )
(if pt
(progn
(setq e (entlast)
d (cdr (assoc 1 (entget e)))
f (+ c (atoi b))
b1 (if (< f 10) (strcat "0" (itoa f)) (itoa f))
chumoi (vl-string-subst b1 b d) 
)
(entmod (subst (cons 1 chumoi) (assoc 1 (entget e)) (entget e)))        
(setq b b1 a e)
)
)
)
(setvar 'cmdecho 1)
(princ)
)

<<

Filename: 405913_cop.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 405972
Tên lệnh: tt
Lisp Cộng Trừ Text
Của bạn đây:
(defun c:tt (/ els ent i new sst str val)
(or #delta# (setq #delta# 0.))
(if (and (princ "\nQuet chon Text...!")
(setq sst (ssget '((0 . "*TEXT"))))
(setq #delta# (cond ((getreal (strcat "\nNhap so gia <" (rtos #delta# 2 2) ">: ")))
(#delta#))))
(repeat (setq i (sslength sst))
(setq ent (ssname sst (setq i (1- i)))
els (entget ent)
str (cdr (assoc 1 els)))
(and (setq val (distof str))
(setq new (+ val #delta#))
(setq els (subst...
>>
Của bạn đây:
(defun c:tt (/ els ent i new sst str val)
(or #delta# (setq #delta# 0.))
(if (and (princ "\nQuet chon Text...!")
(setq sst (ssget '((0 . "*TEXT"))))
(setq #delta# (cond ((getreal (strcat "\nNhap so gia <" (rtos #delta# 2 2) ">: ")))
(#delta#))))
(repeat (setq i (sslength sst))
(setq ent (ssname sst (setq i (1- i)))
els (entget ent)
str (cdr (assoc 1 els)))
(and (setq val (distof str))
(setq new (+ val #delta#))
(setq els (subst (cons 1 (rtos new 2 2)) (assoc 1 els) els))
(entmod els))))
(princ))
<<

Filename: 405972_tt.lsp
Tác giả: jangboko
Bài viết gốc: 406109
Tên lệnh: mul sum
Nhờ Chỉnh Sửa Lisp Cộng Giá Trị Text Của Vật Tư Ngành Nước
 (defun CheckObj(e MyType) (equal (cdr (assoc 0 (entget e))) MyType))
;;;-----------------------------------------
(defun FilObj (ss1 MyType / ss2 i e)
(setq ss2 (ssadd)
i 0
)
(repeat (sslength ss1)
(setq e (ssname ss1 i)
i (1+ i)
)
(if (CheckObj e MyType)
(ssadd e ss2)
)
)
(eval ss2)
)
;;;-----------------------------------------
(defun SelData (/ OK)
(setq OK nil)
(while (not OK)
(prompt "\tChon cac text can tinh:")
(setq ss (FilObj (ssget)...
>>
 (defun CheckObj(e MyType) (equal (cdr (assoc 0 (entget e))) MyType))
;;;-----------------------------------------
(defun FilObj (ss1 MyType / ss2 i e)
(setq ss2 (ssadd)
i 0
)
(repeat (sslength ss1)
(setq e (ssname ss1 i)
i (1+ i)
)
(if (CheckObj e MyType)
(ssadd e ss2)
)
)
(eval ss2)
)
;;;-----------------------------------------
(defun SelData (/ OK)
(setq OK nil)
(while (not OK)
(prompt "\tChon cac text can tinh:")
(setq ss (FilObj (ssget) "TEXT"))
(if (> (sslength ss) 0)
(setq OK T)
(princ "\nDoi tuong chon khong phai text")
)
)
)
;;;-----------------------------------------
(defun WriteRes (kq / OK e data)
(setq OK nil)
(while (not OK)
(setq e (car (entsel "\tChon text ghi ket qua:")))
(if (CheckObj e "TEXT")
(setq OK T)
(princ "\nDoi tuong chon khong phai text")
)
)
(entmod (subst (cons 1 kq) (assoc 1 (setq data (entget e)))  data))
(princ)
)
 
(defun getchar(s)
(vl-list->string (vl-remove-if '(lambda(x) (<= 48 x 57)) (vl-string->list s)))
)
;;;-----------------------------------------
(defun C:MUL (/ i m e ss vt chu dv)
(SelData)
(setq i 0
m 1.0
)
(repeat (sslength ss)
(setq e (ssname ss i)
i (1+ i))
(if (setq vt (vl-string-search "- L" (setq chu (cdr (assoc 1 (entget e))))))
(setq m (* m (atof (substr chu (+ 4 vt)))))
)
(setq dv (getchar (substr chu (+ 4 vt))))
)
(WriteRes (strcat (rtos m) dv))
)
;;;-----------------------------------------
(defun C:SUM (/ i s e ss chu vt dv)
(SelData)
(setq i 0
s 0.0
)
(repeat (sslength ss)
(setq e (ssname ss i)
i (1+ i))
(if (setq vt (vl-string-search "- L" (setq chu (cdr (assoc 1 (entget e))))))
(setq s (+ s (atof (substr chu (+ 4 vt)))))
)
(setq dv (getchar (substr chu (+ 4 vt))))
)
(WriteRes (strcat (rtos s) dv))
)
 

Lisp này có tác dụng cộng các text có dạng D32 PVC - L150m, dùng để thống kê vật tư ngành nước. 

em lấy lisp này  của bác Tot77, trong bài viết: www.cadviet.com/forum/topic/164711-nho-cac-bac-chinh-sua-lai-lisp-cong-tong-text-cho-truong-hop-cua-em/

Em thấy lisp này hoạt động được trên file cad của tác giả, em viết đoạn text có cấu trúc giống tác giả thì lisp lại không hoạt động được, và có báo lỗi 

 
Command: sum
 Chon cac text can tinh:
Select objects: 1 found
 
Select objects: Specify opposite corner: 2 found, 3 total
 
Select objects:  ; error: bad argument type: numberp: nil
 
hề hề, cứ nhờ không các bác thế này cũng ngại, em đã lục tung diễn đàn lên mà không tìm thấy lisp nào tương tự, nên đành mặt dày làm kinh động đến các bác. Mong các bác giúp em.
Em xin cảm ơn các bác, chúc các bác luôn mạnh khỏe.
 
 
 

<<

Filename: 406109_mul_sum.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 405485
Tên lệnh: cla ccl
Nhờ Các Bác Sửa Giúp Cái Lisp Thay Đổi Layer.

Em có sưu tầm được 2 cái lisp thay đổi layer và đổi màu cho đối tượng như thế này. Nhưng nhược điểm là phải chọn hết các đối tượng rồi mới đổi được. Bây giờ em muốn sửa lại theo ý mình là pick đến đâu thay đổi đến đó (giống lệnh MA ý ạ) nhưng chưa biết làm thế nào nên đánh bạo lên...

>>

Em có sưu tầm được 2 cái lisp thay đổi layer và đổi màu cho đối tượng như thế này. Nhưng nhược điểm là phải chọn hết các đối tượng rồi mới đổi được. Bây giờ em muốn sửa lại theo ý mình là pick đến đâu thay đổi đến đó (giống lệnh MA ý ạ) nhưng chưa biết làm thế nào nên đánh bạo lên đây nhờ các bác ạ!

http://www.cadviet.com/upfiles/6/154272_cl_3.lsp

http://www.cadviet.com/upfiles/6/154272_c1_chuyen_mau_doi_tuong_1.lsp

Cám ơn các bác đã bỏ chút thời gian xem bài!

Hề hề hề,

Không biết ý bạn có phải thế này không???

Lưu ý là biến tên màu và tên layer bạn phải nhập cho phù hợp với yêu cầu của bạn.

(defun c:cla ()
(while (setq e (car (entsel)))
       (command "change" e "" "p" "la" ten layer "" )
)
)
(defun c:ccl ()
(while (setq e (car(entsel)))
         (command "change" e "" "p" "c" ten mau "" )
)
)


<<

Filename: 405485_cla_ccl.lsp
Tác giả: Tue_NV
Bài viết gốc: 60673
Tên lệnh: aci
Kéo cung tròn thành đường tròn?

Lisp đây sẽ biến cung arc thành Circle

Filename: 60673_aci.lsp
Tác giả: gia_bach
Bài viết gốc: 60763
Tên lệnh: atc
Kéo cung tròn thành đường tròn?
dùng hàm entmake thay cho hàm Command

Filename: 60763_atc.lsp
Tác giả: Tue_NV
Bài viết gốc: 113350
Tên lệnh: tt
Sửa hộ em code tính tổng lỗi này


Một cách viết ngắn gọn code (tiếp cận hàm acet-xxx):

Filename: 113350_tt.lsp
Tác giả: ketxu
Bài viết gốc: 113343
Tên lệnh: %2A %2B
Sửa hộ em code tính tổng lỗi này
Ở code trên rõ ràng function (tao1) của bạn không có,chắc bạn lấy lisp này từ topic congtrunhanchia :lol:
Bạn có thể dùng code này của các bác trên CV đã viết rồi,áp dụng cho phép cộng (+) và phép nhân (*),tương ứng với lệnh +,* nhé


Filename: 113343_%2A_%2B.lsp
Tác giả: thainguyen_tg
Bài viết gốc: 406237
Tên lệnh: td
Nhờ Sửa Lsp Giúp

Chào các bạn trên diễn đàn cadviet.com!

Mình có sưu tầm được 1 lisp trên diễn đàn (không nhớ rõ tên tác giả) dùng để sửa đối tượng text tăng dần. Tuy nhiên lisp này còn 1 hạn chế là không bắt đầu được số đầu tiên, ví dụ ta có dãy...

>>

Chào các bạn trên diễn đàn cadviet.com!

Mình có sưu tầm được 1 lisp trên diễn đàn (không nhớ rõ tên tác giả) dùng để sửa đối tượng text tăng dần. Tuy nhiên lisp này còn 1 hạn chế là không bắt đầu được số đầu tiên, ví dụ ta có dãy số:

08200, 08200, 08200

Bây giờ ta muốn nó tăng dần thành: ABC00, ABC01, ABC02

Nhưng nó chỉ tăng dần là: ABC01, ABC02, ABC03

è Không bắt đầu được từ 0 hoặc 00

Mình xin cảm ơn các bạn trước!

Mình gởi hình để các bạn tham khảo nha! 



(defun c:td (/ kw ss str n)
(prompt "\nSua tex tang dan(TD)")
  (initget "T D")
  (if (and
	(if (setq kw (getkword "\nTren xuong/Duoi len[T/D]<T>: ")) kw (setq kw "T"))
	(setq ss (ssget '((0 . "*TEXT"))))
      )
    (progn
      (setq str (getstring "\nNhap chuoi: "))
      (setq ss
	     (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))

		      '(lambda (x y)
			 (> (cadr (cdr (assoc 10 (entget x))))
			    (cadr (cdr (assoc 10 (entget y))))
			 )
		       )
	     )
      )
      (if (= kw "D")(setq ss (reverse ss)))
      (setq n 1)
      (foreach e  (mapcar 'vlax-ename->vla-object ss)
	(vla-put-textstring e (strcat (substr str 1 (- (strlen str) 1)) (itoa n)))
	(setq n (1+ n))
	)
    )
  )
  (princ)
  )

 

125368_untitled.jpg


<<

Filename: 406237_td.lsp
Tác giả: duy782006
Bài viết gốc: 406416
Tên lệnh: td
Nhờ Sửa Lsp Giúp

Than tới than lui tốn đất của cadviet quá:

(defun c:td (/ kw ss str n)
(prompt "\nSua tex tang dan(TD)")
  (initget "T D")
  (if (and
	(if (setq kw (getkword "\nTren xuong/Duoi len[T/D]<T>: ")) kw (setq kw "T"))
	(setq ss (ssget '((0 . "*TEXT"))))
      )
    (progn
      (setq str (getstring "\nNhap chuoi co dinh: "))
         (setq ss
	     (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))

		      '(lambda (x y)
			...
>>

Than tới than lui tốn đất của cadviet quá:

(defun c:td (/ kw ss str n)
(prompt "\nSua tex tang dan(TD)")
  (initget "T D")
  (if (and
	(if (setq kw (getkword "\nTren xuong/Duoi len[T/D]<T>: ")) kw (setq kw "T"))
	(setq ss (ssget '((0 . "*TEXT"))))
      )
    (progn
      (setq str (getstring "\nNhap chuoi co dinh: "))
         (setq ss
	     (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))

		      '(lambda (x y)
			 (> (cadr (cdr (assoc 10 (entget x))))
			    (cadr (cdr (assoc 10 (entget y))))
			 )
		       )
	     )
      )
      (if (= kw "D")(setq ss (reverse ss)))
     (setq n (getreal "\nNhap gia tri bat dau : "))
      (foreach e  (mapcar 'vlax-ename->vla-object ss)
	(vla-put-textstring e (strcat str (itoa (fix n))))
	(setq n (+ n 1))
	)
    )
  )
  (princ)
  )

<<

Filename: 406416_td.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 406458
Tên lệnh: tt
Không Thống Kê Được Text Và Mtext Có Font Tiếng Việt
Các bác ngại viết ấy mà, thử viết lại cho chủ top cái, không biết có ổn không đây!???
(defun c:tt (/ make-Text hei lst pt ss str sty)
(defun make-Text (pt hgt str sty)
(entmakex (list (cons 0 "TEXT") (cons 7 sty) (cons 10 pt) (cons 40 hgt) (cons 1 str))))
(and (vl-load-com)
(princ "\nQuet chon Text, Mtext de thong ke...!")
(setq ss (ssget (list (cons 0 "*TEXT"))))
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(setq str (cdr...
>>
Các bác ngại viết ấy mà, thử viết lại cho chủ top cái, không biết có ổn không đây!???
(defun c:tt (/ make-Text hei lst pt ss str sty)
(defun make-Text (pt hgt str sty)
(entmakex (list (cons 0 "TEXT") (cons 7 sty) (cons 10 pt) (cons 40 hgt) (cons 1 str))))
(and (vl-load-com)
(princ "\nQuet chon Text, Mtext de thong ke...!")
(setq ss (ssget (list (cons 0 "*TEXT"))))
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(setq str (cdr (assoc 1 (entget e)))
hei (cdr (assoc 40 (entget e))))
(if (not (assoc str lst))
(setq lst (cons (cons str (list (cons 1 e))) lst))
(setq lst (subst (cons str (list (cons (1+ (caadr (assoc str lst))) e))) (assoc str lst) lst))))
(setq hei (cond ((getreal (strcat "\nChieu cao Text trong bang thong ke <" (rtos hei 2 2) ">: ")))
(hei)))
(setq pt (getpoint "\nDiem dat Bang: "))
(foreach e (vl-sort lst '(lambda (x y) (< (caadr x) (caadr y))))
(make-Text pt hei (itoa (caadr e)) (setq sty (cdr (assoc 7 (entget (cdadr e))))))
(make-Text (polar pt 0 (* 5 hei)) hei (car e) sty)
(setq pt (polar pt (* pi 1.5) (* 1.75 hei)))))
(princ))
<<

Filename: 406458_tt.lsp
Tác giả: duy782006
Bài viết gốc: 406450
Tên lệnh: td
Nhờ Sửa Lsp Giúp

Lần này nửa thôi đấy!

 (defun c:td (/ kw ss str n)
(prompt "\nSua tex tang dan(TD)")
  (initget "T D")
  (if (and
	(if (setq kw (getkword "\nTren xuong/Duoi len[T/D]<T>: ")) kw (setq kw "T"))
	(setq ss (ssget '((0 . "*TEXT"))))
      )
    (progn
      (setq str (getstring "\nNhap chuoi co dinh: "))
         (setq ss
	     (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))

		      '(lambda (x y)
			 (> (cadr (cdr...
>>

Lần này nửa thôi đấy!

 (defun c:td (/ kw ss str n)
(prompt "\nSua tex tang dan(TD)")
  (initget "T D")
  (if (and
	(if (setq kw (getkword "\nTren xuong/Duoi len[T/D]<T>: ")) kw (setq kw "T"))
	(setq ss (ssget '((0 . "*TEXT"))))
      )
    (progn
      (setq str (getstring "\nNhap chuoi co dinh: "))
         (setq ss
	     (vl-sort (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))

		      '(lambda (x y)
			 (> (cadr (cdr (assoc 10 (entget x))))
			    (cadr (cdr (assoc 10 (entget y))))
			 )
		       )
	     )
      )
      (if (= kw "D")(setq ss (reverse ss)))
     (setq n (getint "\nNhap gia tri bat dau : "))
      (foreach e  (mapcar 'vlax-ename->vla-object ss)

(cond
((< n 10) (setq nv (strcat "0" (itoa n))) )
((>= n 10) (setq nv (itoa n)) )
)

	(vla-put-textstring e (strcat str nv))
	(setq n (+ n 1))
	)
    )
  )
  (princ)
  )
 

<<

Filename: 406450_td.lsp
Tác giả: various
Bài viết gốc: 406481
Tên lệnh: ldon+%C2%A0nil ldoff+nil
Lisp Reactor Cho Acad2017

Chào mọi người. Em có dùng lisp reactor. Với cad2017 ( hoặc 2016 ) thì nó vô tác dụng, trong khi 2010 vẫn okie. Mong mọi người có thể giúp tháo gỡ khó khăn này :D

 

Đây là code lisp ạ

 

layerdirector:data
   '(
                         ...
>>

Chào mọi người. Em có dùng lisp reactor. Với cad2017 ( hoặc 2016 ) thì nó vô tác dụng, trong khi 2010 vẫn okie. Mong mọi người có thể giúp tháo gỡ khó khăn này :D

 

Đây là code lisp ạ

 

layerdirector:data
   '(
                           
;;-----------------------------------------------------------------------------------------------------------------------------------------------------;;
;;  Command Pattern  |  Layer Name    |       Description       |    Colour    |   Linetype   |    Lineweight    |       Plot       |    Plot Style    ;;
;;-----------------------------------------------------------------------------------------------------------------------------------------------------;;
;;     [string]      |   [string]     |         [string]        | 0 < int <256 |   [string]   | -3 = Default     |  1 = Will Plot   |     [string]     ;;
;;                   |                |     Use "" for none     |              |              |  0 <= int <= 211 |  0 = Won't Plot  |  Use nil for CTB ;;
;;-----------------------------------------------------------------------------------------------------------------------------------------------------;;
 
("[DM]TEXT,TEXT"       "TEXT"           "Text Layer"                   2        "Continuous"           -3                 1                 nil         )
("DIM*,*LEADER"        "DIMENSIONS"     "Dimension Layer"              3        "Continuous"           -3                 1                 nil         )
("*VPORT*"             "DEFPOINTS"      ""                             7        "Continuous"           -3                 0                 nil         )
("XLINE"               "XLINE"          "Construction Lines"          12        "HIDDEN"                0                 0                 nil         )
 
;;-----------------------------------------------------------------------------------------------------------------------------------------------------;;
 
    )
 
;;----------------------------------------------------------------------;;
;;  Force Layer Properties  [ t / nil ]                                 ;;
;;  ==================================================================  ;;
;;                                                                      ;;
;;  If set to T the properties of existing layers will be modified to   ;;
;;  match those found in the Layer Data list above.                     ;;
;;----------------------------------------------------------------------;;
 
layerdirector:forcelayprops nil
 
;;----------------------------------------------------------------------;;
;;  System Variable Settings                                            ;;
;;  ==================================================================  ;;
;;                                                                      ;;
;;  Populate this list with system variables whose values should be     ;;
;;  automatically changed when a layer change is triggered.             ;;
;;                                                                      ;;
;;  The first item should be a symbol or string corresponding to the    ;;
;;  name of a system variable; the second item should represent the     ;;
;;  value to which the system variable should be set when a layer       ;;
;;  change is triggered.                                                ;;
;;                                                                      ;;
;;  This parameter is optional: remove all list items if no system      ;;
;;  variable changes are to be performed.                               ;;
;;----------------------------------------------------------------------;;
 
layerdirector:sysvars
   '(
 
;;---------------------------------;;
;;  System Variable  |    Value    ;;
;;---------------------------------;;
 
(cecolor              "bylayer")
(celtype              "bylayer")
(celweight               -1    )
 
;;----------------------------------------------------------------------;;
 
    )
 
;;----------------------------------------------------------------------;;
;;  XRef-Dependent Layering                                             ;;
;;  ==================================================================  ;;
;;                                                                      ;;
;;  This option will cause external references (xrefs) to be inserted   ;;
;;  on a layer whose layer name is dependent on the name of the xref.   ;;
;;                                                                      ;;
;;  The first and second items in the below list represent an optional  ;;
;;  prefix and suffix which will surround the xref name in the name of  ;;
;;  the layer generated by the program.                                 ;;
;;                                                                      ;;
;;  The remaining items in the list determine the properties of the     ;;
;;  layers generated by the program for each xref; the order and        ;;
;;  permitted values of such properties are identical to those used by  ;;
;;  the Layer Data list above.                                          ;;
;;                                                                      ;;
;;  To disable this option, simply replace the below list with nil.     ;;
;;----------------------------------------------------------------------;;
 
layerdirector:xreflayer
 
;;-----------------------------------------------------------------------------------------------------------------------------------------------------;;
;;   Layer Prefix   |  Layer Suffix   |       Description       |    Colour    |   Linetype   |    Lineweight    |       Plot       |    Plot Style    ;;
;;-----------------------------------------------------------------------------------------------------------------------------------------------------;;
;;    [string]      |    [string]     |         [string]        | 0 < int <256 |   [string]   | -3 = Default     |  1 = Will Plot   |     [string]     ;;
;; Use "" for none  | Use "" for none |     Use "" for none     |              |              |  0 <= int <= 211 |  0 = Won't Plot  |  Use nil for CTB ;;
;;-----------------------------------------------------------------------------------------------------------------------------------------------------;;
 
'("XREF-"             ""               "XRef Layer"                   250        "Continuous"           -3                 1                 nil        )
 
;;-----------------------------------------------------------------------------------------------------------------------------------------------------;;
 
;;----------------------------------------------------------------------;;
;;  Print Command (Debug Mode)  [ t / nil ]                             ;;
;;  ==================================================================  ;;
;;                                                                      ;;
;;  If set to T the program will print the command name when a command  ;;
;;  is called. This is useful when determining the correct command name ;;
;;  to use in the Layer Data list.                                      ;;
;;----------------------------------------------------------------------;;
 
layerdirector:printcommand nil
 
)
 
;;----------------------------------------------------------------------;;
;;  Commands:  [ LDON / LDOFF ]                                         ;;
;;  ==================================================================  ;;
;;                                                                      ;;
;;  Use these to manually turn the Layer Director on & off.             ;;
;;----------------------------------------------------------------------;;
 
(defun c:ldon  nil (LM:layerdirector  t ))
(defun c:ldoff nil (LM:layerdirector nil))
 
;;----------------------------------------------------------------------;;
 
(if layerdirector:sysvars
    (setq layerdirector:sysvars
        (apply 'mapcar
            (cons 'list
                (vl-remove-if-not '(lambda ( x ) (getvar (car x)))
                    layerdirector:sysvars
                )
            )
        )
    )
)
 
;;----------------------------------------------------------------------;;
 
(defun LM:layerdirector ( on )
    (foreach grp (vlr-reactors :vlr-command-reactor :vlr-lisp-reactor)
        (foreach obj (cdr grp)
            (if (= "LM:layerdirector" (vlr-data obj))
                (vlr-remove obj)
            )
        )
    )
    (or
        (and on
            (vlr-command-reactor "LM:layerdirector"
               '(
                    (:vlr-commandwillstart . LM:layerdirector:set)
                    (:vlr-commandended     . LM:layerdirector:reset)
                    (:vlr-commandcancelled . LM:layerdirector:reset)
                    (:vlr-commandfailed    . LM:layerdirector:reset)
                )
            )
            (vlr-lisp-reactor "LM:layerdirector"
               '(
                    (:vlr-lispwillstart . LM:layerdirector:set)
                    (:vlr-lispended     . LM:layerdirector:reset)
                    (:vlr-lispcancelled . LM:layerdirector:reset)
                )
            )
            (princ "\nLayer Director enabled.")
        )
        (princ "\nLayer Director disabled.")
    )
    (princ)
)
 
;;----------------------------------------------------------------------;;
 
(defun LM:layerdirector:lispcommand ( str )
    (if (wcmatch str "(C:*)") (substr str 4 (- (strlen str) 4)) str)
)
 
;;----------------------------------------------------------------------;;
 
(defun LM:layerdirector:set ( obj arg / lst tmp )
    (if
        (and
            (setq arg (car arg))
            (setq arg (LM:layerdirector:lispcommand (strcase arg)))
            (setq lst (cdar (vl-member-if '(lambda ( x ) (wcmatch arg (strcase (car x)))) layerdirector:data)))
            (setq tmp (LM:layerdirector:createlayer lst))
            (zerop (logand 1 (cdr (assoc 70 tmp))))
        )
        (progn
            (setq layerdirector:oldlayer (getvar 'clayer)
                  layerdirector:oldvars  (mapcar 'getvar (car layerdirector:sysvars))
            )
            (if layerdirector:sysvars
                (apply 'mapcar (cons 'setvar layerdirector:sysvars))
            )
            (setvar 'clayer (car lst))
        )
    )
    (if layerdirector:printcommand (print arg))
    (princ)
)
 
;;----------------------------------------------------------------------;;
 
(defun LM:layerdirector:reset ( obj arg / tmp )
    (if (or (null (car arg)) (not (wcmatch (strcase (car arg)) "U,UNDO")))
        (progn
            (if (and (= 'str (type layerdirector:oldlayer))
                     (setq tmp (tblsearch "layer" layerdirector:oldlayer))
                     (zerop (logand 1 (cdr (assoc 70 tmp))))
                )
                (progn
                    (setvar 'clayer layerdirector:oldlayer)
                    (setq layerdirector:oldlayer nil)
                )
            )
            (mapcar 'setvar (car layerdirector:sysvars) layerdirector:oldvars)
            (setq layerdirector:oldvars nil)
            (if (and (car arg) (wcmatch (strcase (car arg)) "XATTACH,CLASSICXREF"))
                (LM:layerdirector:xreflayer)
            )
        )
    )
    (princ)
)
 
;;----------------------------------------------------------------------;;
 
(defun LM:layerdirector:xreflayer ( / ent enx lay obj xrf )
    (if
        (and
            (= 'list  (type layerdirector:xreflayer))
            (setq ent (entlast))
            (setq enx (entget ent))
            (= "INSERT" (cdr (assoc 0 enx)))
            (setq xrf   (cdr (assoc 2 enx))
                  lay   (strcat (car layerdirector:xreflayer) xrf (cadr layerdirector:xreflayer))
            )
            (= 4 (logand 4 (cdr (assoc 70 (tblsearch "block" xrf)))))
            (LM:layerdirector:createlayer (cons lay (cddr layerdirector:xreflayer)))
            (setq obj (vlax-ename->vla-object ent))
            (vlax-write-enabled-p obj)
        )
        (vla-put-layer obj lay)
    )
)
 
;;----------------------------------------------------------------------;;
 
(defun LM:layerdirector:createlayer ( lst / def )
    (if (or layerdirector:forcelayprops (not (setq def (tblsearch "layer" (car lst)))))
        (apply
           '(lambda ( lay des col ltp lwt plt pst / dic )
                (   (lambda ( def / ent )
                        (if (setq ent (tblobjname "layer" (car lst)))
                            (entmod (cons (cons -1 ent) def))
                            (entmake def)
                        )
                    )
                    (vl-list*
                       '(000 . "LAYER")
                       '(100 . "AcDbSymbolTableRecord")
                       '(100 . "AcDbLayerTableRecord")
                       '(070 . 0)
                        (cons 002 lay)
                        (cons 062 (if (< 0 col 256) col 7))
                        (cons 006 (if (LM:layerdirector:loadlinetype ltp) ltp "Continuous"))
                        (cons 370 (if (or (= -3 lwt) (<= 0 lwt 211)) lwt -3))
                        (cons 290 plt)
                        (append
                            (if (and (= 'str (type pst))
                                     (zerop (getvar 'pstylemode))
                                     (setq dic (dictsearch (namedobjdict) "acad_plotstylename"))
                                     (setq dic (dictsearch (cdr (assoc -1 dic)) pst))
                                )
                                (list (cons 390 (cdr (assoc -1 dic))))
                            )
                            (if (and des (/= "" des))
                                (progn (regapp "AcAecLayerStandard")
                                    (list
                                        (list -3
                                            (list
                                                "AcAecLayerStandard"
                                               '(1000 . "")
                                                (cons 1000 des)
                                            )
                                        )
                                    )
                                )
                            )
                        )
                    )
                )
            )
            lst
        )
        def
    )
)
 
;;----------------------------------------------------------------------;;
 
(defun LM:layerdirector:loadlinetype ( ltp )
    (eval
        (list 'defun 'LM:layerdirector:loadlinetype '( ltp )
            (list 'cond
               '(   (tblsearch "ltype" ltp) ltp)
                (list
                    (list 'vl-some
                        (list 'quote
                            (list 'lambda '( lin )
                                (list 'vl-catch-all-apply ''vla-load
                                    (list 'list (vla-get-linetypes (vla-get-activedocument (vlax-get-acad-object))) 'ltp 'lin)
                                )
                               '(tblsearch "ltype" ltp)
                            )
                        )
                        (list 'quote
                            (vl-remove-if
                               '(lambda ( x )
                                    (member (strcase x t)
                                        (if (zerop (getvar 'measurement))
                                           '("acadiso.lin"  "iso.lin") ;; Known metric   .lin files
                                           '("acad.lin" "default.lin") ;; Known imperial .lin files
                                        )
                                    )
                                )
                                (apply 'append
                                    (mapcar
                                       '(lambda ( dir ) (vl-directory-files dir "*.lin" 1))
                                        (vl-remove "" (LM:layerdirector:str->lst (getenv "ACAD") ";"))
                                    )
                                )
                            )
                        )
                    )
                    'ltp
                )
            )
        )
    )
    (LM:layerdirector:loadlinetype ltp)
)
 
;;----------------------------------------------------------------------;;
 
(defun LM:layerdirector:str->lst ( str del / pos )
    (if (setq pos (vl-string-search del str))
        (cons (substr str 1 pos) (LM:layerdirector:str->lst (substr str (+ pos 1 (strlen del))) del))
        (list str)
    )
)
 
;;----------------------------------------------------------------------;;
 
(   (lambda ( )
        (vl-load-com)
        (if (= 'list (type s::startup))
            (if (not (member '(LM:layerdirector t) s::startup))
                (setq s::startup (append s::startup '((LM:layerdirector t))))
            )
            (defun-q s::startup nil (LM:layerdirector t))
        )
        (princ)
    )
)
 
;;----------------------------------------------------------------------;;
;;                             End of File                              ;;
;;----------------------------------------------------------------------;;
 
 
(   (lambda nil (vl-load-com)
        (defun c:mteditreactoron nil
            (mtedit-reactor-remove)
            (vlr-set-notification
                (vlr-command-reactor "mtedit-reactor"
                   '((:vlr-commandwillstart . mtedit-reactor-callback))
                )
                'active-document-only
            )
            (vlr-set-notification
                (vlr-editor-reactor "mtedit-reactor"
                   '((:vlr-beginclose . mtedit-reactor-clean))
                )
                'active-document-only
            )
            (princ "\nMTEdit Reactor enabled.")
            (princ)
        )
        (defun c:mteditreactoroff nil
            (mtedit-reactor-remove)
            (mtedit-reactor-clean nil nil)
            (princ "\nMTEdit Reactor disabled.")
            (princ)
        )
        (defun mtedit-reactor-callback ( a b )
            (if (wcmatch (strcase (car b) t) "mtedit,mleadercontentedit")
                (if (or mtedit-reactor-wsh (setq mtedit-reactor-wsh (vlax-create-object "wscript.shell")))
                    (vl-catch-all-apply 'vlax-invoke (list mtedit-reactor-wsh 'sendkeys "^{HOME}(^+{END})"))
                )
            )
            (princ)
        )
        (defun mtedit-reactor-clean ( a b )
            (if (= 'vla-object (type mtedit-reactor-wsh))
                (vl-catch-all-apply 'vlax-release-object (list mtedit-reactor-wsh))
            )
            (setq mtedit-reactor-wsh nil)
            (princ)
        )
        (defun mtedit-reactor-remove nil
            (foreach grp (vlr-reactors :vlr-command-reactor :vlr-editor-reactor)
                (foreach obj (cdr grp)
                    (if (= "mtedit-reactor" (vlr-data obj))
                        (vlr-remove obj)
                    )
                )
            )
        )
        (c:mteditreactoron)
        (princ)
    )
)

<<

Filename: 406481_ldon+%C2%A0nil_ldoff+nil.lsp

Trang 209/330

209