Jump to content
InfoFile
Tác giả: 790312
Bài viết gốc: 69280
Tên lệnh: scdo
Hỏi về chỉnh kích thước hình tròn vẽ bằng lệnh donut
góp ý với 790312 : Bạn không nên post bài của bạn vào 2 chủ đề khác nhau

Đây là code Tue_NV đã chỉnh lại. Hy vọng bạn hài lòng.

Bạn sử dụng thử và cho ý kiến...

>>
góp ý với 790312 : Bạn không nên post bài của bạn vào 2 chủ đề khác nhau

Đây là code Tue_NV đã chỉnh lại. Hy vọng bạn hài lòng.

Bạn sử dụng thử và cho ý kiến nhé :

(defun c:scdo()
(vl-load-com)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq ss (ssget '((0 . "*POLYLINE"))) i 0)
(setq tle (getdist "\n Nhap he so ti le : "))

(while (< i (sslength ss))
(setq ent (ssname ss i))

(if (= (cdr(assoc 0 (entget ent))) "POLYLINE")
(progn
(setq diem1 (cdr (assoc 10 (entget (entnext ent)))))
(setq diem2 (cdr (assoc 10 (entget(entnext (entnext ent))))))

(setq po (list (/ (+ (car diem1) (car diem2)) 2) (/ (+ (cadr diem1) (cadr diem2)) 2) 0))
)
)

(if (= (cdr(assoc 0 (entget ent))) "LWPOLYLINE")
(progn
(setq ddau (vlax-curve-getStartPoint ent))
(setq diem (vlax-curve-getPointAtParam ent 1))
(setq po (list (/ (+ (car ddau) (car diem)) 2) (/ (+ (cadr ddau) (cadr diem)) 2) 0))
)
)
(command "scale" ent "" po tle)
(setq i (1+ i))
)
(setvar "osmode" oldos)
(command "undo" "end")
(princ)
)

Chân thành cảm ơn sự nhiệt tình của bạn.Cảm ơn diễn đàn.


<<

Filename: 69280_scdo.lsp
Tác giả: almodeus
Bài viết gốc: 129931
Tên lệnh: lsw
Cần Lisp ngược với lệnh Layiso

Nếu bạn để chế độ Layiso là Off thì đoạn code sau sẽ toggle trạng thái :

(defun c:lsw (/)
 (vlax-map-collection
  ...
>>

Nếu bạn để chế độ Layiso là Off thì đoạn code sau sẽ toggle trạng thái :

(defun c:lsw (/)
 (vlax-map-collection
   (vla-get-layers
     (vla-get-activedocument (vlax-get-acad-object))
    )
   '(lambda (x)
      	(if (= (vla-get-layeron x) :vlax-false) (vla-put-layeron x :vlax-true) (vla-put-layeron x :vlax-false))		
	)
  )
  )

Còn nếu bạn để chế độ Fade Out thì đọc mấy dòng tiếp theo này ^^

@lispser : Với chế độ Fade Out, Cad sẽ lock layer thay vì Off nó.Nhưng khi un-lock (un-fade) thì độ mờ của layer không thay đổi được ngay, mà phải regen đôi lần, điều này khá cấm kỵ, có ai có giải pháp gì không ạ ?

Không được bạn ketxu ah, sau khi sài lệnh thì toàn bộ bị ẩn đi hết luôn...hix...mình cần lisp đảo ngược thuộc tính của đối tượng layiso thôi...để khi cần layiso nhiều layer sẽ đỡ mệt


<<

Filename: 129931_lsw.lsp
Tác giả: vqhnb
Bài viết gốc: 72653
Tên lệnh: cong tru nhan chia
Viết lisp theo yêu cầu [phần 2]
Mình đã nhiều lần gặp trường hợp như bạn trong công việc. đây là lisp mình tìm được trên diễn đàn này. mình đã sửa lại 1 chút để bạn có thể sử dụng...
>>
Mình đã nhiều lần gặp trường hợp như bạn trong công việc. đây là lisp mình tìm được trên diễn đàn này. mình đã sửa lại 1 chút để bạn có thể sử dụng được cả 4 phép tính. Nó có tác dụng cộng, hoặc trừ, hoặc nhân, hoặc chia tất cả các text số mà bạn chọn với một số mà bạn nhập vào.

lệnh là: cong; tru; nhan; chia.

(defun c:cong()
(setq i 0 s1 0)
(setq n (getreal "\nnhap so muon cong them: "))
 (prompt "\nchon cac so can sua ...")
(setq txt (ssget '((0 . "TEXT"))))
	(repeat (sslength txt)
	(setq txt_name (ssname txt i))
  	(setq txt_ent (entget txt_name))
	(setq cont (cdr(assoc 1 txt_ent)))
	(setq cont (atof cont))
	(setq s (+ cont n))	  
  (setq txt_ent  (subst (cons 1 (rtos s)) (assoc 1 txt_ent) txt_ent))
	(entmod txt_ent)
	(setq i (+ i 1))
);repeat
);defun	
;------------------------------------------------------
(defun c:tru()
(setq i 0 s1 0)
(setq n (getreal "\nnhap so tru: "))
 (prompt "\nchon cac so can sua ...")
(setq txt (ssget '((0 . "TEXT"))))
	(repeat (sslength txt)
	(setq txt_name (ssname txt i))
  	(setq txt_ent (entget txt_name))
	(setq cont (cdr(assoc 1 txt_ent)))
	(setq cont (atof cont))
	(setq s (- cont n))	  
  (setq txt_ent  (subst (cons 1 (rtos s)) (assoc 1 txt_ent) txt_ent))
	(entmod txt_ent)
	(setq i (+ i 1))
);repeat
);defun	
;------------------------------------------------------
(defun c:nhan()
(setq i 0 s1 0)
(setq n (getreal "\nnhap so muon nhan: "))
 (prompt "\nchon cac so can sua ...")
(setq txt (ssget '((0 . "TEXT"))))
	(repeat (sslength txt)
	(setq txt_name (ssname txt i))
  	(setq txt_ent (entget txt_name))
	(setq cont (cdr(assoc 1 txt_ent)))
	(setq cont (atof cont))
	(setq s (* cont n))	  
  (setq txt_ent  (subst (cons 1 (rtos s)) (assoc 1 txt_ent) txt_ent))
	(entmod txt_ent)
	(setq i (+ i 1))
);repeat
);defun	
;------------------------------------------------------
(defun c:chia()
(setq i 0 s1 0)
(setq n (getreal "\nnhap mau so: "))
 (prompt "\nchon cac so can sua ...")
(setq txt (ssget '((0 . "TEXT"))))
	(repeat (sslength txt)
	(setq txt_name (ssname txt i))
  	(setq txt_ent (entget txt_name))
	(setq cont (cdr(assoc 1 txt_ent)))
	(setq cont (atof cont))
	(setq s (/ cont n))	  
  (setq txt_ent  (subst (cons 1 (rtos s)) (assoc 1 txt_ent) txt_ent))
	(entmod txt_ent)
	(setq i (+ i 1))
);repeat
);defun	
;------------------------------------------------------

Chú ý là kết quả tính toán sẽ lấy số chữ số sau dấu phẩy theo Precision trong định dạng Units bản vẽ của bạn. Với text cao độ thường lấy 2 chữ số sau dấu phẩy. bạn nên thiết lập lại Precision trước khi chạy thực hiện lệnh.

Bác Thaistreetz là ks giao thông ạ. lisp đúng ý tớ cảm ơn bác, mong được học hỏi bác nhiều hơn nữa, cám ơn bác nhé, cám ơn sự nhiệt tình của các thành viên trong diễn đàn. Thanhs


<<

Filename: 72653_cong_tru_nhan_chia.lsp
Tác giả: gia_bach
Bài viết gốc: 90379
Tên lệnh: gpmb
LISP GPMB
.....................

(DEFUN C:gpmb(/ TH SS Index Lst LenEn I J Pt1 Pt2 PlineLeft PlineRight GPMBL GPMBR ChanTrai ChanPhai PtMid PtLine S Now)  
 (ACET-ERROR-INIT (LIST (LIST ...
>>
.....................

(DEFUN C:gpmb(/ TH SS Index Lst LenEn I J Pt1 Pt2 PlineLeft PlineRight GPMBL GPMBR ChanTrai ChanPhai PtMid PtLine S Now)  
 (ACET-ERROR-INIT (LIST (LIST  "OSMODE" 0 "CLAYER" "DIM" "CMDECHO" 0) T))
 (setq TH (getstring "\nChọn trường hợp: "))
 (setq s (getvar "DATE"))
 (setq Now (* 86400.0 (- s (fix s))))
 .................................
 (setq s (getvar "DATE"))
 (alert (strcat "Tổng thời gian thực hiện là:" (rtos (- (* 86400.0 (- s (fix s))) Now )) " giây."))
 (acet-error-restore)
)

Góp ý với bạn :

1- truớc khi dùng hàm : ACET-ERROR-INIT, acet-error-restore cần kiểm tra xem CAD có cài EXPRESS hay không?

nếu chưa cài sẽ báo lỗi.

2- Cad có biến hệ thống MILLISECS trả về thời gian của hệ thống - đơn vị mili giây

 

Có thể thay đoạn tính thời gian thưc hiện

(setq s (getvar "DATE"))

(setq Now (* 86400.0 (- s (fix s))))

.............

(setq s (getvar "DATE"))

(alert (strcat "Tổng thời gian thực hiện là:" (rtos (- (* 86400.0 (- s (fix s))) Now )) " giây."))

bằng :

 

(setq time (getvar "MILLISECS"))

.............

(princ (strcat "\nTong thoi gian thuc hien : " (rtos(/ (- (getvar "MILLISECS") time) 1000.0)) " giay."))


<<

Filename: 90379_gpmb.lsp
Tác giả: phamngoctukts
Bài viết gốc: 133850
Tên lệnh: demc
Cách thống kê số lượng circle

cám ơn bạn nhưng ko hiểu sao lisp của bạn chọn toàn sai số lượng.

bạn thử check lại giúp mình...

>>

cám ơn bạn nhưng ko hiểu sao lisp của bạn chọn toàn sai số lượng.

bạn thử check lại giúp mình xem

Xin lỗi mình thiếu 1 điều kiện lọc.

(defun c:demc()
 (setq ra (cdr (assoc 40 (entget (car (entsel "Chon duong chon can thong ke:")))))
ci (ssget "x" (list (cons 0 "CIRCLE") (cons 40 ra)))
kq (sslength ci)
)
 (princ (strcat "\nTong so duong tron co duong kinh: " (rtos ra 2 2) " la " (rtos kq 2 0) " cai"))
 )


<<

Filename: 133850_demc.lsp
Tác giả: hungtrangt
Bài viết gốc: 409293
Tên lệnh: ddm
nhờ viết lisp vẽ thêm đường đồng mức phụ

 

Đây bạn, nhưng nó chỉ làm với 2 poly hình dạng gần giống nhau thôi, còn dạng như yên ngựa thì chạy không đúng.

>>

 

Đây bạn, nhưng nó chỉ làm với 2 poly hình dạng gần giống nhau thôi, còn dạng như yên ngựa thì chạy không đúng.

(defun c:ddm (/ ss dd dn lst d1 dis n)  
 
  (defun laydinh (en / l)
    (setq l nil)
    (if (= (cdr (assoc 70 (entget en))) 5) (setq tn t) (setq tn nil))
    (while (not (equal (cdr (assoc 0 (entget (setq en (entnext en))))) "SEQEND"))
      (setq l (cons (cdr (assoc 10 (entget en))) l)))
    (if tn (setq l (cons (last l) l)))
    (reverse l)
  )
  
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "POLYLINE")))))))
  (if (not sokhoang) (setq sokhoang (getint "\nSo khoang chia:")))
  (setq dd (car (vl-sort ss '(lambda (x y) (> (vlax-curve-getDistAtParam x (vlax-curve-getEndParam x))
     (vlax-curve-getDistAtParam y (vlax-curve-getEndParam y))))))
dn (car (vl-remove dd ss))
dd (laydinh dd)
lst nil
  )
  (repeat (1- sokhoang) (setq lst (cons '() lst)))
 
  (foreach d0 dd 
    (setq d1 (vlax-curve-getclosestpointto dn d0)
 dis (/ (distance d0 d1) sokhoang)
          n 0)    
    (setq lst (mapcar '(lambda (x) (append x (list (polar d0 (angle d0 d1) (* (setq n (1+ n)) dis))))) lst)) 
  )
  (command "undo" "be")
  (foreach v lst
    (entmake '((0 . "POLYLINE") (66 . 1)) )
    (foreach v1 v (entmake (list '(0 . "VERTEX") (cons 10 v1))))
    (entmake '((0 . "SEQEND")))       
  )
  (command "undo" "e") (princ)      
)

Sao em ap rồi mà lip ko chạy được nữa vậy ạ


<<

Filename: 409293_ddm.lsp
Tác giả: tacongthang
Bài viết gốc: 110427
Tên lệnh: layer on layer off
Ứng dụng REACTOR trong quản lý bản vẽ theo layer.
Ứng dụng REACTOR trong quản lý bản vẽ theo layer.

 

Trong truờng hợp quản lý bản vẽ theo layer, thông thuờng các...

>>
Ứng dụng REACTOR trong quản lý bản vẽ theo layer.

 

Trong truờng hợp quản lý bản vẽ theo layer, thông thuờng các đối tuợng khác nhau sẽ thuộc các layer khác nhau (có ngoại lệ).

VD : đối tuợng LINE thuộc layer “LINE”, đối tuợng Text thuộc layer “TEXT”, đối tuợng Dimension (kích thuớc) thuộc layer “DIMENSION”, ...

Cách vẽ thông thuờng là :

1. vẽ đối tuợng truớc, sau đó mới tạo layer rồi chuyển đối tuợng qua layer đó.

2. cách thứ 2 là tạo hàng loạt layer theo qui định, sau đó truớc khi vẽ đối tuợng sẽ set layer tuơng ứng về hiện hành. Vd : vẽ đối tuợng LINE thì set layer “LINE” về hiện hành.

 

Cách vẽ thứ 1 có lợi điểm là không cần quan tâm đến layer hiện hành, sau khi hoàn thành có thể sử dụng lệnh FILTER hay LISP để lọc các kiểu đối tuợng rồi chuyển qua layer tuơng ứng.

Cách vẽ thứ 2 có vẻ rắc rối hơn vì mỗi lần vào lệnh CAD lại phải thay đổi layer tuơng ứng về hiện hành.

Do đó phát sinh nhu cầu : làm thế nào để mỗi khi tạo đối tuợng mới, CAD “hiểu đuợc” chúng ta muốn đặt đối tuợng đó vào Layer tuơng ứng? (không cần thiết phải qua buớc set layer)

Truớc đây tôi có viết 1 lisp sử dụng biến hệ thống "CMDACTIVE", nhưng quả thật trong các t/hợp các lệnh có liên quan đến hộp thoại “vấn đề chưa đuợc giải quyết rốt ráo”.

Link tham khảo

 

Rất may là các lệnh REACTOR (hàm VLR-***) có cung cấp cho chúng ta cách giải quyết vấn đề.

Các bạn có thể tham khảo thêm trong “tàng kinh” của VisualLisp.

Cụ thể là : (vlr-command-reactor data callbacks) cho phép xây dựng các hành động tuơng ứng với các khả năng có thể xảy ra (tạm gọi là sự kiện) khi gọi 1 lệnh CAD.

Một vài sự kiện khi gọi 1 lệnh CAD :

- sự kiện bắt đầu gọi lệnh : :vlr-commandWillStart

- sự kiện khi lệnh kết thúc: :vlr-commandEnded

- sự kiện hủy bỏ lệnh : :vlr-commandCancelled

 

Như vậy đối với truờng hợp muốn Cad “hiểu đuợc” Layer tuơng ứng với mỗi lệnh, chúng ta phải xây dựng các hàm :

- đáp ứng sự kiện bắt đầu gọi lệnh ":vlr-commandWillStart

- đáp ứng sự kiện khi lệnh kết thúc “:vlr-commandEnded”

- đáp ứng sự kiện khi hủy bỏ lệnh “:vlr-commandEnded”

- tạo 1 danh sách các lệnh và layer tưong úng .

 

VD: khi gọi lệnh LINE, CAD sẽ kiểm tra xem layer hiện hành có phải là “LINE” không ?

- Nếu đúng → kết thúc

- Nếu sai → chuyển layer “LINE” về hiện hành (nếu chưa có : tao mới layer)

Tuơng tự cho các sự kiện khi kết thúc lệnh LINE hay sự kiện khi hủy bỏ lệnh (nguời dùng nhấn phím Cancel)

 

Chú ý :

- vì mỗi nguời (cty) có qui định về Layer khác nhau nên cần phải có 1 buớc hiệu chỉnh cho phù hợp.

Cụ thể là tìm dòng (setq COMLAYLST (list

(list "DIMANGULAR" "KT-DIM" )

(list "DTEXT" "TEXT" )

….....................

; Add your own command layer lists here....

))

thay thế hay bổ sung-xóa các cặp danh sách tuơng ứng theo định dạng (list "tênLệnhCadViếtHoa" "tênLayer" ).

VD : thay dòng (list "DTEXT" "TEXT" ) bằng (list "DTEXT" "ChuSo" )

hay thêm (list "LINE" "DuongThang" )

(setq COMLAYLST (list

(list "DIMANGULAR" "KT-DIM" )

(list "DTEXT" "ChuSo" ) (list "LINE" "DuongThang" )

))

- để tắt Reactor gọi lệnh Layer_Off, bật Reactor lại gọi lệnh Layer_On

- trong t/hợp Layer tuơng ứng ở tình trạng : Lock, Freeze, Thaw kết quả còn bị lỗi. <_<

Duới đây là toàn bộ code của Ứng dụng REACTOR trong quản lý bản vẽ theo layer.

(vl-load-com)
(defun StartCommand (CALL CALLBACK / COMLAYLST)
 (setq COMLAYLST (list
	    (list "DIMANGULAR" "KT-DIM" )
	    (list "DIMALIGNED" "KT-DIM" )
	    (list "DIMBASELINE" "KT-DIM" )
	    (list "DIMCENTER" "KT-DIM"  )
	    (list "DIMCONTINUE" "KT-DIM" )
	    (list "DIMDIAMETER" "KT-DIM")
	    (list "DIMLINEAR" "KT-DIM")
	    (list "DIMRADIUS" "KT-DIM" )
	    (list "QDIM" "KT-DIM" )
	    (list "LEADER" "KT-DIM" )
	    (list "TEXT" "TEXT" )
	    (list "MTEXT" "TEXT" )
	    (list "DTEXT" "TEXT" )
                   ; Add your own command layer lists here....
	    ))
 (if (setq N (assoc (strcase (car CALLBACK)) COMLAYLST))
   (progn
     (setq *Currentlayers* (cons (getvar "CLAYER") *Currentlayers*))
     (if (setq objLay(make_layers (cadr N) ))
(vla-put-activelayer *DOC* objLay  )    )    )
   (setq *Currentlayers* (cons nil *Currentlayers*))  )
 (princ)  )

(defun MAKE_LAYERS (LAY_NAM / LAYOBJ LAYSOBJ ) 
 (or *DOC* (setq *DOC* (vla-get-activedocument (vlax-get-acad-object))))
 (setq LAYSOBJ (vla-get-layers *DOC*))
 (if (tblobjname "layer" LAY_NAM)
   (setq LAYOBJ (vla-item LAYSOBJ LAY_NAM))
   (setq LAYOBJ (vl-catch-all-apply 'vla-add (list LAYSOBJ LAY_NAM)))  )
 (if (vl-catch-all-error-p LAYOBJ)
   (not (print (vl-catch-all-error-message LAYOBJ)))
   (progn
     (if (= (strcase (vla-get-name LAYOBJ)) (strcase (getvar "clayer")))
       (setvar "clayer" "0")      )
     (vla-put-lock LAYOBJ :vlax-false)
     (vla-put-layeron LAYOBJ :vlax-true)
     (vla-put-freeze LAYOBJ :vlax-false)      	
     LAYOBJ  )  ))

(defun endCommand (CALL CALLBACK)
 (if *Currentlayers*
   (if (car *Currentlayers*)
     (progn
       (vla-put-lock
         (vla-item
           (vla-get-layers *DOC*)
           (car *Currentlayers*)  )
         :vlax-false        )
       (setvar "CLAYER" (car *Currentlayers*)) ) ) )
 (setq *Currentlayers* (cdr *Currentlayers*)))

(defun cancelCommand (CALL CALLBACK)
 (if *Currentlayers*
   (if (car *Currentlayers*)
     (progn
       (vla-put-lock
         (vla-item
           (vla-get-layers *DOC*)
           (car *Currentlayers*)  )
         :vlax-false        )
       (setvar "CLAYER" (car *Currentlayers*)) ) ) )
 (setq *Currentlayers* (cdr *Currentlayers*)))

(defun C:Layer_On ()  
 (and *vlr-CWS (not (vlr-added-p *vlr-CWS)) (vlr-add *vlr-CWS))
 (and *vlr-CE (not (vlr-added-p *vlr-CE)) (vlr-add *vlr-CE))
 (and *vlr-CC (not (vlr-added-p *vlr-CC)) (vlr-add *vlr-CC))
 (or *vlr-CWS 
    (setq *vlr-CWS (vlr-command-reactor nil '((:vlr-commandwillstart . StartCommand)))))
 (or *vlr-CE
    (setq *vlr-CE (vlr-command-reactor nil '((:vlr-commandEnded . endCommand)))))
 (or *vlr-CC
    (setq *vlr-CC (vlr-command-reactor nil '((:vlr-commandCancelled . cancelCommand)))))
 (princ "\nLayer Reactor ON")
 (princ))
(c:Layer_On)

(defun C:Layer_Off ()
 (and *vlr-CWS (vlr-added-p *vlr-CWS) (vlr-remove *vlr-CWS))
 (and *vlr-CE (vlr-added-p *vlr-CE) (vlr-remove *vlr-CE))
 (and *vlr-CC (vlr-added-p *vlr-CC) (vlr-remove *vlr-CC))
 (princ "\nLayer Reactor OFF")
 (princ))

 

cái này ban đầu không hiểu gì, giờ ứng dụng kết hợp với quét layer nên việc vẽ nhanh hơn trước đây nhiều lắm. cái này diễn đàn phải cho nhấn nút thanks nhiều lần nhấn mới sướng.


<<

Filename: 110427_layer_on_layer_off.lsp
Tác giả: alpha1810
Bài viết gốc: 166468
Tên lệnh: cc
Lisp xuất chiều dài Line ra Text có sẵn và có tiền tố, hậu tố

Của anh đây ạ :

(defun c:cc (/ doituong total dtuong1 tdt dt ktext ktratext ktratext1 ktextcu textdt ktextmoi newcolor oldcolor)
  (setq...
>>

Của anh đây ạ :

(defun c:cc (/ doituong total dtuong1 tdt dt ktext ktratext ktratext1 ktextcu textdt ktextmoi newcolor oldcolor)
  (setq doituong (ssget '((0 . "*POLYLINE"))))
  (setq total (sslength doituong))
  (setq tdt 0)
  (repeat total
        (setq total (- total 1))
        (setq dtuong1 (cdr (car (entget (ssname doituong total)))))
        (command "area" "e" dtuong1)
        (setq dt (getvar "Perimeter"))
        (setq tdt (+ tdt dt))
  )
  (setq ktext (car (entsel "chi vµo text cЗn ghi: ")))
  (setq ktratext (entget ktext))
  (setq ktratext1 (cdr (assoc 0 ktratext)))
  (if (= ktratext1 "TEXT")
      (progn
              (setq ktextcu (assoc 1 ktratext))
              (setq textdt (strcat "L= " (rtos (- tdt 0) 2 2) " m"))
              (setq ktextmoi (cons 1 textdt))
              (setq ktratext (subst ktextmoi ktextcu ktratext))
              (entmod ktratext)
              (setq color 4)
              (setq newcolor (cons 62 color))
                 (if (assoc 62 ktratext)
                     (progn
                          (setq oldcolor (assoc 62 ktratext))
                          (setq ktratext (subst newcolor oldcolor ktratext))
                          (entmod ktratext)
                     )
                     (entmod (append ktratext (list (cons 62 color))))
                  )
       )
       (alert "¤i trкi ¬i, chдn nhЗm rеi, ®г kh«ng ph¶i lµ tetx!")
  )
 (textpage)
 (graphscr)
)

 

Nhân tiện cho em hỏi là biến nào lưu giữ đơn vị hiện hành của CAD ạ ?

 

sao minh dung nó toàn báo lỗi vậy ban:

Select objects: 1 found

1 was filtered out.

; error: bad argument type: lselsetp nil

Command:


<<

Filename: 166468_cc.lsp
Tác giả: AutoTay.com
Bài viết gốc: 174416
Tên lệnh: taluy
viết giúp em cái lisp rải mái taluy

Bạn nào .....

 

 

 

thì vào đây nhé. Hehe

 

(defun c:taluy (/)  (setvar "CMDECHO" 0) ...
>>

Bạn nào .....

 

 

 

thì vào đây nhé. Hehe

 

(defun c:taluy (/)  (setvar "CMDECHO" 0)  (setq osmode (getvar "osmode"))  (setvar "osmode" 0)  (setvar "unitmode" 0)  (setvar "dimzin" 0)  (setvar "blipmode" 0)  (setvar "aunits" 0)  (setvar "angbase" (/ pi 2))  (setvar "angdir" 1)  (if (not (tblsearch "layer" "BATTER"))    (command "layer" "n" "BATTER" "color" "8" "BATTER" "s" "BATTER" \n)    (command "layer" "s" "BATTER" \n)  )  (if (not lint)    (setq lint 10.0)  )  (setq	int (getdist (strcat "\nNhap khoang cach chia taluy <"		         (rtos lint 2 3)		         ">: "	         )    	)  )  (if int    (setq lint int)    (setq int lint)  )  (command "line" (list 0.0 0.0) (list 0.0 0.0001) "")  (if (tblsearch "block" "tadtick")    (command "block" "tadtick" "y" (list 0.0 0.0) (entlast) "")    (command "block" "tadtick" (list 0.0 0.0) (entlast) "")  )  (while (setq refent (entsel "\nChon doi tuong can rai taluy : "))    (command "undo" "group")    (redraw (car refent) 3)    (initget 1 "daO daP")    (setq      reply (getkword "\nChon kieu taluy Nen Da hay Nen Da: ")    )    (print "\n")    (print "Chon cac doi tuong can batter :")    (setq s (ssget))    (command "measure" refent "b" "tadtick" "y" int)    (setq p  (ssget "p")  	cn 0    )    (if	s      (progn	(while (< cn (sslength p))(setq en (entget (ssname p cn))p0 (cdr (assoc 10 en))pt1 p0pt2 nilb (cdr (assoc 50 en)))(entdel (ssname p cn))(setq p1 (polar p0 (+ (/ pi 2) b ) 0.0001))  	(command "line" p0 p1 "")  	(command "extend" s "" (list (entlast) p1) "")  	(setq xent (entget (entlast)))  	(setq	xdist	     (distance (cdr (assoc 10 xent)) (cdr (assoc 11 xent)))  	)  	(if (not (equal xdist 0.0001 0.0001))    	(setq pt2 (cdr (assoc 11 xent)))    	(progn      	(command "extend" s "" (list (entlast) p0) "")      	(setq xent (entget (entlast)))      	(setq xdist (distance (cdr (assoc 10 xent))			    	(cdr (assoc 11 xent))		  	)      	)      	(if (not (equal xdist 0.0001 0.0001))		(setq pt2 (cdr (assoc 10 xent)))      	)    	)  	)  	(entdel (entlast))  	(if pt2    	(if	(= reply "daP")      	(if (= (rem cn 2) 0)		(command "line" pt1 pt2 "")		(command	  	"line"	  	pt1	  	(polar pt1 (angle pt1 pt2) (/ (distance pt1 pt2) 2))	  	""		)      	)      	(if (= (rem cn 2) 0)		(command "line" pt2 pt1 "")		(command	  	"line"	  	pt2	  	(polar pt2 (angle pt2 pt1) (/ (distance pt2 pt1) 2))	  	""		)      	)    	)  	)  	(setq cn (1+ cn))	)      )    )    (command "undo" "en")  )  (setvar "blipmode" 1)  (setvar "osmode" osmode)  (princ))

 

 

Bon...on...n

Come on!

Không hiểu sao khi dùng lisp này em rất hay gặp lỗi. Quá trình chạy lisp thì vẫn bình thường nhưng kết quả thu được là 1 mớ các Line dài loằng ngoằng nằm tận đẩu đâu. Đôi lúc với trường hợp chân và đỉnh taluy là các Pline gấp khúc thì lại gặp phải lỗi các Line không nối hết khoảng trống giữa 2 Line chân và đỉnh taluy.

Nhưng nếu Copy bản vẽ sang bản vẽ mới thì lại rải được bình thường, cũng có lúc làm mọi cách vẫn không được, kể cả thử trên bản vẽ mới hoàn toàn! Nói chung là rất bực mình! :huh: :huh: :huh:

Mong các bác giúp đỡ!

Thankssssssssssssssssssss!


<<

Filename: 174416_taluy.lsp
Tác giả: hoangkimoanh
Bài viết gốc: 243494
Tên lệnh: dm
Lisp thay đổi màu layer

 

-Lisp trên chỉ thay đổi màu của layer chứa đối tượng bạn chọn chứ ko phải "hết tất cả layer về cùng một...

>>

 

-Lisp trên chỉ thay đổi màu của layer chứa đối tượng bạn chọn chứ ko phải "hết tất cả layer về cùng một màu".

-Bạn muốn "những đối tượng mình chọn mới thay đổi thành màu khác" nghĩa là thay màu của đối tượng ko còn là bylayer nửa phải ko?

*Nếu vậy thì dùng này:

(defun c:dm (/ m ss)
(command "undo" "be")
  (princ "\nChon doi tuong muon doi mau:")
  (setq ss (ssget))
  (princ "\nChon mau muon doi :")(setq m (acad_colordlg 7))
(command "change" ss "" "P" "c" m "")
(command "undo" "end")
(setvar "MODEMACRO" "**KTS_DUY**")
(princ)
)


Tôi đã xoá các bài của kexu và thanhdatkts đề nghị tập trung vào chuyên môn.

@thanhdatkts: đề nghị chồng cho tôi 1 dấu + nếu không tôi chồng cho bạn 1 dấu trừ đấy! tongue.gif

nhờ các anh sửa giúp em để khi gõ lệnh => Pick chọn đối tượng (theo Layer) => thì tất cả các đối tượng thuộc Layer đó sẽ chuyển thành màu số 4 (Cyan).

cảm ơn các anh!


<<

Filename: 243494_dm.lsp
Tác giả: hoangkimanh1607
Bài viết gốc: 211491
Tên lệnh: chm chd cdlt cvt3d
Xin lisp nội suy cao độ ?

Đã chỉnh sửa lại theo yêu cầu của bạn. Tuy nhiên file bạn gửi thì nội dung text với elevation của text là khác...

>>

Đã chỉnh sửa lại theo yêu cầu của bạn. Tuy nhiên file bạn gửi thì nội dung text với elevation của text là khác nhau.

(defun c:chm()
  	(setq i 1)
	(command "osnap" "node,center,ins,end,mid")
     	(or *chieucao* (setq *chieucao* 1))
	(setq chieucao (getreal (strcat "\n Chi\U+1EC1u cao text <"
         	(rtos *chieucao* 2 2)
     	"> :"
			)
   	)
	)
     	(if (not chieucao) (setq chieucao *chieucao*) (setq *chieucao* chieucao))
     	(or *xoay* (setq *xoay* 0))
	(setq xoay (getreal (strcat "\n G\U+00F3c xoay text <"
         	(rtos *xoay* 2 2)
     	"> :"
			)
   	)
	)

  		(if (not xoay) (setq xoay *xoay*) (setq *xoay* xoay))
 (command "undo" "be")
	(setq pt1 (getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m th\U+1EE9 nh\U+1EA5t : "))
	(setq x1 (car pt1))
	(setq y1 (cadr pt1))
	(setq z1 (caddr pt1))
	(setq pt2 (getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m th\U+1EE9 hai : "))
	(setq x2 (car pt2))
	(setq y2 (cadr pt2))
	(setq z2 (caddr pt2))
	(setq Diem1 (list x1 y1))
  	(setq Diem2 (list x2 y2))
	(setq d (distance diem1 diem2))
  	(setq n (getint "\nNh\U+1EADp s\U+1ED1 \U+0111i\U+1EC3m c\U+1EA7n ch\U+00E8n: "))
	(setq kcl (/ d n))
  	(setq gocdt (angle diem1 diem2))
(while  (< i n)
	(command "osnap" "Off")
(setq pt_i (polar diem1 gocdt (* i kcl)))
	(setq x3 (car pt_i))
	(setq y3 (cadr pt_i))
	(setq d1 (distance diem1 pt_i))
(setq d2 (distance diem2 pt_i))
(setq kcdai (+ d1 d2))
	(setq dz12 (- z2 z1))
	(setq dhz (* dz12 (/ d1 kcdai)))
	(setq z3 (+ z1 dhz))
	(setq Caodo (rtos z3 2 2))
	(setq pt_i (list x3 y3 (atof Caodo)))
(entmake (list (cons 0 "TEXT")(cons 1 caodo) (cons 10 pt_i) (cons 40 chieucao)(cons 50 (DTR xoay))))
(entmake (list (cons 0 "POINT") (cons 10 pt_i)))
(setq i (1+ i))
  )
 (command "undo" "end")
(princ)
)
(defun c:chd()
  	(setq i 1)
	(command "osnap" "node,center,ins,end,mid")
     	(or *chieucao* (setq *chieucao* 1))
	(setq chieucao (getreal (strcat "\n Chi\U+1EC1u cao text  <"
         	(rtos *chieucao* 2 2)
     	"> :"
			)
   	)
	)
     	(if (not chieucao) (setq chieucao *chieucao*) (setq *chieucao* chieucao))
     	(or *xoay* (setq *xoay* 0))
	(setq xoay (getreal (strcat "\n  G\U+00F3c xoay text <"
         	(rtos *xoay* 2 2)
     	"> :"
			)
   	)
	)
     	(if (not xoay) (setq xoay *xoay*) (setq *xoay* xoay))
	(command "undo" "be")
	(setq pt1 (getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m th\U+1EE9 nh\U+1EA5t : "))
	(setq x1 (car pt1))
	(setq y1 (cadr pt1))
	(setq z1 (caddr pt1))
	(setq pt2 (getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m th\U+1EE9 hai : "))
	(setq x2 (car pt2))
	(setq y2 (cadr pt2))
	(setq z2 (caddr pt2))
	(setq Diem1 (list x1 y1))
  	(setq Diem2 (list x2 y2))
	(setq d (distance diem1 diem2))
  	(setq kcl (getint "\nNh\U+1EADp kho\U+1EA3ng c\U+00E1ch gi\U+1EEFa 2 \U+0111i\U+1EC3m: "))
	(setq n (/ d kcl))
  	(setq gocdt (angle diem1 diem2))
(while  (< i n)
	(command "osnap" "Off")
(setq pt_i (polar diem1 gocdt (* i kcl)))
	(setq x3 (car pt_i))
	(setq y3 (cadr pt_i))
	(setq d1 (distance diem1 pt_i))
(setq d2 (distance diem2 pt_i))
(setq kcdai (+ d1 d2))
	(setq dz12 (- z2 z1))
	(setq dhz (* dz12 (/ d1 kcdai)))
	(setq z3 (+ z1 dhz))
	(setq Caodo (rtos z3 2 2))
	(setq pt_i (list x3 y3 (atof Caodo)))
	(entmake (list (cons 0 "TEXT")(cons 1 caodo) (cons 10 pt_i) (cons 40 chieucao)(cons 50 (DTR xoay))))
(entmake (list (cons 0 "POINT") (cons 10 pt_i)))
(setq i (1+ i))
  )
	(command "undo" "end")
(princ)
)
(defun c:cdlt() ;chen diem lien tiep
  	(setq i 1)
	(command "osnap" "node,center,ins,end,mid")
     	(or *chieucao* (setq *chieucao* 2))
	(setq chieucao (getreal (strcat "\n Chi\U+1EC1u cao text <"
         	(rtos *chieucao* 2 2)
     	"> :"
			)
   	)
	)
     	(if (not chieucao) (setq chieucao *chieucao*) (setq *chieucao* chieucao))
     	(or *xoay* (setq *xoay* 5))
	(setq xoay (getreal (strcat "\n G\U+00F3c xoay text <"
         	(rtos *xoay* 2 2)
     	"> :"
			)
   	)
	)
     	(if (not xoay) (setq xoay *xoay*) (setq *xoay* xoay))
	(command "undo" "be")
	(setq pt1 (getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m th\U+1EE9 nh\U+1EA5t : "))
	(setq x1 (car pt1))
	(setq y1 (cadr pt1))
	(setq z1 (caddr pt1))
	(setq pt2 (getpoint "\nCh\U+1ECDn \U+0111i\U+1EC3m th\U+1EE9 hai : "))
	(setq x2 (car pt2))
	(setq y2 (cadr pt2))
	(setq z2 (caddr pt2))
	(setq Diem1 (list x1 y1))
  	(setq Diem2 (list x2 y2))
	(setq d (distance diem1 diem2))
(while
 	(progn
	(command "osnap" "Off")
(setq pt_i (getpoint "\n Ch\U+1ECDn \U+0111i\U+1EC3m c\U+1EA7n ch\U+00E8n: "))
	(setq x3 (car pt_i))
	(setq y3 (cadr pt_i))
	(setq d1 (distance diem1 pt_i))
(setq d2 (distance diem2 pt_i))
(setq kcdai (+ d1 d2))
	(setq dz12 (- z2 z1))
	(setq dhz (* dz12 (/ d1 kcdai)))
	(setq z3 (+ z1 dhz))
	(setq Caodo (rtos z3 2 2))
	(setq pt_i (list x3 y3 (atof Caodo)))
	(entmake (list (cons 0 "TEXT")(cons 1 Caodo) (cons 10 pt_i) (cons 40 chieucao)(cons 50 (DTR xoay))))
(entmake (list (cons 0 "POINT") (cons 10 pt_i)))
(setq i (1+ i))
 	)
  )
	(command "undo" "end")
(princ)
)
(defun DTR (A) (/ (* A pi) 180.0))

(defun ST: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
  )
)
(defun C:CVT3D (/ ss Tdo Caodo Pnt temp )
 (command "undo" "be")
 (command "osnap" "off")
  (setq ss (ssget (list (cons 0  "TEXT"))))
 (progn
  (setq ss (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex ss))))
  (foreach item ss
(setq temp  (entget item)
 Tdo (ST:Text-Base item )
  	Caodo (cdr (assoc 1 temp))
  Pnt (list (car Tdo)(cadr Tdo)(atof caodo))
)
  	(setq temp (subst (cons 10 Pnt)(assoc 10 temp) temp))
   	(entmod temp)
(entmake (list (cons 0 "POINT") (cons 10 Pnt) ))
  )
)
(command "undo" "end")
(princ)
)

OK,thanks bác nhiều


<<

Filename: 211491_chm_chd_cdlt_cvt3d.lsp
Tác giả: longbyoongho
Bài viết gốc: 198615
Tên lệnh: tcal
LISP cộng têxt toàn bộ bản vẽ thêm 1 hằng sô

Thêm 1 chú nữa:

 

;; free lisp from cadviet.com
;;; this lisp was downloaded from...
>>

Thêm 1 chú nữa:

 

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=37567
;;----------------------------------------------;;
;; Text calculation tool -  Skywings ;;
;;----------------------------------------------;;
;;***SUB-FUNCTION***
(defun GET-TEXT ()
 (princ "\nSelect NUMBERs : ")
 (while (null (setq Numbers (ssget '((0 . "*TEXT")))))
(princ "\n**NOTHING selected!**")
 )
)
(defun GET-DATA (/ ss-mt ss-t n)
 (setq ss-mt (ssadd)
ss-t  (ssadd)
n 	0
sw	0
 )
 (repeat (sslength Numbers)
(setq ent (ssname Numbers n))
(if (= (cdr (assoc 0 (entget ent))) "MTEXT")
 	(setq ss-mt (ssadd ent ss-mt))
 	(setq ss-t (ssadd ent ss-t))
)
(setq n (1+ n))
 )
 (if (/= (sslength ss-mt) 0)
(setq Numbers (acet-explode ss-mt)
  sw   1
)
 )
 (setq n 0)
 (repeat (sslength ss-t)
(setq ent   (ssname ss-t n)
  Numbers (ssadd ent Numbers)
  n   (1+ n)
)
 )
)
(defun GET-VALUE (name / sw)
 (princ (strcat "\nSelect " name " : "))
 (cond
((= (cdr (assoc 0 (entget ename))) "MTEXT")
(command ".explode" ename "")
(setq value (read (cdr (assoc 1 (entget (entlast)))))
sw  1
)
)
((setq value (read (cdr (assoc 1 (entget ent))))))
 )
 (if (= sw 1)
(command ".undo" 1)
 )
 value
)
(defun OPT ()
 (if (null option)
(setq option "Replace"
  save2  option
)
 )
 (initget "Replace Create Do-nothing")
 (setq
option
(getkword
  	(strcat "\nOptions:  <"
   	option
   	"> "
  	)
)
 )
 (if (null option)
(setq option save2)
(setq save2 option)
 )
 (setq switch 1)
)
(defun ACTION (option result / txt pnt)
 (cond
((= option "Replace")
(while (null (setq txt (entsel "\nChoose TEXT to replace: ")))
  	(princ "\n**NOTHING selected!**")
)
(setq txt (entget (car txt))
txt (subst (cons 1 result) (assoc 1 txt) txt)
)
(entmod txt)
)
((= option "Create")
(setq pnt (getpoint "\nSpecify start point of text:"))
(entmake (list (assoc 0 ent)
 	(assoc 8 ent)
 	(cons 1 result)
 	(cons 10 (trans pnt 1 0))
 	(assoc 40 ent)
 	(assoc 7 ent)
 	(assoc 50 ent)
  	)
)
)
 )
)
(defun GET-ORDER ()
 (princ (strcat "\nCurrent setting: Precision = "
  (rtos precision 2 0)
  " <"
  (rtos 0 2 precision)
  ">"
 )
 )
 (initget
"Plus Subtract Multiply Divide Average maX-min ADd-by mUltiply-by preCision"
 )
 (setq operation
 (getkword
(strcat
 	"\nOperations: : <"
 	operation
 	"> "
)
 )
 )
 (if (null operation)
(setq operation save1)
(setq save1 operation)
 )
)
;;***MAIN FUNCTION***:
(defun c:TCAL (/ Numbers   DIVIDEND  DIVISOR   ENT  ID
  INDEX	MINUEND   NUM-MAX   NUM-MIN  NUM-SET
  RESULT	SUBTRAHEND    	SWITCH  VALUE
  sw
 )
 (princ
"** Text calculation tool - Skywings **"
 )
 (setvar "CMDECHO" 0)
 (setvar "QAFLAGS" 1)
 (if (null precision)
(setq precision 2
  save3 precision
)
 )
 (if (null operation)
(setq operation "Plus"
  save1 operation
)
 )
 (GET-ORDER)
 (while (= operation "preCision")
(initget 4)
(setq
 	precision (getint (strcat "\nSpecify new precision: <"
(rtos precision 2 0)
"> "
  )
 )
)
(if (null precision)
 	(setq precision save3)
 	(setq save3 precision)
)
(GET-ORDER)
 )
 (cond
;; PLUS:
((= operation "Plus")
(GET-TEXT)
(setq switch 0)
(while (/= Numbers nil)
  	(GET-DATA)
  	(setq index 0
 	result 0
  	)
  	(princ "\n>>Expression: ")
  	(repeat (sslength Numbers)
 (setq ent   (entget (ssname Numbers index))
   	value (read (cdr (assoc 1 ent)))
   	index (1+ index)
 )
 (if (numberp value)
(progn
 	(setq result (+ result value))
 	(if (/= index 1)
   	(princ " + ")
 	)
 	(princ (rtos value 2 precision))
)
 )
  	)
  	(if (= sw 1) (command ".undo" 1))
  	(princ (strcat "\n>>RESULT = " (rtos result 2 precision)))
  	(if (= switch 0)
 (OPT)
  	)
  	(ACTION option (rtos result 2 precision))
  	(setq Numbers nil
 	Numbers (ssget '((0 . "*TEXT")))
  	)
)
)
;; MULTIPLY:
((= operation "Multiply")
 	(GET-TEXT)
 	(setq switch 0)
 	(while (/= Numbers nil)
(GET-DATA)
(setq index 0
  	result 1
)
(princ "\n>>Expression: ")
(repeat (sslength Numbers)
  (setq ent   (entget (ssname Numbers index))
 value (read (cdr (assoc 1 ent)))
 index (1+ index)
  )
  (if (numberp value)
(progn
  	(setq result (* result value))
  	(if (/= index 1)
 (princ " * ")
  	)
  	(princ (rtos value 2 precision))
)
  )
)
(if (= sw 1)
  (command ".undo" 1)
)
(princ (strcat "\n>>RESULT = " (rtos result 2 precision)))
(if (= switch 0)
  (OPT)
)
(ACTION option (rtos result 2 precision))
(setq Numbers nil
  	Numbers (ssget '((0 . "*TEXT")))
)
 	)
)
;; SUBTRACT:
((= operation "Subtract")
 	(setq switch 0
sw 0
 	)
 	(while (null (setq ename (car (entsel (strcat "\nSelect MINUEND : "))))))
 	(setq minuend (GET-VALUE "MINUEND"))
 	(while (null (numberp minuend))
(while (null (setq ename (car (entsel (strcat "\nSelect MINUEND : "))))))
(setq minuend (GET-VALUE "MINUEND"))
 	)
 	(princ minuend)
 	(redraw ename 3)
 	(princ "\nSelect SUBTRAHENDs : ")
 	(while (null (setq Numbers (ssget '((0 . "*TEXT")))))
(princ "\nSelect SUBTRAHENDs : ")
 	)
 	(redraw ename 4)
 	(while (/= ename nil)
(GET-DATA)
(setq index   0
  	result  0
  	minuend (float minuend)
)
(princ (strcat "\n>>Expression: "
	(rtos minuend 2 precision)
	" - ("
   	)
)
(repeat (sslength Numbers)
  (setq ent	(entget (ssname Numbers index))
 subtrahend (read (cdr (assoc 1 ent)))
 index	(1+ index)
  )
  (if (numberp subtrahend)
(progn
  	(setq result (+ result subtrahend))
  	(if (/= index 1)
 (princ " + ")
  	)
  	(princ (rtos subtrahend 2 precision))
)
  )
)
(princ ")")
(if (= sw 1)
  (command ".undo" 1)
)
(setq result (- minuend result))
(princ (strcat "\n>>RESULT = " (rtos result 2 precision)))
(if (= switch 0)
  (OPT)
)
(ACTION option (rtos result 2 precision))
(setq ename nil
  	ename (car (entsel (strcat "\nSelect MINUEND : ")))
)
(if
  (or
(null ename)
(null (numberp (setq minuend (GET-VALUE "MINUEND"))))
  )
  (progn
(setvar "QAFLAGS" 0)
(vl-exit-with-error "")
  )
)
(princ minuend)
(princ "\nSelect SUBTRAHENDs <TEXT>: ")
(while (null (setq Numbers (ssget '((0 . "*TEXT")))))
  (princ "\nSelect SUBTRAHENDs : ")
)
 	)
)
;; DIVIDE:
((= operation "Divide")
 	(setq switch 0
sw 0
 	)
 	(while (null (setq ename (car (entsel (strcat "\nSelect DIVIDEND : "))))))
 	(setq dividend (GET-VALUE "DIVIDEND"))
 	(while (null (numberp dividend))
(while (null (setq ename (car (entsel (strcat "\nSelect DIVIDEND : "))))))
(setq dividend (GET-VALUE "DIVIDEND"))
 	)
 	(princ dividend)
 	(redraw ename 3)
 	(princ "\nSelect DIVISORs : ")
 	(while (null (setq Numbers (ssget '((0 . "*TEXT")))))
(princ "\nSelect DIVISORs : ")
 	)
 	(redraw ename 4)
 	(while (/= ename nil)
(GET-DATA)
(setq index   0
  	result  1
  	dividend (float dividend)
)
(princ (strcat "\n>>Expression: "
	(rtos dividend 2 precision)
	" / ("
   	)
)
(repeat (sslength Numbers)
  (setq ent (entget (ssname Numbers index))
 divisor (read (cdr (assoc 1 ent)))
 index (1+ index)
  )
  (if (numberp divisor)
(progn
  	(setq result (* result divisor))
  	(if (/= index 1)
 (princ " * ")
  	)
  	(princ (rtos divisor 2 precision))
)
  )
)
(princ ")")
(if (= sw 1)
  (command ".undo" 1)
)
(setq result (/ dividend result))
(princ (strcat "\n>>RESULT = " (rtos result 2 precision)))
(if (= switch 0)
  (OPT)
)
(ACTION option (rtos result 2 precision))
(setq ename nil
  	ename (car (entsel (strcat "\nSelect DIVIDEND : ")))
)
(if
  (or
(null ename)
(null (numberp (setq dividend (GET-VALUE "DIVIDEND"))))
  )
  (progn
(setvar "QAFLAGS" 0)
(vl-exit-with-error "")
  )
)
(princ dividend)
(princ "\nSelect DIVISORs : ")
(while (null (setq Numbers (ssget '((0 . "*TEXT")))))
  (princ "\nSelect DIVISORs : ")
)
 	)
)
;; AVERAGE:
((= operation "Average")
(GET-TEXT)
(setq switch 0)
(while (/= Numbers nil)
  	(GET-DATA)
  	(setq index 0
 	id 0
 	result 0
  	)
  	(princ "\n>>Expression: (")
  	(repeat (sslength Numbers)
 (setq ent   (entget (ssname Numbers index))
   	value (read (cdr (assoc 1 ent)))
   	index (1+ index)
 )
 (if (numberp value)
(progn
 	(setq result (+ result value)
id   (1+ id)
 	)
 	(if (/= index 1)
   	(princ " + ")
 	)
 	(princ (rtos value 2 precision))
)
 )
  	)
  	(if (= sw 1) (command ".undo" 1))
  	(setq result (rtos (/ (float result) id) 2 precision))
  	(princ (strcat ") / " (rtos id 2 0)))
  	(princ (strcat "\n>>RESULT = " result))
  	(if (= switch 0)
 (OPT)
  	)
  	(ACTION option result)
  	(setq Numbers nil
 	Numbers (ssget '((0 . "*TEXT")))
  	)
)
)
;; MAX-MIN:
((= operation "maX-min")
(GET-TEXT)
(setq switch 0)
(while (/= Numbers nil)
  	(GET-DATA)
  	(setq index 0
 	Num-set nil
  	)
  	(repeat (sslength Numbers)
 (setq ent   (entget (ssname Numbers index))
   	value (read (cdr (assoc 1 ent)))
   	index (1+ index)
 )
 (if (numberp value)
(setq Num-set (cons value Num-set))
 )
  	)
  	(setq Num-set (vl-sort Num-set '>)
 	num-max (car Num-set)
 	num-min (last Num-set)
 	result  (strcat "MAX = "
   	(rtos num-max 2 precision)
   	"  MIN = "
   	(rtos num-min 2 precision)
  	)
  	)
  	(if (= sw 1) (command ".undo" 1))
  	(princ "\n>>Numbers set: ")
  	(princ Num-set)
  	(print)
  	(princ result)
  	(if (= switch 0)
 (OPT)
  	)
  	(ACTION option result)
  	(setq Numbers nil
 	Numbers (ssget '((0 . "*TEXT")))
  	)
)
)
;; ADD-BY...:
((= operation "ADd-by")
(if (null number0)
  	(setq number0 0.00
 	save4 number0
  	)
)
(setq number0 (getreal (strcat "Add by: <" (rtos number0 2 2) "> "))
index   0
)
(if (null number0)
  	(setq number0 save4)
  	(setq save4 number0)
)
(GET-TEXT)
(GET-DATA)
(repeat (sslength Numbers)      
  	(setq ent   (entget (ssname Numbers index))
 	value (read (cdr (assoc 1 ent)))
 	index (1+ index)
  	)      
  	(if (numberp value)
 (setq value (+ (float value) number0)
   	ent   (subst (cons 1 (rtos value 2 precision))
  	(assoc 1 ent)
  	ent
  	)
 )
  	)
  	(entmod ent)      
)
)
;;MULTIPLY-BY...:
((= operation "mUltiply-by")
(if (null number0)
  	(setq number0 0.00
 	save4 number0
  	)
)
(setq number0 (getreal (strcat "Multiply by: <" (rtos number0 2 2) "> "))
index   0
)
(if (null number0)
  	(setq number0 save4)
  	(setq save4 number0)
)
(GET-TEXT)
(GET-DATA)
(repeat (sslength Numbers)
  	(setq ent   (entget (ssname Numbers index))
 	value (read (cdr (assoc 1 ent)))
 	index (1+ index)
  	)
  	(if (numberp value)
 (setq value (* (float value) number0)
   	ent   (subst (cons 1 (rtos value 2 precision))
  	(assoc 1 ent)
  	ent
  	)
 )
  	)
  	(entmod ent)
)
)
 )
 (princ "<Exit>")
 (setvar "QAFLAGS" 0)
 (princ)
)

 

Tcal dùng lựa chọn AD (add-by) nhập hằng số K là -K nếu muốn trừ, K nếu muốn cộng

Bạn ơi bạn có thể thêm tiền tố vào trước kết quả xuất ra không? ví dụ (+1) + (+1) = (+2) tương tự với các ký tự khác ví dụ (layer1: 1,2) + (3) = (layer1: 3,2).

Và thêm phần +,-,*,/ với số nhập từ bàn phím nữa thì quá tuyệt. Thanks:D


<<

Filename: 198615_tcal.lsp
Tác giả: Phiphi-
Bài viết gốc: 64762
Tên lệnh: st1
Viết Lisp theo yêu cầu
Kết hợp như dưới đây.

(defun c:st1 ( / oldos lst1 ss ki ki0 ki1 ki2 lst ddau dcuoi eget)
 (setq oldos (getvar "osmode"))
 (setvar "osmode" 0)

 (prompt "Chon Text:")
 (setq ss ...
>>
Kết hợp như dưới đây.

(defun c:st1 ( / oldos lst1 ss ki ki0 ki1 ki2 lst ddau dcuoi eget)
 (setq oldos (getvar "osmode"))
 (setvar "osmode" 0)

 (prompt "Chon Text:")
 (setq ss  (ssget '((0 . "TEXT"))))

 (if (not tyledong)  (setq tyledong 1.5))    
 (setq tyledong1 (getreal (strcat "\nVao ty le dong khoang cach dong <"
			    (rtos tyledong 2 2) ">: ")))     
 (if tyledong1 (setq tyledong tyledong1))

 (setq lst1 '(("L" 0 0)  ("C" 1 0)  ("R" 2 0)  ("M" 4 0)
      ("TL" 0 3)  ("TC" 1 3) ("TR" 2 3)
      ("ML" 0 2)  ("MC" 1 2) ("MR" 2 2)
      ("BL" 0 1)  ("BC" 1 1) ("BR" 2 1)))

 (initget 1 "C L M R TL TC TR ML MC MR BL BC BR")
 (setq ki  (getkword "Enter an option :")
ki1 (cadr (setq ki0 (assoc ki lst1)))
       ki2 (last ki0)	
       lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
lst (vl-sort lst '(lambda (e1 e2) (> (caddr (assoc 10 (entget e1))) 
                                     (caddr (assoc 10 (entget e2))))))										 
vt (cdr (assoc 10 (entget (car lst))))
yht (cadr vt)
linespc (* (cdr (assoc 40 (entget (car lst)))) tyledong)
 )

 (command "undo" "begin")
 (foreach e lst   
(setq eget (entget e)	      
      dtiep (list (car vt) (setq yht (- yht linespc)) 0)
      eget (subst (cons 72 ki1) (assoc 72 eget) eget)
      eget (subst (cons 73 ki2) (assoc 73 eget) eget)
      eget (if (and (zerop ki1) (zerop ki2))
	     (subst (cons 10 dtiep) (assoc 10 eget) eget)
	     (subst (cons 11 dtiep) (assoc 11 eget) eget))
)
   (entmod eget)  
 )
 (command "undo" "end")
 (setvar "osmode" oldos)
 (Princ)
)

Trên cả mức tuyệt vời.

Cám ơn bác q288 thật nhiều


<<

Filename: 64762_st1.lsp
Tác giả: engineer0405
Bài viết gốc: 196742
Tên lệnh: an hien
Xin lisp chọn dim

Hay là các bạn có thể sử dụng lisp này. Viết lại 1 tý :

(defun c:an (/ ssd dtuong)
(initget "")
(setq dtuong (getstring...
>>

Hay là các bạn có thể sử dụng lisp này. Viết lại 1 tý :

(defun c:an (/ ssd dtuong)
(initget "")
(setq dtuong (getstring "\n Nhap ten doi tuong can An : / Enter de Pick chon doi tuong mau : "))
(if (= dtuong "") (setq dtuong (acet-dxf 0 (entget(car(entsel "\n Pick chon doi tuong mau :"))))))
 (if (setq ssd (ssget (list (cons 0 dtuong))))
   (acet-ss-visible (acet-ss-remove ssd (ssget "X" (list (cons 0 dtuong))  )) 1)
 )
)
;;;;;;;;
(defun c:Hien(/)
   (acet-ss-visible (ssget "X" '((60 . 1))) 0)
)

Cách chạy :

 

Command: an -> Gõ lệnh AN

Nhap ten doi tuong can An : / Enter de Pick chon doi tuong mau : LINE -> Nhập tên đối tượng cần ẩn.

Ví dụ LINE thì gõ LINE

TEXT và MTEXT có thể gõ *TEXT hoặc gõ TEXT,MTEXT

POLYLINE có thể gõ *POLYLINE

Block : gõ INSERT

DIMENSION thì gõ DIMENSION

HATCH thì gõ HATCH

.....

- Nếu bạn không nhớ tên thì có thể enter để chọn 1 đối tượng mẫu

- Chọn đối tượng cần giữ lại. Các đối tượng cùng "kiểu" với đối tượng không được chọn sẽ bị ẩn

 

Select objects: -> Chọn đối tượng cần giữ lại

 

Hiện lại thì gõ lệnh hien

 

....

 

Chúc vui

lisp này trả về lỗi nil

không hiểu sao vậy anh

em cảm ơn anh


<<

Filename: 196742_an_hien.lsp
Tác giả: leolas
Bài viết gốc: 14332
Tên lệnh: tg
Routine tính tổng chiều dài các đối tượng

Nhờ sự giúp đỡ của bác Nguyễn Hoành em có viết 1 đoạn code nhằm tính tổng chiều dài của các đối tượng chọn (*Line, Arc, Circle, Elippse). Các bác dùng thử và cho ý...
>>
Nhờ sự giúp đỡ của bác Nguyễn Hoành em có viết 1 đoạn code nhằm tính tổng chiều dài của các đối tượng chọn (*Line, Arc, Circle, Elippse). Các bác dùng thử và cho ý kiến.

Một lần nữa xin cảm ơn bác Hoành về sự nhiệt tình giúp đỡ anh em.

Chúc cả nhà luôn vui..

 

(defun add_mline ()
 (foreach e_record_sub	e_record
   (cond ((= 10 (car e_record_sub))
   (setq pt1	   (cdr e_record_sub)
	 mline_len 0.0
   )
  )
  ((= 11 (car e_record_sub))
   (setq pt2	   (cdr e_record_sub)
	 mline_len (+ mline_len (distance pt2 pt1))
	 pt1	   pt2
   )
  )
   )
 )
 (setq tot_len (+ tot_len mline_len))
 (ssdel e_name ss)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun C:tg (/ tot_len ss e_name e_record e_type)
 (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))
  (e_type (ssdel e_name ss))
   )
 )
 (prompt (strcat "\nTotal length is: " (rtos tot_len 2 2)))
 (princ)
)

Cám ơn bạn với code này. Nhưng mình muốn tính tổng chiều dài tát cả các LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE trong 1 lớp , khi chạy code hỏi " tính cho lớp nào", mình chọn lớp, ra kết quả. Bạn giúp mình nha


<<

Filename: 14332_tg.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 114198
Tên lệnh: sct
xin lisp scale TẠI TÂM cho nhiều đối tượng
HÌ!! bạn thử cái này xem có vừa ý không nhé

(defun BatDau() (setq OldOs (getvar "osmode")) (setvar "osmode" 0))
(defun KetThuc() (setvar "osmode" OldOs))
(defun...
>>
HÌ!! bạn thử cái này xem có vừa ý không nhé

(defun BatDau() (setq OldOs (getvar "osmode")) (setvar "osmode" 0))
(defun KetThuc() (setvar "osmode" OldOs))
(defun c:sct (/ OldOs OldEcho tile en pt1 pt2 mid i Rec)
(setq i 0)
(princ "\nChon Doi tuong Scale tai tam:") 
(setq ss (ssget))
(setq tile (getreal "\nChon tile Scale:"))
(while ((setq en (ssname ss i))
(setq  Rec (acet-ent-geomextents en)
   pt1 (nth 0 Rec);lay dinh
   pt2 (nth 1 Rec);lay dinh 
   mid (acet-geom-midpoint pt1 pt2)
);setq
(BatDau)
(command "SCALE" en "" mid tile )
(KetThuc)	

(setq i (1+ i))	 
);while
     (princ "\n...Done...")
(princ)
);defun

Tại cái TÂM của bạn nó khó xác định quá nên mình dùng cách này nhé!!!

Tiện đây mình hỏi luôn: cái Hàm acet-ent-geomextents tại sao nó vẫn thực hiện mà cứ báo lỗi nhỉ

Mình dùng hàm acet-ent-geomextents để xác định tâm.

Tốt nhất bạn Block từng đối tượng muốn scale vào để đc chính xác!!!

Chào bạn nguyentuyen6,

Nó báo lỗi thế nào hử bạn???

Rất cám ơn bạn về cái hàm (acet-ent-midpoint... )

 

@ Ketui: Bữa nay bác thấy trong người không khỏe ư???? Bác quả là vui khi thấy có người chết đứ đừ ư???

@ Chủ thớt: Hãy suy nghĩ cho kỹ trước khi làm chủ thớt. Làm chủ mà không biết mình cần gì thì có ngày bán thớt sớm đó. Ý kiến của mọi người cho dù có chưa đúng cũng không phải cái cớ để chém thớt đâu ông chủ ạ....Hãy học cách tôn trọng người khác nếu còn muốn làm chủ.....


<<

Filename: 114198_sct.lsp
Tác giả: duyngoc
Bài viết gốc: 176395
Tên lệnh: glt
Lisp tính lý trình các điểm trên 1 polyline/line

Hề hề hề,

Của bạn đây. Hy vọng bạn sẽ hài lòng với lần sửa này;


(defun c:glt (/ pl plst...
>>

Hề hề hề,

Của bạn đây. Hy vọng bạn sẽ hài lòng với lần sửa này;


(defun c:glt (/ pl plst pa pd k l a lt lt1 lt2 txt tg etg txtp txtp1 txtp2 dl dl1 dl2)
(vl-load-com)
(command "undo" "be")
(setq pl (car (entsel "\n Chon polyline can ghi ly trinh")))
(setq plst (vl-sort (acet-geom-vertex-list pl) '(lambda (x y) (< (car x) (car y)))))
(setq pa (getstring t "\n Chon diem goc ghi ly trinh <T or P>: "))
(if (= (strcase pa) "T")
   (setq pd (car plst))
   (setq pd (last plst))
)
(setq k (getint "\n Chon so chu so thap phan: "))
(setq l (getint "\n Chon phuong an ghi ly trinh <1 or 2>: "))
(setq a (getpoint "\n Chon point can ghi ly trinh"))
(while ( /= a nil)
(if (= l 1)
   (progn
         (if (equal (vlax-curve-getStartPoint (setq obj (vlax-ename->vla-object pl))) pd 0.001)
             (setq lt (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a)))
             (setq lt (- (vlax-curve-getDistAtPoint obj (vlax-curve-getEndPoint obj))
                           (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a))))
         )
         (setq dl (- lt (* (fix (/ lt 1000)) 1000)))
         (if (< (fix dl) 100)
             (if (< (fix dl) 10)
                 (setq txtp (strcat "00" (rtos dl 2 k)))
                 (setq txtp (strcat "0" (rtos dl 2 k)))
             )
             (setq txtp (rtos dl 2 k))
         )
         (setq txt (strcat "Km" (itoa (fix (/ lt 1000))) "+" txtp))
         (setq tg (car (entsel "\n Chon text can thay the ")))
         (setq etg (entget tg))
         (setq etg (subst (cons 1 txt) (assoc 1 etg) etg))
         (entmod etg)
   )
   (progn
	(if (equal (vlax-curve-getStartPoint (setq obj (vlax-ename->vla-object pl))) pd 0.001)
		(progn
                 (setq lt1 (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a)))
                 (setq lt2 (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj (getpoint "\n Chon second point can ghi ly trinh"))))
		)
		(progn
				(setq lt1 (- (vlax-curve-getDistAtPoint obj (vlax-curve-getEndPoint obj))
                				(vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a))))
				(setq lt2 (- (vlax-curve-getDistAtPoint obj (vlax-curve-getEndPoint obj))
                				(vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj (getpoint "\n Chon second point can ghi ly trinh")))))
		)
         )
         (setq dl1 (- lt1 (* (fix (/ lt1 1000)) 1000)))
         (if (< (fix dl1) 100)
             (if (< (fix dl1) 10)
                 (setq txtp1 (strcat "00" (rtos dl1 2 k)))
                 (setq txtp1 (strcat "0" (rtos dl1 2 k)))
             )
             (setq txtp1 (rtos dl1 2 k))
         )
         (setq dl2 (- lt2 (* (fix (/ lt2 1000)) 1000)))
         (if (< (fix dl2) 100)
             (if (< (fix dl2) 10)
                 (setq txtp2 (strcat "00" (rtos dl2 2 k)))
                 (setq txtp2 (strcat "0" (rtos dl2 2 k)))
             )
             (setq txtp2 (rtos dl2 2 k))
         )
         (setq txt (strcat "Km" (itoa (fix (/ lt1 1000))) "+" txtp1 "-Km" (itoa (fix (/ lt2 1000))) "+" txtp2 ))
         (setq tg (car (entsel "\n Chon text can thay the ")))
         (setq etg (entget tg))
         (setq etg (subst (cons 1 txt) (assoc 1 etg) etg))
         (entmod etg)
)
)
(setq a (getpoint "\n Ban hay chon diem tiep theo: ")))
)
(command "undo" "e")
(princ)
)

Chúc bạn luôn vui khi tham gia diễn đàn cùng mọi người.

Mình thấy lisp của bạn PhamThanhBinh rất hay, tuy nhiên nếu sửa lại như thế này thì hay biết mấy: Sau khi gõ lệnh GLT thì lisp nên hỏi chọn điểm gốc để tính lý trình, lý trình điểm gốc là bao nhiêu? để điền cho đúng.


<<

Filename: 176395_glt.lsp
Tác giả: proconeng86
Bài viết gốc: 306391
Tên lệnh: xrefbind
Lisp Bind Xref các bản vẽ đang mở

 

Tên topic không hợp lệ, nhưng hơn hai tuần rồi topic vẫn còn (không bị xóa) chắc là mod bỏ qua rồi.

gửi bạn Lisp...

>>

 

Tên topic không hợp lệ, nhưng hơn hai tuần rồi topic vẫn còn (không bị xóa) chắc là mod bỏ qua rồi.

gửi bạn Lisp bind xref cho file hiện hành.

Nếu OK thì việc dùng cho các file đang mở chỉ là chuyện nhỏ.

(defun c:XrefBind ()
  (vlax-map-Collection (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object)))
    '(lambda (b)
       (if (= (vla-get-IsXRef b) :vlax-true)
	 (vl-catch-all-error-p
	   (vl-catch-all-apply 'vla-bind (list b :vlax-true)  ) )  )  )  ))

 

Lisp này rất là hay tuy nhiên chỉ bind được file đang mở. Mình làm với 1 bên kiến trúc, mỗi mặt bằng họ làm 1 file do đó để bind được hết cũng mất rất nhiều thời gian

Mình thấy Lee Mac có 1 lisp rất hay là copy một số đối tượng vào nhiều file mà không cần mở những file đó ra (lisp đính kèm)

Do đó mình nhờ các bạn cải thiện lisp bind trên theo hướng có thể bind bản vẽ mà không cần mở như của LeeMac thì tuyệt vời

Cám ơn các bạn nhiều

P/s: bạn Tot77 đã cải tiến lisp bind trên với 1 lựa chọn là có thể chọn đối tượng để bind hoặc bind tất cả. Các bạn cải tiến lisp của bạn Tot77 theo hướng là không cần mở bản vẽ mà vẫn bind được thì tuyêt nhất

 

http://www.mediafire.com/download/du0mgjnbwqbdb86/Copy2DrawingsV1-2.lsp

http://www.mediafire.com/download/t5soxppm4q3w4dg/bind_xref.lsp


<<

Filename: 306391_xrefbind.lsp
Tác giả: abc007
Bài viết gốc: 104942
Tên lệnh: pllev
GHI CAO ĐỘ TUYẾN CỐNG

Bạn abc007 và hoa35ktxd thử code này nhé :

 

(defun c:PLLEV(/ OK PL LenPL I Points LenPoint ep NewLv Lv)
 (while (and (null OK)
      (setq ddau (getpoint "\n Chon diem...
>>
Bạn abc007 và hoa35ktxd thử code này nhé :

 

(defun c:PLLEV(/ OK PL LenPL I Points LenPoint ep NewLv Lv)
 (while (and (null OK)
      (setq ddau (getpoint "\n Chon diem dau cua tuyen Cong POLYLINE :")))
 (if (null ddau) (setq OK t)
   (if (and (setq PL (nentselp ddau))
     (wcmatch (cdr (assoc 0 (entget(car PL)))) "*POLYLINE")
     (or(equal (vlax-curve-getstartpoint (car PL)) ddau)
        (equal (vlax-curve-getEndpoint (car PL)) ddau)
     )
)
     (PROGN
(setq OK t)
(setq Points (mapcar 'cdr (vl-remove-if '(lambda(x) (if (/= (car x) 10) x))
	     (entget(car pl)))))
  	(if (equal (setq ep (vlax-curve-getEndpoint (car PL))) ddau)
   		 (setq Points (reverse Points))
       )
(setq LenPoints (length Points) i 1)
 	(setq lv (getreal "\nNhap cao do dau: ")
      Id (Getreal "\nNhap do doc doc: ")
)
 	(setq cao (getdist "\n NHap chieu cao Text :"))
(wtxt (rtos LV 2 3) ddau cao)
   (while (< i LenPoints)
     (setq p1 (nth i Points))
     (if (equal ep ddau)
(setq Len (ABS (- (Vlax-curve-getdistatpoint (car PL) ep)
	           (Vlax-curve-getdistatpoint (car PL) p1)
	       )
	  )
)
       (setq Len (Vlax-curve-getdistatpoint (car PL) p1))
     )
       (setq NewLV (+ LV (/ (* Id Len) 100.0)))
       (wtxt (rtos NewLV 2 3) p1 cao)
     (setq i (1+ i))
   )

     );PROGN
       (princ "\n Chon diem dau khong dung tren POLYline")
   )
  )
 )
)
;;;
(defun wtxt(txt p cao)
 (entmake (list (cons 0 "TEXT")
	 (cons 10 p)
	 (cons 11 p)
	 (cons 1 txt)
	 (cons 40 cao)
	 (cons 72 1)
	 (cons 73 2)))
)

@Hoa35ktxd : Đây là code mà Tue_NV viết theo các ý trên :

Kiểm tra Chọn điểm đầu hoặc điểm cuối của Polyline, đồng thời chọn luôn Pline làm cơ sở tính toán

Nếu User chọn không đúng điểm đầu hoặc điểm cuối trên PLINE hoặc chọn trật thì Lisp sẽ báo câu :

Chon diem dau khong dung tren POLYline

Nếu không thích tính toán viết Text, bác cứ Enter -> kết thúc lệnh

 

Vì Pline trên màn hình CAD : User không nhận ra đâu là điểm đầu, đâu là điểm cuối nên :

- Nếu User chọn đúng điểm đầu thì Lisp sẽ tính toán và viết Text từ điểm đầu đến điểm cuối

- Nếu User chọn đúng điểm cuối thì Lisp sẽ tính toán và viết Text từ điểm cuối đến điểm đầu

 

Lisp đúng trong trường hợp ống cống có đoạn bo cong

Bác thử nhé :D

 

Rất vui nếu được biết tên bác và làm quen với bác :D

Thank hai Bác hoa35ktxd và Tue NV nhiều lắm , mình đang cần cái này, 2 Bác rất tuyệt.Thank


<<

Filename: 104942_pllev.lsp
Tác giả: VUVUZELA
Bài viết gốc: 108446
Tên lệnh: test
Có cách nào lấy dữ liệu và chỉnh sửa đối tượng PROXY
Chào VUVUZELA

Ngoài lề 1 chút, VUVUZELA có ai "chống lưng" không vậy ?

(do mở cùng một vấn đề trên nhiều topic khác nhau nhưng chẳng thấy Mod nào lên...

>>
Chào VUVUZELA

Ngoài lề 1 chút, VUVUZELA có ai "chống lưng" không vậy ?

(do mở cùng một vấn đề trên nhiều topic khác nhau nhưng chẳng thấy Mod nào lên tiếng !

hề hề : chắc sợ FIFA can thiệp ...)

 

Trở lại chủ đề chính, không phải là tui không nói sớm, mà là do cách đặt vấn đề của VUVUZELA.

- bài viết đầu tiên Vuvuzela hỏi : Có cách nào để tìm điểm gốc đặt vị trí của PROXY ? Thú thực cho đến bây giờ tôi chưa biết cách tìm điểm gốc đặt vị trí của PROXY, nên không thể trả lời đuợc.

- tuy nhiên với cách tiếp cận : tìm và xoá các đối tượng nằm gần nhau dưới 1 khoảng cách thì vấn đề lại khác.

 

Yêu cầu của bạn tuơng tự như yêu cầu : xoá text trong khoảng nhất định của NDBNGO http://www.cadviet.com/forum/index.php?showtopic=23110

Vấn đề ở đây là tìm đuờng bao của PROXY (mở rộng : tìm đuờng bao của tất cả đối tuợng).

Trên cơ sở đuờng bao của các PROXY, nếu đối tuợng có giao với đuờng bao -> xóa đối tuợng đó.

 

Vì Vuvuzela đã biết lập trình nên tôi chỉ giới thiệu hàm tính đuờng bao của PROXY (mở rộng cho tất cả đối tuợng)

Các buớc kế tiếp, tham khảo Lisp xoá text trong khoảng nhất định

 

Code hàm tính đuờng bao của đối tuợng:

(defun lstBound (ent / lst ll ur)
 (vla-GetBoundingBox (vlax-Ename->Vla-Object ent) 'll 'ur)
 (setq ll (safearray-value ll)
ur (safearray-value ur)
lst (list (list (car ll) (cadr ll))
	  (list (car ll) (cadr ur))
	  (list (car ur) (cadr ur))
	  (list (car ur) (cadr ll)))))

(defun C:test (/ ent lstRec)
 (setq ent (car (entsel "\nSelect object:"))
lstRec (lstBound ent))
 (vla-put-Closed
   (vla-AddLightWeightPolyline (vla-get-modelspace (vla-get-ActiveDocument (vlax-get-Acad-Object)))
     (vlax-make-variant
(vlax-safearray-fill
  (vlax-make-safearray vlax-vbDouble (cons 0 (1- (* 2 (length lstRec)))))
  (apply (function append) lstRec))))
   :vlax-true)
 (princ)  )

Lọc lấy layer chứa proxy

- hàm chọn tất cả các Proxy (ssget (list (cons 0 "ACAD_PROXY_ENTITY")))

có tập chọn thì việc lấy layer chứa proxy là chuyện nhỏ với Vuvuzela ?!

 

Chúc bạn thành công và tiếp tục lăn bánh Bon ... on ... n

 

Bác gia_bach uy tín thật

Bác bảo đầu tuần sẽ reply thì mới sáng thứ 2 mở ra đã có rồi

Cám ơn bác nhiều nhé, bác đã chỉ ra hướng thật là hay. Em đã ngộ ra nhiều điều

Khâm phục, khâm phục

Em viết autolisp từ hồi autocad R14 đến giờ nên khả năng cập nhật những câu lệnh mới của visual lisp thì chịu (tiếng Anh dốt mà)

Cái PROXY này trong các chương trình thường lấy theo layer hiện hành nên việc lọc để mà EXPLODE rất khó

nên việc viết chương trình thường gặp vấn đề chỗ này

Nhưng có một cách là lấy DXF name của nó

Ví dụ như khi bấm lệnh command : LIST chọn đối tượng sẽ ra kết quả như thế này

LIST

Select objects: 1 found

Select objects:

 

ACAD_PROXY_ENTITY Layer: "CDTKE"

Space: Model space

Handle = 3F6652

DXF name: HS_NODEOBJECT

Class name: HsNodeObj

Application name: Harmony

 

Vì vậy cách tốt nhất là lấy được DXF name: HS_NODEOBJECT (em tham khảo các phần mềm khác cũng thường định nghĩa cho các đối tương thường theo DXF name này)

Vì thế, "đã thương thì thương cho chót"

Mong bác chỉ giáo cách nào lấy được DXF name của nó để em lọc cho nó dễ

Em xin cám ơn bác nhiều lắm

 

Còn đối với câu hỏi

 

Ngoài lề 1 chút, VUVUZELA có ai "chống lưng" không vậy ?

 

Thì em xin trả lời luôn là không có ai chống lưng hết

Chắc tại các bác Admin thấy em hiền (đi tu rồi, không có ý quậy phá gì) lại ham học hỏi nên thương tình, không thổi còi em vậy thôi

Bon ... on ... n

 

:(


<<

Filename: 108446_test.lsp

Trang 241/308

241