Jump to content
InfoFile
Tác giả:
Bài viết gốc: 0
Tên lệnh: lcui uncui

Filename: 13227_lcui_uncui.lsp
Tác giả: hoavusua
Bài viết gốc: 304488
Tên lệnh: to
Nhờ sửa giúp lisp tính tổng chiều dài
Dưới đầy lài lisp tính tổng chiều dài của mình. giờ mình muốn có thêm đoạn pick chọn layer để tính tổng sau đó mới quét khu vực có layer đó để tính tổng (nó sẽ loại những đối tượng không thuộc layer đó để chỉ tính tổng các đối tượng đã thuộc layer đã chọn). cảm ơn mọi người quan tâm.

(defun C:to (/ tot_len ss e_name e_record e_type)
(setvar "cmdecho"...
>>
Dưới đầy lài lisp tính tổng chiều dài của mình. giờ mình muốn có thêm đoạn pick chọn layer để tính tổng sau đó mới quét khu vực có layer đó để tính tổng (nó sẽ loại những đối tượng không thuộc layer đó để chỉ tính tổng các đối tượng đã thuộc layer đã chọn). cảm ơn mọi người quan tâm.

(defun C:to (/ tot_len ss e_name e_record e_type)
(setvar "cmdecho" 0)
(prompt "\nBan hay chon cac doi tuong: line,arc,circle,polyline,ellipse,spline,... ")
(prompt "\nDe tinh tong chieu dai cho tat ca cac doi tuong do!")   
(setq tot_len 0.0)
(setq ss (ssget))
(if (null ss)
(exit)
)
(while (> (sslength ss) 0)
(setq e_name (ssname ss 0))
(setq e_record (entget e_name))
(setq e_type (cdr (assoc '0 e_record)))
(cond ((wcmatch e_type "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")
(command "lengthen" e_name "")
(setq tot_len (+ tot_len (getvar "PERIMETER")))
(ssdel e_name ss)
)
((wcmatch e_type "MLINE") (add_mline))	; Link sang Ham add_mline ***********************
(e_type (ssdel e_name ss))
)
)
(prompt (strcat "\nTong chieu dai cua cac doi tuong la: " (rtos tot_len 2 4)))
(princ)
(setq en (car (entsel "\nThay cho so : ")))
(print tot_len)
  (setq elst (entget en))
  (setq elst (subst (cons 1 (rtos tot_len 2 3)) (assoc 1 elst) elst))
  (setq elst (append elst '((62 . 2))))
  (entmod elst)
(setvar "cmdecho" 1)

)

 


<<

Filename: 304488_to.lsp
Tác giả: nguyentuyen6
Bài viết gốc: 304489
Tên lệnh: to
Nhờ sửa giúp lisp tính tổng chiều dài

Đây bạn

 

(defun C:to (/ tot_len ss e_name e_record e_type tenlayer)
(setvar "cmdecho" 0)
(prompt "\nBan hay chon cac doi tuong: line,arc,circle,polyline,ellipse,spline,... ")
(prompt "\nDe tinh tong chieu dai cho tat ca cac doi tuong do!")   
(setq tot_len 0.0)

(setq  tenlayer (cdr (assoc 8 (entget (car (entsel "\nChon mau layer:"))))))
(prompt "\nChon doi tuong tinh chieu dai:") 
(setq ss (ssget (list (cons 8 tenlayer))))
(if (null...
>>

Đây bạn

 

(defun C:to (/ tot_len ss e_name e_record e_type tenlayer)
(setvar "cmdecho" 0)
(prompt "\nBan hay chon cac doi tuong: line,arc,circle,polyline,ellipse,spline,... ")
(prompt "\nDe tinh tong chieu dai cho tat ca cac doi tuong do!")   
(setq tot_len 0.0)

(setq  tenlayer (cdr (assoc 8 (entget (car (entsel "\nChon mau layer:"))))))
(prompt "\nChon doi tuong tinh chieu dai:") 
(setq ss (ssget (list (cons 8 tenlayer))))
(if (null ss)
(exit)
)
(while (> (sslength ss) 0)
(setq e_name (ssname ss 0))
(setq e_record (entget e_name))
(setq e_type (cdr (assoc '0 e_record)))
(cond ((wcmatch e_type "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")
(command "lengthen" e_name "")
(setq tot_len (+ tot_len (getvar "PERIMETER")))
(ssdel e_name ss)
)
((wcmatch e_type "MLINE") (add_mline))	; Link sang Ham add_mline ***********************
(e_type (ssdel e_name ss))
)
)
(prompt (strcat "\nTong chieu dai cua cac doi tuong la: " (rtos tot_len 2 4)))
(princ)
(setq en (car (entsel "\nThay cho so : ")))
(print tot_len)
  (setq elst (entget en))
  (setq elst (subst (cons 1 (rtos tot_len 2 3)) (assoc 1 elst) elst))
  (setq elst (append elst '((62 . 2))))
  (entmod elst)
(setvar "cmdecho" 1)
)



<<

Filename: 304489_to.lsp
Tác giả: Tot77
Bài viết gốc: 304501
Tên lệnh: nt tinh
Sửa giùm mình lisp

Cũng chẳng có gì, sửa lại chút thôi.

(defun C:nt(/ tm tm1 cao)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (defun txt1011 (x) (if (= 0 (distance (dxf 11 x) '(0 0))) (dxf 10 x) (dxf 11 x)))
  (setq tm (vl-sort (mapcar '(lambda(x) (list (txt1011 x) x))
    (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*TEXT")))))))
  '(lambda (x y) (< (cadar x) (cadar y))))
cao (dxf 40 (last (car tm))))
  (while tm
 ...
>>

Cũng chẳng có gì, sửa lại chút thôi.

(defun C:nt(/ tm tm1 cao)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (defun txt1011 (x) (if (= 0 (distance (dxf 11 x) '(0 0))) (dxf 10 x) (dxf 11 x)))
  (setq tm (vl-sort (mapcar '(lambda(x) (list (txt1011 x) x))
    (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*TEXT")))))))
  '(lambda (x y) (< (cadar x) (cadar y))))
cao (dxf 40 (last (car tm))))
  (while tm
    (setq tm1 (vl-sort (vl-remove-if-not
'(lambda(x) (equal (cadr (caar tm)) (cadar x) cao)) tm)
    '(lambda (x y) (< (caar x) (caar y)) )) 
 tm (vl-remove-if
'(lambda(x) (equal (cadr (caar tm)) (cadar x) cao)) tm))
    (if (= (length tm1) 2)
      (entmod (subst
(cons 1 (strcat (dxf 1 (last (car tm1))) "-" (dxf 1 (last (last tm1))) "L"))
(assoc 1 (entget (last (car tm1)))) (entget (last (car tm1)))))
    )
  ) (princ)
)
 
(defun C:tinh(/ tm tm1 cao)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (defun txt1011 (x) (if (= 0 (distance (dxf 11 x) '(0 0))) (dxf 10 x) (dxf 11 x)))
  (setq tm (vl-sort (mapcar '(lambda(x) (list (txt1011 x) x))
    (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*TEXT")))))))
  '(lambda (x y) (< (cadar x) (cadar y))))
cao (dxf 40 (last (car tm)))
ptinh (getstring "\nPhep tinh:"))
  (while tm
    (setq tm1 (vl-sort (vl-remove-if-not
'(lambda(x) (equal (cadr (caar tm)) (cadar x) cao)) tm)
    '(lambda (x y) (< (caar x) (caar y)) )) 
 tm (vl-remove-if
'(lambda(x) (equal (cadr (caar tm)) (cadar x) cao)) tm))
    (if (= (length tm1) 3)
      (entmod (subst 
(cons 1 (rtos ((eval (read ptinh)) (atof (dxf 1 (last (car tm1))))
     (atof (dxf 1 (last (cadr tm1)))))))
(assoc 1 (entget (last (last tm1)))) (entget (last (last tm1)))))
    )
  ) (princ)
)

<<

Filename: 304501_nt_tinh.lsp
Tác giả: thanhduan2407
Bài viết gốc: 304560
Tên lệnh: clt
Xin lisp nội suy cao độ từ 2 điểm (3 điểm nằm trên 1 đoạn thẳng)

Bạn dùng Lisp này nhé!

(defun c:clt(/ chieucao  stt  item1 temp1 Tdo1 X1 Y1 Z1 Caodo1 item2 Tdo2 X2 Y2 Z2 Caodo2 pt1 pt2 pt3 X3 Y3 Z3 d1 d2 d dh dhz Caodo3) ;chen lien tiep tu 2 diem 
		(or *chieucao* (setq *chieucao* 1))
		(setq chieucao (getreal (strcat "\n Chieu cao text <"
					  (rtos *chieucao* 2 2)
					 "> :"
				  )
			 )
		)
		(if (not chieucao) (setq chieucao *chieucao*) (setq *chieucao* chieucao))
  	    (setq stt 1)
  	   ...
>>

Bạn dùng Lisp này nhé!

(defun c:clt(/ chieucao  stt  item1 temp1 Tdo1 X1 Y1 Z1 Caodo1 item2 Tdo2 X2 Y2 Z2 Caodo2 pt1 pt2 pt3 X3 Y3 Z3 d1 d2 d dh dhz Caodo3) ;chen lien tiep tu 2 diem 
		(or *chieucao* (setq *chieucao* 1))
		(setq chieucao (getreal (strcat "\n Chieu cao text <"
					  (rtos *chieucao* 2 2)
					 "> :"
				  )
			 )
		)
		(if (not chieucao) (setq chieucao *chieucao*) (setq *chieucao* chieucao))
  	    (setq stt 1)
  	    (_layer2 "Them_lt" 6)
            (setq Olmode (getvar "OSMODE"))
  	    
  (progn
            (setq item1 (entsel "\nChon text thu nhat : "))
  	    (setq temp1  (entget (car item1)))
	    (setq Tdo1 (TD:Text-Base (car item1 )))
	    (setq  Caodo1 (cdr (assoc 1 temp1))
	              x1 (car Tdo1)
	              y1 (cadr Tdo1)
            )
	    (setq pt1 (list x1 y1))
            (setq  z1 (atof Caodo1))
  
            (setq item2 (entsel "\nChon text thu hai : "))
  	    (setq temp2  (entget (car item2)))
	    (setq Tdo2 (TD:Text-Base (car item2 )))
	    (setq  Caodo2 (cdr (assoc 1 temp2))
	              x2 (car Tdo2)
	              y2 (cadr Tdo2)
            )
            (setq pt2 (list x2 y2))
            (setq z2 (atof Caodo2))
    )
            
  (while
         (progn
         (setvar "OSMODE" 512 )
            (setq pt3 (getpoint "\nVi tri chen diem : "))
            (setq x3 (car pt3))
            (setq y3 (cadr pt3))
            (setq d1 (distance pt1 pt3))
            (setq d2 (distance pt2 pt3))
            (setq d (+ d1 d2))
            (setq dh (- z2 z1))
            (setq dhz (* dh (/ d1 d)))
            (setq z3 (+ z1 dhz))
            (setq Caodo3 (rtos z3 2 3))
            (setq pt3 (list x3 y3 z3))
	    (MakeText pt3 Caodo3 chieucao 0 "C" "Them_lt")
	   (setq stt (+ stt 1))
      )
   )
   (setvar "OSMODE" Olmode )
   (princ)
)

;;;Lấy tọa độ chuẩn của Text
(defun TD:Text-Base (ent)
  (setq Ma10  (cdr (assoc 10 (entget ent))))
  (setq Ma11  (cdr (assoc 11 (entget ent))))
  (setq X11 (car Ma11))
  (setq Ma71  (cdr (assoc 71 (entget ent))))
  (setq Ma72  (cdr (assoc 72 (entget ent))))
  (if (or (and (= Ma71 0) (= Ma72 0) (= X11 0))
	  (and (= Ma71 0) (= Ma72 3) )
	  (and (= Ma71 0) (= Ma72 5) )
      )
    Ma10
    Ma11
   )
)
;;;;Tạo Layer 
(defun _layer2 ( name colour )
    (if (null (tblsearch "LAYER" name))
        (entmake
            (list
               '(0 . "LAYER")
               '(100 . "AcDbSymbolTableRecord")
               '(100 . "AcDbLayerTableRecord")
               '(70 . 0)
                (cons 2 name)
                (cons 62 colour)
            )
        )
    )
)
;;;;Make by Thaistreetz
(defun MakeText (point string Height Ang justify  Layer  / Lst); Ang: Radial
	(setq Lst (list '(0 . "TEXT")
									(cons 10 point)
									(cons 40 Height)
									(cons 1 string)
								        (cons 50 Ang)
									(cons 8 Layer)
			)
				justify (strcase justify))
	(cond ((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))
				((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))
				((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))
				((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))
				((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))
				((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))	
				((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))
				((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))
				((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))
				((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))
				((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))
				((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1))))))
	(entmakex Lst)
  )

 

(defun c:clt(/ chieucao  stt  item1 temp1 Tdo1 X1 Y1 Z1 Caodo1 item2 Tdo2 X2 Y2 Z2 Caodo2 pt1 pt2 pt3 X3 Y3 Z3 d1 d2 d dh dhz Caodo3) ;chen lien tiep tu 2 diem 
(or *chieucao* (setq *chieucao* 1))
(setq chieucao (getreal (strcat "\n Chieu cao text <"
 (rtos *chieucao* 2 2)
"> :"
 )
)
)
(if (not chieucao) (setq chieucao *chieucao*) (setq *chieucao* chieucao))
     (setq stt 1)
     (_layer2 "Them_lt" 6)
            (setq Olmode (getvar "OSMODE"))
     
  (progn
            (setq item1 (entsel "\nChon text thu nhat : "))
     (setq temp1  (entget (car item1)))
   (setq Tdo1 (TD:Text-Base (car item1 )))
   (setq  Caodo1 (cdr (assoc 1 temp1))
             x1 (car Tdo1)
             y1 (cadr Tdo1)
            )
   (setq pt1 (list x1 y1))
            (setq  z1 (atof Caodo1))
  
            (setq item2 (entsel "\nChon text thu hai : "))
     (setq temp2  (entget (car item2)))
   (setq Tdo2 (TD:Text-Base (car item2 )))
   (setq  Caodo2 (cdr (assoc 1 temp2))
             x2 (car Tdo2)
             y2 (cadr Tdo2)
            )
            (setq pt2 (list x2 y2))
            (setq z2 (atof Caodo2))
    )
            
  (while
         (progn
         (setvar "OSMODE" 512 )
            (setq pt3 (getpoint "\nVi tri chen diem : "))
            (setq x3 (car pt3))
            (setq y3 (cadr pt3))
            (setq d1 (distance pt1 pt3))
            (setq d2 (distance pt2 pt3))
            (setq d (+ d1 d2))
            (setq dh (- z2 z1))
            (setq dhz (* dh (/ d1 d)))
            (setq z3 (+ z1 dhz))
            (setq Caodo3 (rtos z3 2 3))
            (setq pt3 (list x3 y3 z3))
   (MakeText pt3 Caodo3 chieucao 0 "C" "Them_lt")
  (setq stt (+ stt 1))
      )
   )
   (setvar "OSMODE" Olmode )
   (princ)
)

<<

Filename: 304560_clt.lsp
Tác giả: pphung183
Bài viết gốc: 304557
Tên lệnh: wpo
dùng lệnh wipeout cho ellipse

Vẽ Wipeout đường tròn bằng Polygon cạnh 300 đây, muốn hình vuông thì cạnh = 4 :)

(defun C:WPO (/ res cp pt oldos)
       (command "undo" "be")
(setq oldos (getvar "osmode"))
  (setq defres (if defres defres "300"))
  (setq res (getstring (strcat "\nEnter Resolution <"defres">: ")))
  (if (> (strlen res) 0) (setq defres res) (setq res defres))
  (setq cp (getpoint "\nPick Center Point: "))
  (setq pt (getpoint cp "\nPick Point:...
>>

Vẽ Wipeout đường tròn bằng Polygon cạnh 300 đây, muốn hình vuông thì cạnh = 4 :)

(defun C:WPO (/ res cp pt oldos)
       (command "undo" "be")
(setq oldos (getvar "osmode"))
  (setq defres (if defres defres "300"))
  (setq res (getstring (strcat "\nEnter Resolution <"defres">: ")))
  (if (> (strlen res) 0) (setq defres res) (setq res defres))
  (setq cp (getpoint "\nPick Center Point: "))
  (setq pt (getpoint cp "\nPick Point: "))
  (setvar "osmode" 0) 
(initget "I C")
(setq sel (getkword "\nV\U+1EBD \U+0111a gi\U+00E1c n\U+1ED9i ti\U+1EBFp (I) hay ngo\U+1EA1i ti\U+1EBFp (C) v\U+1EDBi \U+0111\U+01B0\U+1EDDng tr\U+00F2n ? <C> :"))
(if (= sel "C")
 (command "polygon" res cp "C" pt)
 (command "polygon" res cp "I" pt)
)
  (command "wipeout" "polyline" "last" "yes")
(setvar "osmode" oldos)
(command "undo" "e")
  (princ))

<<

Filename: 304557_wpo.lsp
Tác giả: Tot77
Bài viết gốc: 304570
Tên lệnh: test
Xin lisp kiểm tra độ vênh của tấm BTXM

Tưởng bạn làm số lượng ít và rời rac, chứ nhiều như vậy thì dù có lisp mà cứ quét 4 cái như trên thấy cũng khá là vất vả.

Thôi làm "rướn" thêm cho bạn cái này, bạn có thể chọn nhiều hàng nhiều cột 1 lúc, cái nào không ok thì sẽ chuyển màu đỏ và có ghi độ vênh. Khi chọn đừng chọn text trùng lên nhau.

Và điều quan trọng là các hàng đều nằm ngang giống file bạn đưa...

>>

Tưởng bạn làm số lượng ít và rời rac, chứ nhiều như vậy thì dù có lisp mà cứ quét 4 cái như trên thấy cũng khá là vất vả.

Thôi làm "rướn" thêm cho bạn cái này, bạn có thể chọn nhiều hàng nhiều cột 1 lúc, cái nào không ok thì sẽ chuyển màu đỏ và có ghi độ vênh. Khi chọn đừng chọn text trùng lên nhau.

Và điều quan trọng là các hàng đều nằm ngang giống file bạn đưa chứ không xiên xéo.

 

(defun test(l / canhngan caodo kq)     
  (setq canhngan (min (distance (caar l) (car (nth 1 l)))
     (distance (caar l) (car (nth 2 l))))       
caodo (mapcar '(lambda(x) (atof (cdr (assoc 1 (entget (last x)))))) l))
  
  (if (> (setq kq (/ (abs (- (+ (nth 0 caodo) (nth 3 caodo))
   (+ (nth 1 caodo) (nth 2 caodo)))) canhngan 1.0)) 0.01)
    (progn 
      (mapcar '(lambda(x) (command "change" (last x) "" "P" "c" "1" "")) l)
      (princ (strcat "\nDo venh " (rtos kq) " > 1%"))
    )
  )
  (princ)  
)
 
(defun c:test(/ tm0 tm tm1 cao n m hang cot a b)
  (setvar 'cmdecho 0)
  (prompt "\nChon text :")
  (setq tm0 (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "TEXT"))))))
tm0 (mapcar '(lambda(x) (list (cdr (assoc 10 (entget x))) x)) tm0)
tm0 (vl-sort tm0 '(lambda(x y) (< (cadar x) (cadar y))))
cao (cdr (assoc 40 (entget (last (car tm0)))))
tm nil
  )
  (while tm0
    (setq tm1 (vl-sort (vl-remove-if-not
'(lambda(x) (equal (cadr (caar tm0)) (cadar x) cao)) tm0)
    '(lambda (x y) (< (caar x) (caar y)) )) 
 tm0 (vl-remove-if
'(lambda(x) (equal (cadr (caar tm0)) (cadar x) cao)) tm0)
 tm (append tm (list tm1))
    )
  )
  (setq m -1
hang (length tm)
cot (length (car tm)))
  (repeat (1- hang)
      (setq n -1
   m (1+ m)
   a (nth m tm)
   b (nth (1+ m) tm))
      (repeat (1- cot)
        (setq n (1+ n))
(test (list (nth n a) (nth (1+ n) a) (nth n b) (nth (1+ n) b)))
      )
  )
  (setvar 'cmdecho 1)
  (princ)
)

<<

Filename: 304570_test.lsp
Tác giả: nguyentuyen6
Bài viết gốc: 304770
Tên lệnh: cdc
Sửa lisp công độ cao

Bạn thử cái này xem

 

(vl-load-com)
(Defun Init()
 (setvar "BLIPMODE" 0)
 (setvar "CMDECHO" 0)
)
(Defun Reinit()
 (setvar "BLIPMODE" 1)
 (setvar "CMDECHO" 1)
 (setvar "LUPREC" 4)
 (princ)
)

(defun sai()
 (setq pt (cdr (assoc 10 lEi)))
 (setq hi (cdr (assoc 40 lEi)))
 (makeC pt hi)
)

(Defun MakeC( pt h / edt)
   (setvar "LUPREC" 2)
   (setq edt (list (cons 0 "CIRCLE")
                   (cons 8 "tron")
                   (cons 62 2)
           ...
>>

Bạn thử cái này xem

 

(vl-load-com)
(Defun Init()
 (setvar "BLIPMODE" 0)
 (setvar "CMDECHO" 0)
)
(Defun Reinit()
 (setvar "BLIPMODE" 1)
 (setvar "CMDECHO" 1)
 (setvar "LUPREC" 4)
 (princ)
)

(defun sai()
 (setq pt (cdr (assoc 10 lEi)))
 (setq hi (cdr (assoc 40 lEi)))
 (makeC pt hi)
)

(Defun MakeC( pt h / edt)
   (setvar "LUPREC" 2)
   (setq edt (list (cons 0 "CIRCLE")
                   (cons 8 "tron")
                   (cons 62 2)
                   (cons 10 pt)
                   (cons 40 (* hi 10))
             )
    )
    (entmake edt)
)
(Defun Makedocao( pt h stl hi wi layer / edt)
   (setvar "LUPREC" 2)
 

  (setq edt (list (cons 0 "text")
                   (cons 8 layer)
                   (cons 62 5)
                   (cons 10 pt)
                   (cons 1 (rtos h 2))
                   (cons 7 stl)
                   (cons 40 hi)
                   (cons 41 (* wi 0.8))
                   (cons 71 1)
             )
    )
    (entmake edt)
)

(defun chelv( layer / stl pt hi wi)
 (setq stl (cdr (assoc 7 lEi)))
 (setq pt (cdr (assoc 10 lEi)))
 (setq hi (cdr (assoc 40 lEi)))
 (setq wi (cdr (assoc 41 lEi)))
 (makedocao pt (+ dc osdc) stl hi wi layer)
 (print i)
)

(defun c:cdc(/ osdc ss noet i ei dc list_layer ii EN LAYER_NAME LEI SS_LAYER TENLAYER)
 (Init)
 (setq list_layer (list))
 ;(setq la (getstring "\n Layer nao ? : "))
 (princ "\nChon doi tuong layer mau:");;;princ
 (setq ss_layer (ssget))
 (setq i 0 );;;setq 
 (while (< i (sslength ss_layer))
    (setq en (ssname ss_layer i))
	(setq layer_name  (cdr (assoc 8 (entget en))));;;setq
	;(princ layer_name)
    (setq list_layer (append list_layer (list layer_name)))
    (setq i (1+ i))
  )
(setq list_layer (LM:Unique list_layer))
(setq ii 0 );;;setq 
(setq osdc (getdist "\n Cong them bao nhieu ? : "))
(while (< ii (length list_layer))
 (setq ss (ssget "X" (list (cons 0 "TEXT") (cons 8 (nth ii list_layer)))))
 (setq NoET (sslength ss))
 (setq tenlayer (nth ii list_layer))
 ;(princ (strcat "\n" (itoa NoET) " Doi tuong se bi thay doi"))
 ;(getint)
 (setq i 0)
      (Repeat NoET
          (setq Ei (ssname ss i))
          (setq i (+ 1 i))
          (setq lEi (entget Ei))
          (if (null (read (cdr (assoc 1 lEi))))
              (progn
                    (sai)
              )
              (progn
                    (setq dc (read (cdr (assoc 1 lEi))))
                    (if (numberp dc) (chelv  (strcat "evnew_" (itoa (1+ ii)))))
              )
          );if
      );Repeat
(setq ii (1+ ii))
)
 (Reinit)
)
(defun LM:Unique ( l / x r )
    (while l
        (setq x (car l)
              l (vl-remove x (cdr l))
              r (cons x r)
        )
    )
    (reverse r)
)

<<

Filename: 304770_cdc.lsp
Tác giả: thanhduan2407
Bài viết gốc: 304781
Tên lệnh: cdc
Sửa lisp công độ cao

Anh Phước thử dùng LISP này em vừa viết xem sao.

(defun c:cdc(/ osdc ss noet i ei dc list_layer ii EN LAYER_NAME LEI SS_LAYER TENLAYER)
(setq Delta (getreal "\n Nhap gia tri cong them: "))
(setq i 0)
(setq ssChon  (ssget))
(setq ss_So  (ChonTextSo ssChon))
(setq Lts_so (acet-ss-to-list ss_So))
(while (< i   (length Lts_so))
  (progn
	(setq E_Text (nth  i Lts_so))
  	(setq Item (entget E_Text))
  	(setq Caodo  (atof (cdr (assoc 1...
>>

Anh Phước thử dùng LISP này em vừa viết xem sao.

(defun c:cdc(/ osdc ss noet i ei dc list_layer ii EN LAYER_NAME LEI SS_LAYER TENLAYER)
(setq Delta (getreal "\n Nhap gia tri cong them: "))
(setq i 0)
(setq ssChon  (ssget))
(setq ss_So  (ChonTextSo ssChon))
(setq Lts_so (acet-ss-to-list ss_So))
(while (< i   (length Lts_so))
  (progn
	(setq E_Text (nth  i Lts_so))
  	(setq Item (entget E_Text))
  	(setq Caodo  (atof (cdr (assoc 1 Item))))
	(setq Layer_Text  (cdr (assoc 8 Item)))
    	(setq Color_Text  (cdr (assoc 62 Item)))
  	(setq Tenphu (Tachtenchinhphu Layer_Text))
  	(setq Layer_Text_moi (strcat "Evnew_"  Tenphu))
	(setq Caodo_moi (+ Caodo Delta))
    	(setq Item (subst (cons 1 (rtos Caodo_moi)) (assoc 1 Item) Item )) 
	(entmod Item)
    	(setq Item (subst (cons 8 Layer_Text_moi) (assoc 8 Item) Item ))
    	(entmod Item)
        (setq Item (subst (cons 62 Color_Text) (assoc 62 Item) Item ))
    	(entmod Item)
   )
   (setq i (1+ i))
)
(princ)
)
(defun ChonTextSo (ss / i ent str ss1) 
    (progn
      (setq i	0
	    ss1	(ssadd)
      )
      (repeat (sslength ss)
	(setq ent (ssname ss i)
	      str (cdr(assoc 1 (entget ent)))
	      i	  (+ 1 i)
	)
	(if (distof str 2)
	  (ssadd ent ss1)
	)
      )
      (if (> (sslength ss1) 0)
	ss1
      )      
    )
)

(defun Tachtenchinhphu(Name /)
	(setq tm_i 1 so nil Tenchinh "" Tenphu "")
	(repeat (strlen Name)
		(setq ch (substr Name tm_i 1))
		(if (= tm_i 1)
		   (progn
			(setq Tenchinh ch)
			(if (and (<= (ascii ch) 57)(>= (ascii ch) 48))
				(setq so T)
				(setq so nil)
			)
		   )
		   (progn
			(if so 
				(if (and (<= (ascii ch) 57)(>= (ascii ch) 48))
					(setq Tenchinh (strcat Tenchinh ch))
					(setq Tenphu (strcat Tenphu ch))
				)
				(if (and (<= (ascii ch) 57)(>= (ascii ch) 48))
					(setq Tenphu (strcat Tenphu ch))
					(setq Tenchinh (strcat Tenchinh ch))
				)
			)
		   )
		)
		(setq tm_i (+ tm_i 1))
	);
  Tenphu
)

<<

Filename: 304781_cdc.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 305114
Tên lệnh: timc
lisp tìm trắc ngang

Mình đang tập tành viết mấy ứng dụng nhỏ giúp cho công việc của mình là chủ yếu. Đang viết lisp tìm trắc ngang nhưng không chạy được nhờ mọi người giúp đỡ.

Nội dung lisp như sau

A. chọn đối tượng để làm lớp chuẩn, sau đó chương trình tự lọc được 2 tập hợp (cái này mình đã làm được)

1. tập tên cọc

2. tập lý trình

Sau đó sẽ ghép tập "tên cọc"...

>>

Mình đang tập tành viết mấy ứng dụng nhỏ giúp cho công việc của mình là chủ yếu. Đang viết lisp tìm trắc ngang nhưng không chạy được nhờ mọi người giúp đỡ.

Nội dung lisp như sau

A. chọn đối tượng để làm lớp chuẩn, sau đó chương trình tự lọc được 2 tập hợp (cái này mình đã làm được)

1. tập tên cọc

2. tập lý trình

Sau đó sẽ ghép tập "tên cọc" và tập "lý trình" lại với nhau (cái này mình cũng làm được rồi)

vấn đề đang vướng mắc là tạo 1 danh sách để đưa vào 1 popup_list (cái này viết đang bị lỗi ở đâu đó không hiểu)

đây là lisp đang viết:

(defun C:timc (/ datalist)
(defun sosanh (e1 e2 / p1 p2)
	(setq p1 (car e1)
		p2 (car e2)
	)
	(if (equal (cadr p1) (cadr p2) 1e-8)
		(< (car p1) (car p2))
		(> (cadr p1) (cadr p2))
	)
	)
(prompt "\nChon doi tuong coc hoac ly trinh lam lop chuan.")  
(setq dtltc (car (entsel)))
(setq lop1 (cdr (assoc 8 (entget dtltc))))
(setq danhsachc (acet-ss-to-list (ssget "X" (list (cons 8 lop1) (cons 1 "C*")))))
(setq danhsachkm (acet-ss-to-list (ssget "X" (list (cons 8 lop1) (cons 1 "K*")))))
(setq coc (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) danhsachc))
(setq km (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) danhsachkm))
(setq coc (vl-sort coc 'sosanh))
(setq km (vl-sort km 'sosanh))
(if (/= (length coc) (length km))
  (alert "Yeu cau so luong 'coc' & 'Ly trinh' phai bang nhau!")
  (progn
   (foreach ent1 coc
	(setq pt1 (car ent1))
	(setq dis (* 2 (distance pt1 (car (nth 0 km)))))
	(foreach ent2 km
	(setq pt2 (car ent2))
	(if (< (distance pt1 pt2) dis)
  	(setq dis (distance pt1 pt2) ent3 ent2)))
	(if (null datalist)
	(setq datalist (strcat (cdr ent1) "-" (cdr ent3)))
	(setq datalist (cons datalist (strcat (cdr ent1) "-" (cdr ent3))))
	)
	)
   )
   )
(setq DCL_ID (load_dialog (strcat odiachay "\\tlkt\\dcl\\Xuat_bang_tinh2.DCL")))
(new_dialog "Ha1" DCL_ID)
(start_list "tn")
(mapcar 'add_list datalist)
(end_list)
(set_tile "tn" (itoa (vl-position numside datalist)))
(action_tile "tn" "(setq numside (nth (atoi $value) datalist))")
(action_tile "btn_tim" "(done_dialog 1)")
(action_tile "btn_thoat" "(done_dialog 14)")
(setq phepchon (start_dialog))
(cond 
      ((= phepchon 1) (thoi))
      ((= phepchon 14) (thoi))
 )
 	(princ)
  )

đây là file DCL

//-----
Ha1 : dialog {
	label = "TIM TRAC NGANG - TRAC DOC";
 : column {
  	  fixed_width = true;
        alignment = centered;
 	  width = 0;
 	: boxed_column {
	  label = "TRAC_NGANG";
	  fixed_width = true;
	: popup_list {key = "tn";label = "Ten coc - Ly trinh";width = 20;fixed_width_font = false;}
}
: boxed_column {
	  label = "TRAC_DOC";
	  fixed_width = true;
	: popup_list {key = "td";label = "Ten coc - Ly trinh";width = 20;fixed_width_font = false;}
}
}
   : row {
        fixed_width = true;
        alignment = centered;
        : default_button {
       is_cancel  = true;
            label = "Tim";
            key = "btn_tim";
            width = 8;
        }
    : row {
        fixed_width = true;
        alignment = centered;
        : button {
       is_cancel  = true;
            label = "Thoat";
            key = "btn_thoat";
            width = 8;
        }
}


    }
}

đây là file thử nghiệm

http://www.cadviet.com/upfiles/3/66960_tdt_ok.rar


<<

Filename: 305114_timc.lsp
Tác giả: thanhduan2407
Bài viết gốc: 305124
Tên lệnh: bl2p
Đưa Block về point gần nhất

Của anh đây. Em đã sửa lại lisp của bác TOT77

(defun c:BL2P(/ os ss ss1 ss2 cd) 
  (defun layxy(a) (list (car a) (cadr a)))
  (defun leftL(L n / l1 i) (setq l1 nil i -1) (while (and (< (setq i (1+ i)) n) (nth i L)) (setq l1 (append l1 (list (nth i L))))))
  (defun doi (id tri v)   (entmod (subst (cons id tri) (assoc id (entget v)) (entget v))))
  (setq ss (ssget (list (cons 0 "INSERT,POINT"))))
(setq ss1 (vl-remove nil (mapcar...
>>

Của anh đây. Em đã sửa lại lisp của bác TOT77

(defun c:BL2P(/ os ss ss1 ss2 cd) 
  (defun layxy(a) (list (car a) (cadr a)))
  (defun leftL(L n / l1 i) (setq l1 nil i -1) (while (and (< (setq i (1+ i)) n) (nth i L)) (setq l1 (append l1 (list (nth i L))))))
  (defun doi (id tri v)   (entmod (subst (cons id tri) (assoc id (entget v)) (entget v))))
  (setq ss (ssget (list (cons 0 "INSERT,POINT"))))
(setq ss1 (vl-remove nil (mapcar '(lambda(x) (if (= (acet-dxf 0 (entget x)) "INSERT") (cons (layxy (acet-dxf 10 (entget x))) x) nil)) (acet-ss-to-list ss))))
(setq ss1 (vl-sort (vl-sort ss1 '(lambda(x y) (< (cadar x) (cadar y)))) '(lambda(x y) (< (caar x) (caar y)))))
(setq ss2 (vl-remove nil (mapcar '(lambda(x) (if (= (acet-dxf 0 (entget x)) "POINT") (layxy (acet-dxf 10 (entget x))) nil)) (acet-ss-to-list ss))))
(setq ss2 (vl-sort (vl-sort ss2 '(lambda(x y) (< (cadr x) (cadr y)))) '(lambda(x y) (< (car x) (car y)))))
  (foreach v ss1    
    (doi 10 (setq cd (car (vl-sort (leftL ss2 10) '(lambda(x y) (< (distance x (car v)) (distance y (car v))))))) (cdr v))
    (setq ss2 (vl-remove cd  ss2))
  )
)

<<

Filename: 305124_bl2p.lsp
Tác giả: mrphuocvie
Bài viết gốc: 305115
Tên lệnh: cte
Nhờ các anh chị giúp 1 đoạn LISP!

Các anh xem giúp em đoạn Lisp này xíu ah!

(defun C:CTE (/ etname  etlist  ettype  newtext
                 et2 etname2 etlist2 ettype2 oldtext)
  (while 
	(if (setq net (nentsel "\nSelect origin text!"))
		(setq
			etname (car net)
			etlist (entget etname)
			ettype (cdr (assoc 0 etlist))
			newtext (cdr (assoc 1 etlist))
		)
	)
	(if (= (substr newtext 1 4) "\\A1;")(setq newtext (vl-string-subst "" "\\A1;" newtext)))
	(if (= (substr...
>>

Các anh xem giúp em đoạn Lisp này xíu ah!

(defun C:CTE (/ etname  etlist  ettype  newtext
                 et2 etname2 etlist2 ettype2 oldtext)
  (while 
	(if (setq net (nentsel "\nSelect origin text!"))
		(setq
			etname (car net)
			etlist (entget etname)
			ettype (cdr (assoc 0 etlist))
			newtext (cdr (assoc 1 etlist))
		)
	)
	(if (= (substr newtext 1 4) "\\A1;")(setq newtext (vl-string-subst "" "\\A1;" newtext)))
	(if (= (substr newtext 1 4) "\\A1;")(setq newtext (vl-string-subst "" "\\A1;" newtext)))
	(if (= (substr newtext 1 4) "\\A1;")(setq newtext (vl-string-subst "" "\\A1;" newtext)))
	(if (= (substr newtext 1 4) "\\A1;")(setq newtext (vl-string-subst "" "\\A1;" newtext)))
	(if (= (substr newtext 1 4) "\\A1;")(setq newtext (vl-string-subst "" "\\A1;" newtext)))
	(if (or (= ettype "TEXT") (= ettype "ATTRIB") (= ettype "MTEXT") (= ettype "DIMENSION"))
		(setq et2 (entsel (strcat "\n" "String <" newtext "> will replace for each text you select!")))
		(setq
			etname2 (car et2)
			etlist2 (entget etname2)
			ettype2 (cdr (assoc 0 etlist2))
			oldtext (assoc 1 etlist2)
		)
		(if (or (= ettype2 "TEXT") (= ettype2 "ATTRIB") (= ettype2 "MTEXT") (= ettype2 "DIMENSION"))
			(progn
				(setq etlist2 (subst (cons 1 newtext) oldtext etlist2))
				(entmod etlist2)
				(entupd etname2)
				(if (setq etname2 (car (cadddr et2)))
				(entupd etname2)
				)
			)
			(prompt (strcat "\n<" ettype2 "> Not a text. Select again!"))
		)
    )
	(Command "ERASE" net)
  )
  (princ)
)

Mong muốn của em:

- Chọn đối tượng 1 (có chứa text)

- Chọn đối tượng 2 (có chứa text)

   Đoạn LISP có chức năng copy nội dung đối tượng 1 dán vào đối tượng 2 và xóa đối tượng 1.

   Vòng lặp đến khi "space" kết thúc lệnh.


<<

Filename: 305115_cte.lsp
Tác giả: nguyentuyen6
Bài viết gốc: 305142
Tên lệnh: cte
Nhờ các anh chị giúp 1 đoạn LISP!

 Sửa nhanh cho bạn

Các anh xem giúp em đoạn Lisp này xíu ah!

Mong muốn của em:

- Chọn đối tượng 1 (có chứa text)

- Chọn đối tượng 2 (có chứa text)

   Đoạn LISP có chức năng copy nội dung đối tượng 1 dán vào đối tượng 2 và xóa đối tượng 1.

   Vòng lặp đến khi "space" kết thúc lệnh.

(defun C:CTE (/ etname  etlist  ettype ...
>>

 Sửa nhanh cho bạn

Các anh xem giúp em đoạn Lisp này xíu ah!

Mong muốn của em:

- Chọn đối tượng 1 (có chứa text)

- Chọn đối tượng 2 (có chứa text)

   Đoạn LISP có chức năng copy nội dung đối tượng 1 dán vào đối tượng 2 và xóa đối tượng 1.

   Vòng lặp đến khi "space" kết thúc lệnh.

(defun C:CTE (/ etname  etlist  ettype  newtext
                 et2 etname2 etlist2 ettype2 oldtext net)
  (while
    (if (setq net (nentsel "\nSelect origin text! :"))
        (setq
            etname (car net)
            etlist (entget etname)
            ettype (cdr (assoc 0 etlist))
            newtext (cdr (assoc 1 etlist))
        )
    )
    (if (= (substr newtext 1 4) "\\A1;")(setq newtext (vl-string-subst "" "\\A1;" newtext)))
    (if (or (= ettype "TEXT") (= ettype "ATTRIB") (= ettype "MTEXT") (= ettype "DIMENSION"))
    (progn
        (setq et2 (entsel (strcat "\n" "String <" newtext "> will replace for each text you select!")))
        (setq
            etname2 (car et2)
            etlist2 (entget etname2)
            ettype2 (cdr (assoc 0 etlist2))
            oldtext (assoc 1 etlist2)
        )
                (setq etlist2 (subst (cons 1 newtext) oldtext etlist2))
                (entmod etlist2)
                (entupd etname2)
                (entdel etname)
    );progn
    )
  )
  (princ)
)

<<

Filename: 305142_cte.lsp
Tác giả: nguyentuyen6
Bài viết gốc: 305135
Tên lệnh: b2p
Đưa Block về point gần nhất

Bạn thanhduan viết rồi mà thôi kệ mình cứ post thử cái này. :D

 

(defun c:b2p(/ lst lstData lstB lstP p index kc)
	(and
	    (setq kc (getdist "\nKhoang cach toi da:" ));;;setq
	    (setq  ten_blk (cdr (assoc 8 (entget(car (entsel "\nChon block mau:"))))))
		(princ "\nChon vung thuc hien");;;princ
		(setq ss (ssget (list (cons 0 "INSERT,POINT"))))
		(setq lstData (acet-ss-to-list ss))
		(foreach e lstData (if (and (= (cdr (assoc 0...
>>

Bạn thanhduan viết rồi mà thôi kệ mình cứ post thử cái này. :D

 

(defun c:b2p(/ lst lstData lstB lstP p index kc)
	(and
	    (setq kc (getdist "\nKhoang cach toi da:" ));;;setq
	    (setq  ten_blk (cdr (assoc 8 (entget(car (entsel "\nChon block mau:"))))))
		(princ "\nChon vung thuc hien");;;princ
		(setq ss (ssget (list (cons 0 "INSERT,POINT"))))
		(setq lstData (acet-ss-to-list ss))
		(foreach e lstData (if (and (= (cdr (assoc 0 (entget e))) "INSERT")(= (cdr (assoc 8 (entget e))) ten_blk)) (setq lstB (cons e lstB)))
						   (if (= (cdr (assoc 0 (entget e))) "POINT") (setq lstP (cons e lstP)))
		)
	)
	;(princ lstP)
	(setq index 0)
	(while (< index (length lstB))
		(setq xx  (nth index lstB));;;setq
		(setq p (cdr (assoc 10 (entget xx))))
		(setq lstP (vl-sort lstP '(lambda(x y)(<= (distance (cdr (assoc 10 (entget x))) p)(distance (cdr (assoc 10 (entget y))) p)))))
		(if (< (distance (cdr (assoc 10 (entget (car lstP)))) p)  kc)
			(entmod (subst (cons 10 (cdr (assoc 10 (entget (car lstP))))) (assoc 10 (entget xx)) (entget xx))) ;;; if T
		)
		(setq index (1+ index))
	);;; end While 
)
;;;ketxu

<<

Filename: 305135_b2p.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 305167
Tên lệnh: timc
lisp tìm trắc ngang

bạn sửa xong check thấy oke thì up lisp hoàn chỉnh lên nhé, mình cũng đang cần lisp như này, thanks :)

Mình đã làm xong rồi (chỉ tìm trắc ngang) nhưng có mấy hàm chạy trong bộ lisp và còn muốn viết thêm mấy cái nữa 

Nếu bạn biết 1 tí về lisp thì sửa để chạy nhé

đây là lisp mới sửa...

>>

bạn sửa xong check thấy oke thì up lisp hoàn chỉnh lên nhé, mình cũng đang cần lisp như này, thanks :)

Mình đã làm xong rồi (chỉ tìm trắc ngang) nhưng có mấy hàm chạy trong bộ lisp và còn muốn viết thêm mấy cái nữa 

Nếu bạn biết 1 tí về lisp thì sửa để chạy nhé

đây là lisp mới sửa tối qua

(defun C:timc (/ datalist)
(defun sosanh (e1 e2 / p1 p2)
	(setq p1 (car e1)
		p2 (car e2)
	)
	(if (equal (cadr p1) (cadr p2) 1e-8)
		(< (car p1) (car p2))
		(> (cadr p1) (cadr p2))
	)
	)
(prompt "\nChon doi tuong coc hoac ly trinh lam lop chuan.")  
(setq dtltc (car (entsel)))
(setq lop1 (cdr (assoc 8 (entget dtltc))))
(setq danhsachc (acet-ss-to-list (ssget "X" (list (cons 8 lop1) (cons 1 "C*")))))
(setq danhsachkm (acet-ss-to-list (ssget "X" (list (cons 8 lop1) (cons 1 "K*")))))
(setq coc (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) danhsachc))
(setq km (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) danhsachkm))
(setq coc (vl-sort coc 'sosanh))
(setq km (vl-sort km 'sosanh))
(if (/= (length coc) (length km))
  (alert "Yeu cau so luong 'coc' & 'Ly trinh' phai bang nhau!")
  (progn
   (foreach ent1 coc
	(setq pt1 (car ent1))
	(setq dis (* 2 (distance pt1 (car (nth 0 km)))))
	(foreach ent2 km
	(setq pt2 (car ent2))
	(if (< (distance pt1 pt2) dis)
  	(setq dis (distance pt1 pt2) ent3 ent2)))
	(if (null datalist)
	(setq datalist (list (strcat (cdr ent1) "-" (cdr ent3))))
	(setq datalist (append datalist (list (strcat (cdr ent1) "-" (cdr ent3)))))
	))))
(setq numside (nth 0 datalist))
(setq DCL_ID (load_dialog (strcat odiachay "\\tlkt\\dcl\\Xuat_bang_tinh2.DCL")))
(new_dialog "Ha1" DCL_ID)
(start_list "tn")
(mapcar 'add_list datalist)
(end_list)
(set_tile "tn" (itoa (vl-position numside datalist)))
(action_tile "tn" "(setq numside (nth (atoi $value) datalist))")
(action_tile "btn_tim" "(done_dialog 1)")
(action_tile "btn_thoat" "(done_dialog 14)")
(setq phepchon (start_dialog))
(cond 
      ((= phepchon 1) (tim))
      ((= phepchon 14) (thoi))
 )
 (if (< 0 DCL_ID) (unload_dialog DCL_ID))
 	(princ)
  )
(defun tim ()
(vl-load-com)
(setq vitri (VL-STRING-POSITION 75 numside))
(setq kmtim (SUBSTR numside (+ vitri 1)))
(foreach ent2 km
(if (= (cdr ent2) kmtim)
(setq point (car ent2))
))
(command "ZOOM" "c" point 25)
)

đây là DCL

//-----
Ha1 : dialog {
	label = "TIM TRAC NGANG - TRAC DOC";
 : column {
  	  fixed_width = true;
        alignment = centered;
 	  width = 0;
 	: boxed_column {
	  label = "TRAC_NGANG";
	  fixed_width = true;
	: popup_list {key = "tn";label = "Ten coc - Ly trinh";width = 45;fixed_width_font = false;}
}
: boxed_column {
	  label = "TRAC_DOC";
	  fixed_width = true;
	: popup_list {key = "td";label = "Ten coc - Ly trinh";width = 45;fixed_width_font = false;}
}
}
   : row {
        fixed_width = true;
        alignment = centered;
        : default_button {
       is_cancel  = true;
            label = "Tim";
            key = "btn_tim";
            width = 8;
        }
    : row {
        fixed_width = true;
        alignment = centered;
        : button {
       is_cancel  = true;
            label = "Thoat";
            key = "btn_thoat";
            width = 8;
        }
}


    }
}

Bạn dùng thử cho ý kiếm


<<

Filename: 305167_timc.lsp
Tác giả: ketxu
Bài viết gốc: 305319
Tên lệnh: aps
Yêu cầu] Lisp chèn số/chữ trước và sau 1 text khác.
Mod post lại ^^
 
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/93259-hoi-ve-ham-trong-lisp/

;----- Add/Change Prefix and/or Suffix for DIMENSION, TEXT, MTEXT, ATTDEF. De tim hieu code >> nen mo trong Notepad++.
;----- Doan Van Ha - CadMagic - Ver.1: 15/9/2013
(vl-load-com)
(defun C:APS ( / dial flag lstobj lstkey lstvar fn Add_Prefix_Suffix SelectObj Ss->Lst Old_APS New_APS...
>>
Mod post lại ^^
 
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/93259-hoi-ve-ham-trong-lisp/

;----- Add/Change Prefix and/or Suffix for DIMENSION, TEXT, MTEXT, ATTDEF. De tim hieu code >> nen mo trong Notepad++.
;----- Doan Van Ha - CadMagic - Ver.1: 15/9/2013
(vl-load-com)
(defun C:APS ( / dial flag lstobj lstkey lstvar fn Add_Prefix_Suffix SelectObj Ss->Lst Old_APS New_APS HA:SetVal Make_File_Dcl)
;----- Sub Functions
 (defun Add_Prefix_Suffix (lst pre suf add);Add Prefix vµ/hoÆc Suffix cho lstobj.
  (command "undo" "be")
  (if (and lst pre suf)
   (mapcar
   '(lambda (obj / typ txt pre1 suf1)
     (setq typ (cdr (assoc 0 (entget (vlax-vla-object->ename obj)))))
     (cond
      ((wcmatch typ "MTEXT,TEXT") (vla-put-TextString obj (strcat pre (vla-get-TextString obj) suf)));MultiLeader ???
      ((wcmatch typ "ATTDEF") (vla-put-TagString obj (strcat pre (vla-get-TagString obj) suf)))
      ((wcmatch typ "DIMENSION")
  (setq txt (cdr (assoc 1 (entget (vlax-vla-object->ename obj)))) pre1 (vla-get-TextPrefix obj) suf1 (vla-get-TextSuffix obj))
       (cond
        ((and (= txt "") (= add "0")); Nguyen thuy hoac da add pre/suf: Change
(vla-put-TextPrefix obj pre) (vla-put-TextSuffix obj suf))
((and (= txt "") (= add "1")); Nguyen thuy hoac da add pre/suf: Add
(vla-put-TextPrefix obj (strcat pre pre1)) (vla-put-TextSuffix obj (strcat suf1 suf)))
     (T; Override: Add (not Change)
(vla-put-TextOverride obj (strcat pre txt suf))))))
     (vlax-release-object obj))
    lst))
  (command "undo" "e"))
 (defun SelectObj (lstvar lstkey / txt lst);Chän ®èi t­îng.
  (setq txt (apply 'strcat (mapcar '(lambda(var key) (if (= var "1") (strcat key ",") "")) (mapcar 'eval lstvar) lstkey)))
  (setq lst (Ss->Lst (ssget (list (cons 0 txt))) T)))
 (defun Ss->Lst (ss flag / lst);Convert selection set to list vla-object
  (and ss (setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
   (if flag (setq lst (mapcar 'vlax-ename->vla-object lst))))
  lst)
 (defun Old_APS();®Æt chÆ  ®é nh­ cÌ£.
  (setq text_old text mtext_old mtext attdef_old attdef dimension_old dimension pre_old pre suf_old suf add_old add change_old change))
 (defun New_APS();®Æt chÆ  ®é míi nh­ cÌ£".
  (setq text text_old mtext mtext_old attdef attdef_old dimension dimension_old pre pre_old suf suf_old add add_old change change_ols))
 (defun HA:SetVal (lstkey lstvar lstval);Set value_default or set value_old for var + Set_tile for key. EX: (HA:SetVal '("key1" "key2" "key3") '(var1 var2 var3) '("0" "1" "a"))
  (mapcar '(lambda (var val) (if (not (eval var)) (set var val))) lstvar lstval)
  (mapcar '(lambda (key val) (set_tile key (set (read key) val))) lstkey (mapcar 'eval lstvar)))
 (defun Make_File_Dcl ( / fn ow dial) 
  (setq fn (vl-filename-mktemp "APS" nil ".dcl"))
  (setq ow (open fn "w"))
  (mapcar
  '(lambda (x) (write-line x ow))
   (list
"APS : dialog { label = \"CadMagic - Add prefix and suffix for objects\";"
" : boxed_column { label = \"Set variable\";"
"    : row {"
"      : boxed_column { label = \"Dimension\";"
"        : toggle { label = \"Dimension\"; key = \"dimension\"; }"
"        : radio_row {"
"          : radio_button { label = \"Add\";  key = \"add\"; }"
"          : radio_button { label = \"Change\";  key = \"change\"; }"
"        }"
"      }"
"      : boxed_row { label = \"Text/Mtext/Attdef\";"
"        : toggle { label = \"Text\"; key = \"text\"; }"
"        : toggle { label = \"Mtext\"; key = \"mtext\"; }"
"        : toggle { label = \"Attdef\"; key = \"attdef\"; }"
"      }"
"    }"
"    : column {"
"      : edit_box { label = \"Prefix:\"; key = \"pre\"; edit_width = 45; }"
"      : edit_box { label = \"Suffix:\"; key = \"suf\"; edit_width = 45; }"
"    }"
": button { label = \"Select objects\"; key = \"chon\"; fixed_width = true; alignment = centered; }"
"  }"
"  ok_cancel;"
"}"))
  (close ow)
  fn)
;----- Main Function.
 (setq dial (load_dialog (setq fn (Make_File_Dcl))) flag 3)
 (while (> flag 1)
  (if (not (new_dialog "APS" dial)) (exit))
  (Old_APS)
  (HA:SetVal (setq lstkey '("text" "mtext" "attdef" "dimension" "pre" "suf" "add" "change"))
            (setq lstvar '(text mtext attdef dimension pre suf add change)) '("0" "0" "0" "0" "Prefix" "Suffix" "1" "0"))
  (action_tile "text" "(setq text $value)")
  (action_tile "mtext" "(setq mtext $value)")
  (action_tile "attdef" "(setq attdef $value)")
  (action_tile "dimension" "(setq dimension $value)")
  (action_tile "pre" "(setq pre $value)")
  (action_tile "suf" "(setq suf $value)")
  (action_tile "add" "(setq add $value change \"0\")")
  (action_tile "change" "(setq change $value add \"0\")")
  (action_tile "Cancel" "(done_dialog 0)")
  (action_tile "Accept" "(done_dialog 1)")
  (action_tile "chon" "(done_dialog 2)")
  (setq flag (start_dialog))
  (cond ((= 0 flag) (New_APS))
        ((= 2 flag) (setq lstobj (SelectObj lstvar lstkey)))
        ((= 1 flag) (Add_Prefix_Suffix lstobj pre suf add))))
 (unload_dialog dial) (vl-file-delete fn) (princ))
;--------------------------------------------------------------------------------------------------------------------------------------
 


<<

Filename: 305319_aps.lsp
Tác giả: TaiNguyen79
Bài viết gốc: 305281
Tên lệnh: trt
Xin lisp cắt ký tự trong text cad

Dung thử code này xem :

(defun c:trt (/ key pos k ss te text len kq)
(initget 1 "Left Right") (setq key (getkword "\n<L:Left> <R:Right> "))
(initget 7) (setq pos (getint "\nNhap 1 so nguyen : "))
(prompt "\n Chon cac chu de trim : ")(while (null (setq SS (ssget (list (cons 0 "Text"))))) (princ "\nChua chon duoc !"))
(setq k 0)
(repeat (sslength SS)
(setq te (entget (ssname SS k))) (setq text (cdr (assoc 1 te))) (setq len...
>>

Dung thử code này xem :

(defun c:trt (/ key pos k ss te text len kq)
(initget 1 "Left Right") (setq key (getkword "\n<L:Left> <R:Right> "))
(initget 7) (setq pos (getint "\nNhap 1 so nguyen : "))
(prompt "\n Chon cac chu de trim : ")(while (null (setq SS (ssget (list (cons 0 "Text"))))) (princ "\nChua chon duoc !"))
(setq k 0)
(repeat (sslength SS)
(setq te (entget (ssname SS k))) (setq text (cdr (assoc 1 te))) (setq len (strlen text))
(if (< pos len)
(progn
(if (eq key "Right") (setq kq (substr text 1 (- (strlen text) pos))) (setq kq (substr text (+ pos 1))))
(entmod (setq te (subst (cons 1 kq) (assoc 1 te) te)))))
(setq k (1+ k)))
(princ))

<<

Filename: 305281_trt.lsp
Tác giả: Tot77
Bài viết gốc: 305423
Tên lệnh: vov1 vov2
{Xin giup do] Viet autolisp nhu File Cad

Bạn thử cái này.

(defun ve(pt / p1 p2 p3 p4 n)
  (entmake (list (cons 0  "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline")
  (cons 90 4) (cons 70 1) (cons 62 1)
  (cons 10 (setq p1 (polar (polar pt pi (* 0.5 ng)) -1.5708 (* 0.5 du))))
  (cons 10 (setq p2 (polar p1 0 ng)))
  (cons 10 (setq p3 (polar p2 1.5708 du)))
  (cons 10 (setq p4 (polar p3 pi ng)))))
  (setq n 0)
  (repeat (1- song)
    (entmake (list (cons...
>>

Bạn thử cái này.

(defun ve(pt / p1 p2 p3 p4 n)
  (entmake (list (cons 0  "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline")
  (cons 90 4) (cons 70 1) (cons 62 1)
  (cons 10 (setq p1 (polar (polar pt pi (* 0.5 ng)) -1.5708 (* 0.5 du))))
  (cons 10 (setq p2 (polar p1 0 ng)))
  (cons 10 (setq p3 (polar p2 1.5708 du)))
  (cons 10 (setq p4 (polar p3 pi ng)))))
  (setq n 0)
  (repeat (1- song)
    (entmake (list (cons 0 "LINE") (cons 62 3)
  (cons 10 (polar p4 0 (* (setq n (1+ n)) d1)))
  (cons 11 (polar p1 0 (* n d1)))))
  )
  (setq n 0)
  (repeat (1- sodu)
    (entmake (list (cons 0 "LINE") (cons 62 3)
  (cons 10 (polar p1 1.5708 (* (setq n (1+ n)) d2)))
  (cons 11 (polar p2 1.5708 (* n d2)))))
  ) 
)
 
(defun c:vov1(/ ng du song sodu pt d1 d2)
  (setq ng (getreal "\nNgang: ")
du (getreal "\nDung: ")
song (getint "\nSo o ngang: ")
sodu (getint "\nSo o dung: ")
pt (getpoint "\nDiem: ")
d1 (/ ng song 1.0)
d2 (/ du sodu 1.0)
  ) (ve pt)
) 
 
(defun c:vov2(/ pt pt1 pt2 ng du song sodu d1 d2)
  (setq pt1 (getpoint "\nDiem1: ")
pt2 (getpoint "\nDiem2: ")
pt (polar pt1 (angle pt1 pt2) (* 0.5 (distance pt1 pt2)))
ng (abs (- (car pt2) (car pt1)))
du (abs (- (cadr pt2) (cadr pt1)))
song (getint "\nSo o ngang: ")
sodu (getint "\nSo o dung: ")
d1 (/ ng song 1.0)
d2 (/ du sodu 1.0)
  ) (ve pt)
) 

<<

Filename: 305423_vov1_vov2.lsp
Tác giả: Tot77
Bài viết gốc: 305450
Tên lệnh: vov1 vov2
{Xin giup do] Viet autolisp nhu File Cad

Vậy thì đây.

(defun ve(pt / p1 p2 p3 p4 n)
 (setq p1 (polar (polar pt pi (* 0.5 ng)) -1.5708 (* 0.5 du))
       p2 (polar p1 0 ng)
       p3 (polar p2 1.5708 du)
       p4 (polar p3 pi ng)
       n 0
  )
  (repeat (if (= 0 (rem ng song)) (1- (fix (/ ng song))) (fix (/ ng song)))
    (entmake (list (cons 0 "LINE") (cons 62 7)
  (cons 10 (polar p4 0 (* (setq n (1+ n)) song)))
  (cons 11 (polar p1 0 (* n song)))))
 ...
>>

Vậy thì đây.

(defun ve(pt / p1 p2 p3 p4 n)
 (setq p1 (polar (polar pt pi (* 0.5 ng)) -1.5708 (* 0.5 du))
       p2 (polar p1 0 ng)
       p3 (polar p2 1.5708 du)
       p4 (polar p3 pi ng)
       n 0
  )
  (repeat (if (= 0 (rem ng song)) (1- (fix (/ ng song))) (fix (/ ng song)))
    (entmake (list (cons 0 "LINE") (cons 62 7)
  (cons 10 (polar p4 0 (* (setq n (1+ n)) song)))
  (cons 11 (polar p1 0 (* n song)))))
  )
  (setq n 0)
  (repeat (if (= 0 (rem du sodu)) (1- (fix (/ du sodu))) (fix (/ du sodu)))
    (entmake (list (cons 0 "LINE") (cons 62 7)
  (cons 10 (polar p1 1.5708 (* (setq n (1+ n)) sodu)))
  (cons 11 (polar p2 1.5708 (* n sodu)))))
  )
  (princ)
)
 
(defun c:vov1(/ ng du song sodu pt)
  (setq ng (getreal "\nNgang: ")
du (getreal "\nDung: ")
song (getint "\nKT ngang o: ")
sodu (getint "\nKT dung o: ")
pt (getpoint "\nDiem: ")
  ) (ve pt)
) 
 
(defun c:vov2(/ pt pt1 pt2 ng du song sodu)
  (setq pt1 (getpoint "\nDiem1: ")
pt2 (getpoint "\nDiem2: ")
pt (polar pt1 (angle pt1 pt2) (* 0.5 (distance pt1 pt2)))
ng (abs (- (car pt2) (car pt1)))
du (abs (- (cadr pt2) (cadr pt1)))
song (getint "\nKT ngang o: ")
sodu (getint "\nKT dung o: ")
  ) (ve pt)
)
 

<<

Filename: 305450_vov1_vov2.lsp
Tác giả: mrphuocvie
Bài viết gốc: 305437
Tên lệnh: s10
Lisp stretch nhóm đối tượng 2 phía vào giữa và xung quanh vào tâm

Nhân tiện cho em hỏi xíu.

Em muốn strecth đối tượng vào cách 1 đối tượng khác luôn bằng 1 khoảng cách là 10. Và em cũng đã viết thử 1 đoạn lisp mà không hiểu sao nó không chạy được.

Thao tác:

- Chọn đối tượng,

- Chọn điểm đầu

- Chọn điểm cuối.

LISP sẽ thực hiện lệnh strecth đối tượng được chọn theo phương (p1 p2) và cách điểm p2 1 khoảng bằng...

>>

Nhân tiện cho em hỏi xíu.

Em muốn strecth đối tượng vào cách 1 đối tượng khác luôn bằng 1 khoảng cách là 10. Và em cũng đã viết thử 1 đoạn lisp mà không hiểu sao nó không chạy được.

Thao tác:

- Chọn đối tượng,

- Chọn điểm đầu

- Chọn điểm cuối.

LISP sẽ thực hiện lệnh strecth đối tượng được chọn theo phương (p1 p2) và cách điểm p2 1 khoảng bằng khoảng cách 2 điểm p1 p2 trừ 10

(defun c:s10 ()
	(setq ss1 (ssget))
	(setq P1 (getpoint "\nDiem dau : "))
	(setq P2 (getpoint p1 "\nDiem cuoi : "))
	(setq dt (- (distance P1 P2) 10))
	(command "stretch" ss1 p1 dt)
)

<<

Filename: 305437_s10.lsp

Trang 166/330

166