Jump to content
InfoFile
Tác giả: qh2qa06
Bài viết gốc: 405132
Tên lệnh: ddo
Lisp tính cao độ khi biết cao độ và độ dốc

Những kiến thức chuyên sâu thế thì em không xử lý được. Lisp  anh sửa cho em dùng không bị lỗi thế rồi.

Em cảm ơn...

>>

Những kiến thức chuyên sâu thế thì em không xử lý được. Lisp  anh sửa cho em dùng không bị lỗi thế rồi.

Em cảm ơn anh!

 

 

Thật ra không phải do lsp mà là do 2 cái pline của bạn có chiều dài khác nhau dù rất nhỏ. Bạn cho luprec = 8 rồi nhấp vào từng pline rồi ctr-1 sẽ thấy length khác nhau. Và vì vậy nên khi nhân độ dốc sẽ khác nhau (cũng do vấn đề làm tròn số) dù chỉ 1 mm.

Tôi sửa lại lsp để khử cái vụ chênh nhau 1 chút đó.

(defun c:ddo( / a b txt tt1 sole dd1 vt)
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (defun ator (a sl) (atof (rtos a 2 sl)))
  (setq a (getpoint "\nChon diem da biet cao do: ")
       txt (car (entsel "\nText cao do tuong ung: "))
       tt1 (dxf 1 txt)
       sole (if (setq vt (vl-string-search "." tt1)) (- (strlen (substr tt1 vt)) 2) 0)
       dd1 (getreal (strcat "\nNhap do doc (+ len; - xuong) <" (rtos (if (not dd) (setq dd 0.01) dd)) ">: ")))
 (if dd1 (setq dd dd1))
 (while (setq b (getpoint a "\nChon diem can tinh cao do: "))
  (entmake (list '(0 . "TEXT") (cons 10 b) (cons 11 b) (cons 40 (dxf 40 txt)) (cons 41 (dxf 41 txt))
 (cons 8 (dxf 8 txt)) (cons 62 (if (dxf 62 txt) (dxf 62 txt) 256))
 (cons 7 (dxf 7 txt)) (cons 72 (dxf 72 txt)) (cons 73 (dxf 73 txt)) '(50 . 0)
 (cons 1 (rtos (+ (atof (dxf 1 txt)) (ator (* dd (ator (distance a b) sole)) sole)) 2 sole))))
 )
 (princ)
)

 

Em muốn nhờ các chuyên gia, nếu bác Tot77 có vào đây giúp em càng tốt ạ. Lisp trên tính cho 1 điểm. Bây giờ em có nhiều điểm và muốn thiết kế cho một hệ thống lưới các điểm có cùng độ dốc.

Chi tiết em ghi rõ trong file đính kèm ạ. Em cảm ơn nhiều!

 

http://www.cadviet.com/upfiles/6/64018_tinh_cao_do_diem_theo_mat_luoi_cho_mot_nhom_diem.dwg


<<

Filename: 405132_ddo.lsp
Tác giả: vbao
Bài viết gốc: 3815
Tên lệnh: kbv
Để bản vẽ không thể sửa được
Tôi ngồi hì hụi làm 2 đêm thì được như thế này rồi, gửi anh em chỉnh giúp 1 số hạn chế sau:

 

(Defun c:KBV ()
(setvar "MODEMACRO" "KHOA BAN VE...
>>
Tôi ngồi hì hụi làm 2 đêm thì được như thế này rồi, gửi anh em chỉnh giúp 1 số hạn chế sau:

 

(Defun c:KBV ()
(setvar "MODEMACRO" "KHOA BAN VE TOAN DIEN")
 (command "-layer" "new" "DEFPOINTS" "color" "7" "DEFPOINTS" "")
(princ "\nPHAM QUOC DUY Binh Son - Quang ngai")
 (setq XX (ssget "x"))
(setq L 0)
(setq M (sslength XX))
(while (< L M)
  (setq DT (ssname XX L))
  (setq DTM (entget DT))
  (setq TEXT (cdr (assoc 10 DTM)))
  (setq LOP (cdr (assoc 8 DTM)))
  (setq TENLOP (TBLOBJNAME "LAYER" LOP))
  (setq DOCLOP (entget TENLOP))
  (setq MAULOP (cdr (assoc 62 DOCLOP)))
   ;(setq TEN (car DTM))
  (setq LM (+ L 356))
(luuos)
 (setvar "osmode" 0)
 (setq x (car TEXT))
 (setq y (cadr TEXT))
  (traos)
 (luuos)
 (setvar "osmode" 0)
 (command ".chprop" DT "" "COLOR" MAULOP "")
 (command ".chprop" DT "" "la" "DEFPOINTS" "")
 ;(command "TEXT" "c" (list (+ x 0)(- y 0)) 250 0 MAULOP)
 (command "BLOCK" LM (list (+ x 0)(- y 0)) DT "")
 (command "MINSERT" LM (list (+ x 0)(- y 0)) 1 1 0 2 2 0 0)

(traos)
  (setq L (1+ L))
)

(command "BLOCK" "$174270_59" (list 0 0) "ALL" "")
(command "MINSERT" "$174270_59" (list 0 0) 1 1 0 2 2 0 0)
(setvar "MODEMACRO" "**CHUC BAN LAM VIEC HIEU QUA** PHAM QUOC DUY - BINH SON - QUANG NGAI")
     (Princ)
)

Các nhược điểm tồn tại như sau:

Những đối tượng có màu không phải BYLAYER thì do chưa phân biệt được nên màu cũng bị chuyễn theo màu của lớp.

Tên các BLOCK do không lấy được tên của đối tượng nên phải tự đặt tên.

Các BLOCK có sẳn trong bản vẽ thì không chuyễn về lớp dẻpoint được.

Còn lại thì nói chung là nếu anh em nào vẽ màu theo lớp hết thì dùng nó khóa được rồi.

Nhớ sao lưu trước vì khi gỏ lệnh KBV là nó nát ten beng luôn. Thời gian chạy cũng hơi lâu, bản vẽ sẽ nặng gấp đôi.

sau khi song thi không in và không sửa được nửa.

 

sau khi test thử gặp lỗi sau :

 

Layer "DEFPOINTS" already exists.

Enter an option

: color

Enter color name or number (1-255): 7

Enter name list of layer(s) for color 7 (white) <GHICHU>: DEFPOINTS Enter an

option :

Command:

PHAM QUOC DUY Binh Son - Quang ngai; error: no function definition: LUUOS

 

Thanks


<<

Filename: 3815_kbv.lsp
Tác giả: vbao
Bài viết gốc: 9902
Tên lệnh: zz
nội suy cao độ tại giao điểm
Chương trình nội suy cao độ theo các đường đồng mức và/hoặc các điểm tham chiếu. Cung cách hoạt động đúng như ssg đã trình bày ở bài trước. Tên lệnh:...
>>
Chương trình nội suy cao độ theo các đường đồng mức và/hoặc các điểm tham chiếu. Cung cách hoạt động đúng như ssg đã trình bày ở bài trước. Tên lệnh: ZZ

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;
;;;This program interpolate elevation at 1 point-object
;;;from 2 equal level polylines and/or reference point-objects
;;;Elevation of each reference point-object is specified by nearest text_object
;;;Written by ssg - December 2007 - www.cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;

;;;--------------------------------------------------------------------
(defun mod(x y) (fix (rem x y)) ) ;;;Remainder result of divide, return INT
;;;--------------------------------------------------------------------
(defun wtxt (txt p / sty d h) ;;;Write txt at p
(setq
   sty (getvar "textstyle")
   d (tblsearch "style" sty)
   h (cdr (assoc 40 d))
)
(entmake (list (cons 0 "TEXT") (cons 7 sty) (cons 1 txt) (cons 10 p)
                      (if (> h 0) (cons 40 h) (assoc 40 d)) (assoc 41 d))
)
)
;;;--------------------------------------------------------------------
(defun ss2ent (ss / i Le e) ;;;Convert ss to list of ename
(setq i 0 Le nil)
(repeat (sslength ss) 
   (setq
       e (ssname ss i)
       Le (append Le (list e))
       i (1+ i)
   )
)
Le
)
;;;--------------------------------------------------------------------
(defun ss2Lp(ssp / Lp i e p) ;;;Convert ss of points to list of 3Dpoints
(setq i 0 Lp nil)
(repeat (sslength ssp) 
   (setq
       e (ssname ssp i)
       p (cdr (assoc 10 (entget e)))
       Lp (append Lp (list p))
       i (1+ i)
   )
)
Lp
)
;;;--------------------------------------------------------------------
(defun aver(Ln / tot x) ;;;Average List of Number
(setq tot 0)
(foreach x Ln (setq tot (+ tot x)))
(/ tot (length Ln))
)
;;;--------------------------------------------------------------------
(defun distance_xy (p1 p2) ;;;Distance between 2 projections of p1 and p2
(setq
   pp1 (list (car p1) (cadr p1) 0)
   pp2 (list (car p2) (cadr p2) 0)
)
(distance pp1 pp2)
)
;;;--------------------------------------------------------------------
(defun inter2p(p p1 p2) ;;;Interpolate zp from p1, p2
(setq
   d1 (distance_xy p p1)
   d2 (distance_xy p p2)
   z1 (caddr p1)
   z2 (caddr p2)
)
(/ (+ (* d1 z2) (* d2 z1)) (+ d1 d2))
)
;;;--------------------------------------------------------------------
(defun ariang(p1 p2 p3) ;;;Arithmetic Angle between 2 vector p1p2 and p2p3
(setq
   a1 (angle p2 p1)
   a2 (angle p2 p3)
)
(abs (- (abs (- a1 a2)) pi))
)
;;;--------------------------------------------------------------------
(defun pair(p Lp / Lpair Lpass p1 p2 ass chk x y)
;;;Arrange list of points Lp in pairs, opposite by p. Return list of pair_list
(setq Lpair nil)
(while Lp
   (setq
       p1 (car Lp)
       ass (lambda (x) (cons x (ariang p1 p x)))
       chk (lambda (x y) (< (cdr x) (cdr y)))
       Lpass (vl-sort (mapcar 'ass Lp) 'chk)
       p2 (car (car Lpass))
       Lpair (append Lpair (list (list p1 p2)))
       Lp (vl-remove p1 Lp)
       Lp (vl-remove p2 Lp)
   )
)
Lpair
)
;;;--------------------------------------------------------------------
(defun getZ(p sst) ;;;Get nearest text in sst, assign to zp
(setq
   Lt (ss2ent sst)
   neap (lambda (x y)
                (<
                (distance_xy p (cdr (assoc 10 (entget x))))
                (distance_xy p (cdr (assoc 10 (entget y))))
                )
            )
   Lt (vl-sort Lt 'neap)
   z (atof (cdr (assoc 1 (entget (car Lt)))))
   p (subst z (caddr p) p)
)
)
;;;--------------------------------------------------------------------
(defun placp(pl p / pp) ;;;Check pl across p, different z
(vl-load-com)
(setq pp (vlax-curve-getClosestPointTo pl p))
(and (= (car p) (car pp)) (= (cadr p) (cadr pp)))
)
;;;--------------------------------------------------------------------
;;;MAIN PROGRAM
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;
(defun C:ZZ(/ oldos p Ln Lpp res sspl pl1 pl2 pp1 pp2 v1 ssp sst Lp x)

;;;INPUT DATA
(setq oldos (getvar "osmode"))
(setvar "osmode" 8)
(setq
   p (getpoint "\nBase point:")
   Ln nil Lpp nil res nil
)
(setvar "osmode" 0)
(prompt "\nSelect 2 Equal Level Polylines or <Enter for none>...")
(setq sspl (ssget '((0 . "LWPOLYLINE"))))

;;;INTERPOLATE FROM EQUAL LEVEL PLINE
(if (and sspl (setq pl1 (ssname sspl 0) pl2 (ssname sspl 1))) (progn
   (vl-load-com)
   (setq
       pp1 (vlax-curve-getClosestPointTo pl1 p)
       pp2 (vlax-curve-getClosestPointTo pl2 p)
   )
   ;;;If pline across p then write result and exit
   (if (and (= (car p) (car pp1)) (= (cadr p) (cadr pp1))) (setq res (caddr pp1)))
   (if (and (= (car p) (car pp2)) (= (cadr p) (cadr pp2))) (setq res (caddr pp2)))
   (if res (progn
       (alert "The polyline across the point")
       (wtxt (rtos res) p)
       (setvar "osmode" oldos)
       (princ)
       (exit)
   ))
   ;;;Else continue...
   (setq
       v1 (inter2p p pp1 pp2)
       Ln (append Ln (list v1))
   )
))

;;;INTERPOLATE FROM REFERENCE POINTS
(prompt "\nSelect Reference Points or <Enter for none>...")
(if (and (setq ssp (ssget '((0 . "POINT"))))
            (setq sst (ssget "X" '((0 . "TEXT"))))
   )
   (progn
       (setq Lp (vl-remove p (ss2Lp ssp)))
       (if (/= (mod (length Lp) 2) 0)
           (progn
               (alert "Number of reference points must be in Even (n = 2k). Action is canceled!")
               (exit)
           )
           (progn
               (foreach x Lp (setq Lp (subst (getZ x sst) x Lp)))
               (setq Lpp (pair p Lp))
               (foreach x Lpp (setq Ln (append Ln (list (inter2p p (car x) (cadr x))))))
           )
       )
   )
)

;;;WRITE RESULT
(if Ln (wtxt (rtos (aver Ln)) p))
(setvar "osmode" oldos)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;

 

Thuyết minh hoạt động của chương trình:

1) Nội suy theo đường đồng mức: từ điểm đang xét, kẻ 2 đường vuông góc (theo mặt bằng) với 2 đường đồng mức. Sau đó thực hiện nội suy theo công thức:

Z = (d1*Z2 + d2*z1) / (d1 + d2), không quan tâm đến 3 điểm có thẳng hàng hay không.

 

2) Nội suy theo các cặp điểm tham chiếu:

Công thức nội suy vẫn như trên. Yêu cầu tổng số điểm chọn, trừ điểm đang xét, phải là số chẵn. Nếu không, chương trình sẽ ra thông báo và sau đó exit.

Xem ra cũng khá dài dòng vì để lấy được dữ liệu của 1 điểm phải cần đến 2 đối tượng khác loại nhau (lấy X, Y từ point và lấy Z từ text). Trong 2 thành phần đó, chương trình dựa vào point là chính. Độ cao Z được lấy theo đối tượng text gần nhất so với point. Lưu ý: điểm chuẩn của text đối với chương trình là điểm insert của nó. Do đó, trong các vùng phức tạp, mật độ text dày đặc, có khả năng gặp phải trường hợp “râu ông nọ cắm cằm bà kia”! Nếu có thể, nên chuyển điểm insert của text về trùng (x, y) với đối tượng point mà nó biểu diễn để bảo đảm cho chương trình chạy chính xác.

 

3) Theo mình, các bản vẽ đã “lỡ có” rồi thì thôi. Nhưng khi lập bản vẽ mới, nên có quy ước nhất quán sẽ tạo điều kiện thuận lợi hơn cho lập trình khi cần. Chẳng hạn, cách ghi text và point, nếu bảo đảm được 1 trong 2 điều kiện sau thì chương trình này sẽ đơn giản hơn rất nhiều, và hoàn toàn không phải bận tâm đến vấn đề nêu trên:

- Các đối tượng point được vẽ đúng độ cao z (giống như các pline đồng mức).

- Các đối tượng text có điểm insert đúng tọa độ x, y của point

 

Vbao xem và test trong nhiều trường hợp khác nhau. Nếu có vấn đề gì thì phản hồi, mình sẽ sửa và bổ sung.

 

chân thành cảm ơn anh ssg, chương trình chạy rất tốt :)


<<

Filename: 9902_zz.lsp
Tác giả: dnhqs
Bài viết gốc: 17256
Tên lệnh: chia
cắt pline thành các đoạn theo chiểu dài chọn

16h ~ 100 dòng code, vị chi là 16*60/100 = mất 9.6 phút cho 1 dòng code, hơi bị lâu hén. Đùa tí thôi, định trả lời bài này giống vndesperados, nhưng vndes đã trả lời...
>>
16h ~ 100 dòng code, vị chi là 16*60/100 = mất 9.6 phút cho 1 dòng code, hơi bị lâu hén. Đùa tí thôi, định trả lời bài này giống vndesperados, nhưng vndes đã trả lời vậy rồi, mình trả lời giống lại thành spam bài kiểu Jikibo. Đành phải trả lời khác vậy.

 

Lệnh CHIA dưới đây sẽ làm điều dnhqs muốn (measure sau đó thì break một cách tự động):

(defun c:chia( / ent kc oldos)
 (defun findp(ent)
   (vlax-curve-getPointAtDist ent kc)
 )
 (setq ent (car (entsel "\nVao doi tuong: "))
kc (getdist "\nVAo khoang cach: ")
oldos (getvar "osmode")
 )
 (setvar "osmode" 0)
 (while (and (setq p (findp ent)) (not (equal p oldp 0.01)))
   (command ".break" ent p p)
   (setq ent (entlast)
  oldp p)
 )
 (setvar "osmode" oldos)
 (princ)
)

 

hổng chịu chạy

 

Command: ap

APPLOAD ChiaPLine.lsp successfully loaded.

 

 

Command:

Command:

Command: chia

 

Vao doi tuong:

VAo khoang cach: 200

; error: no function definition: VLAX-CURVE-GETPOINTATDIST

 

Command:

Command:


<<

Filename: 17256_chia.lsp
Tác giả: leejang
Bài viết gốc: 141410
Tên lệnh: dc
lisp đổi màu tất cả các đường DIM ?

Tự động cắt cút chận dim thì chắc là không có, chỉ thiếu cái chân dim chưa có màu 30 thôi :) Bạn sửa lại như vầy :

>>

Tự động cắt cút chận dim thì chắc là không có, chỉ thiếu cái chân dim chưa có màu 30 thôi :) Bạn sửa lại như vầy :

(defun c:dc()(setvar "dimclrt" 2)(setvar "dimclrd" 30)(setvar "dimclre" 30)(command "-dimstyle" "a" "all" ""))]

Hic. Bác kiểm tra lại giúp em. Nó tự động CUT chân dim cụt hết đi mà ? Đây là file ví dụ, khi mở file mới thì nó đổi màu ko cut chân DIM, nhưng khi chạy trên file cũ thì nó cut hết chân dim ?

http://www.cadviet.com/upfiles/3/vi_du_4.dwg


<<

Filename: 141410_dc.lsp
Tác giả: tuvanthietke.hcm
Bài viết gốc: 118378
Tên lệnh: mcc
Tổng hợp LISP và nhờ các cao thủ CHỈNH SỬA
Mình sửa cho bạn đây. Bạn xem có vừa ý không nhé.

;;LE QUOC VIET 2/8/2002
; CHUONG TRINH VE MC COT
(defun c:MCC (/ A B C BV D E D1 E1 F P1 P2)
      ...
>>
Mình sửa cho bạn đây. Bạn xem có vừa ý không nhé.

;;LE QUOC VIET 2/8/2002
; CHUONG TRINH VE MC COT
(defun c:MCC (/ A B C BV D E D1 E1 F P1 P2)
       (vl-load-com)
(setq oldosmode (getvar "osmode"))
       (setvar "osmode" 0)
       (setq 
	A (getreal "\nBe rong mc cot:")
	B (getreal "\nBe dai mc cot:")
	BV (getreal "\nLop bv mc cot:")
	D (getint "\nS.luong thep ngang mc cot:")
	E (getint "\nS.luong thep doc mc cot:")
	P1 (getpoint  "\nDiem chen:")
               F (* BV 0.7)
		D1 (/ (- A (* 2 BV) (* F 2)) (- D 1))
	E1 (/ (- B (* 2 BV) (* F 2)) (- E 1))
       ); end of setq
(command ".rectangle" "f" "0" P1 (list (+ (car P1) A) (+ (cadr P1) :iluvyousmiley:) ""
	".offset" BV (ssget P1) (list (+ (car P1) BV) (+ (cadr P1) BV)) ""
       )
       (setq ver (acet-geom-vertex-list (entlast)))
       (entdel (entlast))
       (command ".rectangle" "f" (* bv 0.7) (car ver) (caddr ver)
        ".change" (entlast) "" "P" "C" 1 ""
       ); end of command
       (setq 	P2 (list (+ (car P1) BV F) (+ (cadr P1) BV F)))
    	(repeat D 
	(command ".donut" 0 F P2 ^C)
       	(setq P2 (polar P2 0 D1))
     	); end of repeat1
       (setq 	P2 (list (+ (car P1) BV F) (+ (cadr P1) (- B BV F) )))
    	(repeat D 
	(command ".donut" 0 F P2 ^C)
       	(setq P2 (polar P2 0 D1))
     	); end of repeat2
       (setq 	P2 (list (+ (car P1) BV F) (+ (cadr P1) BV F)))
       (repeat (- E 2)
      		(setq P2 (polar P2 (/ pi 2)  E1))
	(command ".donut" 0 F P2 ^C)
       ); end of repeat3
 	(setq 	P2 (list (+ (car P1) (- A BV F)) (+ (cadr P1) BV F)))
	(repeat (- E 2)
      		(setq P2 (polar P2 (/ pi 2)  E1))
	(command ".donut" 0 F P2 ^C)
       ); end of repeat3
(setvar "osmode" oldosmode)
); end of ve mc cot

 

Không thể hay hơn

 

Tiếp là lisp vẽ mặt cắt ngang dầm http://www.mediafire.com/?vf5jd4ik9p50sb8

 

11192010101539pm.png

 

À tiện thể cho hỏi luôn làm sao chèn file lên diễn đàn

 

Chỉnh giúp lisp đẹp như hình vẽ


<<

Filename: 118378_mcc.lsp
Tác giả: tientracdia
Bài viết gốc: 229554
Tên lệnh: kk
Lisp up nội dung từ Excel vào Cad

 

Thêm 1 Lisp nữa cho bạn đây.

>>

 

Thêm 1 Lisp nữa cho bạn đây.

http://www.cadviet.com/upfiles/3/71162_update_so_lieu_tu_excel_vao_cad.lsp

Lệnh KK nhé. Sau đó chọn file số liệu (chuyển sang dạng txt ngăn cách bởi dấu tab hoặc space) rồi chọn số liệu trên bản vẽ.

Tuy nhiên để chạy lisp này thì bạn copy file sau đây vào thư mục Support trong CAD

http://www.cadviet.com/upfiles/3/71162_a.dwg

;========LISP UPDATE SO LIEU TU FILE TXT VAO CADU==========
;================KANGKUNG 25/03/2013=======================
(defun C:KK()
  (command "UNDO" "BE")
  (setq os(getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (if (not Path)
    (setq Path(getvar "dwgprefix")))
  (setq file(getfiled "Select File:" Path "txt" 2))
  (setq Path file)
  (setq taphop(ssget '((0 . "TEXT"))))
  (setq index 0)
  (setq TEXT_LIST (list))
  (while (< index (sslength taphop))
    (setq TEXT (entget (ssname taphop index)))
    (if (/= (read (cdr(assoc 1 TEXT))) (atof (cdr(assoc 1 TEXT))))
      (progn
	(setq String(cdr(assoc 1 TEXT)))
	(if (= (+ (cdr(assoc 72 TEXT)) (cdr(assoc 73 TEXT))) 0)
	  (setq InsertPoint(cdr(assoc 10 TEXT)))
	  (setq InsertPoint(cdr(assoc 11 TEXT)))
	  )
	(setq TEXT_LIST (append (list (list String InsertPoint)) TEXT_LIST))
	)
      )
    (setq index (1+ index))
    )
  (setq file_in(open file "R"))
  (setq lst_solieu(list))
  (while(setq txt(read-line file_in))
    (if (/= txt nil) (setq lst (read (strcat "(" txt ")"  ))))
    (foreach dt TEXT_LIST
      (if (= (car dt) (vl-princ-to-string(car lst)))
	(command "insert"  "a"  (cadr dt)  "1" "1" "0"
		   (vl-princ-to-string(car lst))
		   (vl-princ-to-string(cadr lst))
		   (vl-princ-to-string(caddr lst))
		   (vl-princ-to-string(cadddr lst)))
	)
      )
    )
  (COMMAND "ERASE" TAPHOP "")
  (close file_in)
  (setvar "OSMODE" os)
  )
(princ "\n                Written By KangKung - 25/03/2013\n")
(princ "\n                  Nhap KK de chay chuong trinh\n")

Lisp của bạn thì xuất nội dung thuộc tính cần phải nhập vào riêng từng ô thì quá lâu khi mình sửa. Mong bạn xem giúp lại.

Mình muốn quét tất cả các ô, chọn file excel, *.cvs hay *.txt dựa vào tên ô và lisp thay thế vào các ô Cad hàng loat.

Rất mong được sự giúp đỡ. CÁm ơn nhiều.


<<

Filename: 229554_kk.lsp
Tác giả: danhgapro
Bài viết gốc: 404933
Tên lệnh: dtc
Lisp Tính Diện Tích Text, Số

 

Cái lisp này viết lâu rồi, chắc vẫn còn xài được. Cad phải có cài Express.

(defun c:dtc (/ v0 el en...
>>

 

Cái lisp này viết lâu rồi, chắc vẫn còn xài được. Cad phải có cài Express.

(defun c:dtc (/ v0 el en l tong oe nd)
  (setq oe (getvar 'cmdecho))
  (setvar 'cmdecho 0)
  (command "undo" "be")
  
  (setq v0 (car (entsel "\nChon text de tinh dien tich:"))
nd (cdr (assoc 1 (entget v0))))
  (command "copy" v0 "" "" "")  
  (setq el (entlast)
l nil)
  (sssetfirst nil (ssadd v0 (ssadd)))
  (C:Txtexp)
  
  (setq tong 0)
  (while (setq en (entnext el)) (setq l (cons en l) el en))
  (foreach v (vl-remove-if-not '(lambda(x) (= "POLYLINE" (cdr (assoc 0 (entget x))))) l)
    (setq tong (+ tong (vla-get-Area (vlax-ename->vla-object v))))
    (entdel v))
  
  (command "undo" "e")  
  (setvar 'cmdecho oe)
  (princ (strcat "\nDien tich cua chu \"" nd "\" la: " (rtos tong))) (textscr) (princ)
)

Bạn kiểm tra lại giúp mình, mình dùng lisp tính thử với bo nét chữ không đúng. (đã cài Express).

Bài toán là: mình cần tính diện tích sơn, in chữ biển báo, VD "ĐI CHẬM", mình tính diện tích chữ Đ, I, C.....

Cảm ơn bạn. 


<<

Filename: 404933_dtc.lsp
Tác giả: qh2qa06
Bài viết gốc: 304603
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...
>>

 

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)
)

Cảm ơn bạn đã giúp nhưng mấy lisp bạn đưa mình đều không dùng được. Dùng lisp đầu tiên báo lỗi như sau:

Chieu cao text <1.00> : ; error: no function definition: _LAYER2

 

Mình cần một lisp hỗ trợ tính như file sau:

http://www.cadviet.com/upfiles/3/64018_cd_diem_can_noi_suy.doc

File CAD mình đã up ở đầu topic!

Nhờ các bạn giúp đỡ! Cảm ơn nhiều!


<<

Filename: 304603_clt.lsp
Tác giả: tien2005
Bài viết gốc: 423492
Tên lệnh: sd2
LISP CẮT DIM ĐO ĐOẠN CUNG TRÒN

Bạn dùng thử xem co được  không. Lệnh là SD2

(vl-load-com)
(defun c:sd2 (/ lstd en hd objTStyle objDoc tstyle m)
  (setvar "cmdecho" 0)

  (princ "\nChon cac DIM can sap xep")
  (setq	lstd (vl-remove-if
	       'listp
	       (mapcar 'cadr (ssnamex (ssget '((0 . "DIMENSION")))))
	     )
  )
  (setq m (getreal "\nHe so nhan: "));dung de chinh chieu dai chan dim theo ty le chieu cao text
  (setq
...
>>

Bạn dùng thử xem co được  không. Lệnh là SD2

(vl-load-com)
(defun c:sd2 (/ lstd en hd objTStyle objDoc tstyle m)
  (setvar "cmdecho" 0)

  (princ "\nChon cac DIM can sap xep")
  (setq	lstd (vl-remove-if
	       'listp
	       (mapcar 'cadr (ssnamex (ssget '((0 . "DIMENSION")))))
	     )
  )
  (setq m (getreal "\nHe so nhan: "));dung de chinh chieu dai chan dim theo ty le chieu cao text
  (setq
    en	      (vlax-ename->vla-object (car lstd))
    tstyle    (vla-get-textstyle en)
    objDoc    (vla-get-activedocument (vla-get-application en))
    objTStyle (vla-item (vla-get-textstyles objdoc) tstyle)
    hd	      (vla-get-height objTStyle)
  )
  (if (= hd 0.0)
    (setq hd (vla-get-Textheight en))
  )
  (foreach e1 lstd
    (setq en (vlax-ename->vla-object e1))
    (vla-put-extlinefixedlensuppress en :vlax-true)
    (vla-put-extlinefixedlen en (* m hd))
  )
  (princ)
)

 


<<

Filename: 423492_sd2.lsp
Tác giả: tientracdia
Bài viết gốc: 230098
Tên lệnh: kk
Nhờ viết lisp lọc các đối tượng là text trong một vùng kín xuất ra Excel

 

Lisp của bạn đây. Vùng kín hay hở đều chơi hết.File xuất ra gồm có STT X Y và nội dung Text

>>

 

Lisp của bạn đây. Vùng kín hay hở đều chơi hết.File xuất ra gồm có STT X Y và nội dung Text

;========LISP OUTPUT TEXT BEN TRONG PLINE==========
;=============KANGKUNG 28/03/2013==================
(defun C:KK()
  (setq plst (acet-geom-vertex-list (car (entsel "\n Select pline:\n"))))
  (setq plst1 (vl-sort plst '(lambda (e1 e2) (if (/= (car e1) (car e2)) (< (car e1) (car e2)) (< (cadr e1) (cadr e2))))))
  (setq X_min(car (nth 0 plst1))
	X_max(car (last plst1)))
  (setq plst2 (vl-sort plst '(lambda (e1 e2) (if (/= (cadr e1) (cadr e2)) (< (cadr e1) (cadr e2)) (< (car e1) (car e2))))))
  (setq Y_min(cadr (nth 0 plst2))
	Y_max(cadr (last plst2)))
  (command "ZOOM" (list X_min Y_min) (list X_max Y_max))
  (setq taphop (ssget  "CP" plst '((0 . "TEXT"))))
  (if (not Path) (setq Path(getvar "dwgprefix")))
  (setq file(getfiled "Output File" Path "csv" 11) Path file)
  (setq file_out(open file "W"))
  (setq index 0)
  (while (< index (sslength taphop))
    (setq TEXT (entget (ssname taphop index)))
    (if (= (+ (cdr(assoc 72 TEXT)) (cdr(assoc 73 TEXT))) 0)
      (setq InsertPoint(cdr(assoc 10 TEXT)))
      (setq InsertPoint(cdr(assoc 11 TEXT))))
    (setq String(cdr(assoc 1 TEXT)))
    (write-line (strcat (rtos (+ index 1) 2 0) "," (rtos (car InsertPoint) 2 3) "," (rtos (cadr InsertPoint) 2 3) "," String) file_out)
    (setq index (+ index 1))
    )
  (close file_out)
  (alert "Well done!")
  )
(princ "\n         Written By KangKung - 28/03/2013\n")
(princ "\n           Nhap KK de chay chuong trinh\n")

Cám ơn bạn KangKung về Lisp trên,

Mính có một file tọa độ điểm gồm : lớp điểm ( dạng point )  là tọa độ x,y ; lớp Số thứ tụ điểm, lớp cao độ , lớp code dạng ghi chú về điểm đó ( dạng text),

Xin  nhờ Bạn giúp mình Lisp xuất :  điểm point , text ra excel theo từng điểm theo hàng như sau : Số thứ tụ điểm đó - tọa độ X - tọa độ Y - Ghi chú. ( X,Y theo điểm point ).

File gởi kèm

http://www.cadviet.com/upfiles/3/114381_xuat_ra_excel.dwg

Cám ơn


<<

Filename: 230098_kk.lsp
Tác giả: proconeng86
Bài viết gốc: 242138
Tên lệnh: chatt
Lisp đánh số thứ tự vào phần text của các block attribute

 

Hề hề hề,

Đồng ý với ý kiến của bác, song bác cho mình một ít thời gian để sửa nhé. Rất cám ơn về món...

>>

 

Hề hề hề,

Đồng ý với ý kiến của bác, song bác cho mình một ít thời gian để sửa nhé. Rất cám ơn về món quà bác biếu....

Hề hề hề,..

 

Và nó dây ạ:

(defun c:chatt (/ oldos bln ssbl atn n k i a j  ans att atlst atv pre num)(vl-load-com)(command "undo" "be")(setq oldos (getvar "osmode"))(setvar "osmode" 0)(setq bln (cdr (assoc 2 (entget (car (entsel "\n Chon block mau can thay doi gia tri thuoc tinh"))))))(setq ssbl (acet-ss-to-list (ssget (list (cons 0 "insert") (cons 2 bln) (cons 66 1)))))(if ssbl       (progn              (setq atn (cdr (assoc 2 (entget (car (nentsel "\n Chon thuoc tinh can thay doi gia tri ")))))                      n (getint "\n Nhap so ky tu can giu cua gia tri thuoc tinh: ")                                          k (getint "\n Nhap so ky tu bieu dien so: ")                      i (getint "\n Nhap so bat dau danh so: ")                      a (getreal "\n Nhap gia so: ")                      j 0 )              ;;;;(if (> k 4) (setq k 4))                   (if (= atn "") (setq atn bln))              (setq ans (getstring t "\n Ban muon danh so theo chieu thuan <y or n>: "))              (if (= (strcase ans) "Y")                  (setq ssbl (vl-sort ssbl '(lambda (x y) (< (cadr (assoc 10 (entget x))) (cadr (assoc 10 (entget y)))))))                  (setq ssbl (vl-sort ssbl '(lambda (x y) (> (cadr (assoc 10 (entget x))) (cadr (assoc 10 (entget y)))))))              )              (foreach bl ssbl                      (setq att (entnext bl))                      (while (/= (cdr (assoc 0 (entget att))) "SEQEND")                               (setq atlst (entget att))                               (if (= (cdr (assoc 2 atlst)) (strcase atn))                                   (progn                                          (setq atv (cdr (assoc 1 atlst))                                                  pre (substr atv 1 n)                                                  num (rtos (+ i (* j a)) 2 0))                                          ;;;(if (and (= (strlen num) 1) (= k 4)) (setq num (strcat "000" num)))                                          ;;;(if (and (= (strlen num) 2) (= k 4)) (setq num (strcat "00" num)))                                          ;;;(if (and (= (strlen num) 3) (= k 4)) (setq num (strcat "0" num)))                                          ;;;(if (and (= (strlen num) 1) (= k 3)) (setq num (strcat "00" num)))                                          ;;;(if (and (= (strlen num) 2) (= k 3)) (setq num (strcat "0" num)))                                          ;;;(if (and (= (strlen num) 1) (= k 2)) (setq num (strcat "0" num)))                                          (if (< (strlen num) k)                                              (setq num (repeat (- k (strlen num)) (setq num (strcat "0" num))))                                          )                                          (setq atlst (subst (cons 1 (strcat pre num)) (assoc 1 atlst) atlst))                                          (entmod atlst)                                                                                    (setq j (1+ j))                                    )                                 )                                 (setq att (entnext att))                      )              )         ))(command "regenall")(setvar "osmode" oldos)(command "undo" "e")(princ))

sao mình down về mà ko dùng được nhỉ, nó báo lỗi là "Command: nil

Command: UNDO Current settings: Auto = On, Control = All, Combine = Yes, Layer 
= Yes
Enter the number of operations to undo or  

<1>: END"

rồi sau đó gõ lệnh thì nó báo là không có lệnh đó, bạn xem lại cái


<<

Filename: 242138_chatt.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 275867
Tên lệnh: ha
Xin lisp lấy màu đối tượng

 

Ví dụ thế này chăng?

 

(defun C:HA()
 (vl-load-com)
 (acad_colordlg (vlax-get...
>>

 

Ví dụ thế này chăng?

 

(defun C:HA()
 (vl-load-com)
 (acad_colordlg (vlax-get (vlax-ename->vla-object (car (entsel))) 'Color)))
 

Hề hề hề,

Hay là cái ni nhể:

(defun c:getcol (/ col)

(setq col (cdr (assoc 62 (entget (car (entsel "\n chon doi tuong can xac dinh mau"))))))

(alert (strcat "\n Doi tuong co mau so: " (if col (rtos col 2 0) "256"))))


<<

Filename: 275867_ha.lsp
Tác giả: bach1212
Bài viết gốc: 183499
Tên lệnh: ha
Lisp di chuyển text của dim
Tôi nhớ là đã viết giùm bạn nào đó cái y/c này rồi nhưng bây giờ mò đường link không ra nên đành post lên lại cho bạn vậy.
>>
Tôi nhớ là đã viết giùm bạn nào đó cái y/c này rồi nhưng bây giờ mò đường link không ra nên đành post lên lại cho bạn vậy.
 ;Doan Van Ha - CADViet.com. Xuat Text, Mtext, Dimension ra file. (defun C:HA( / lst fn fw index x y z txt) (princ "\nChon cac Text/Mtext/Dimension can xuat ra file...") (setq lst (acet-ss-to-list (ssget '((0 . "*TEXT,DIMENSION")))) fn (getfiled "Chon file de save" "" "csv" 1) fw (open fn "w") index 0 x 1 y 1 z 1) (repeat (length lst) (cond ((= (cdr (assoc 0 (entget (nth index lst)))) "TEXT") (setq txt (strcat (cdr (assoc 1 (entget (nth index lst)))) "," "text" (itoa x)) x (1+ x))) ((= (cdr (assoc 0 (entget (nth index lst)))) "MTEXT") (setq txt (strcat (cdr (assoc 1 (entget (nth index lst)))) "," "mtext" (itoa y)) y (1+ y))) ((= (cdr (assoc 0 (entget (nth index lst)))) "DIMENSION") (if (= (cdr (assoc 1 (entget (nth index lst)))) "") (setq txt (strcat (rtos (cdr (assoc 42 (entget (nth index lst))))) "," "dim" (itoa z)) z (1+ z)) (setq txt (strcat (cdr (assoc 1 (entget (nth index lst)))) "," "dim" (itoa z)) z (1+ z))))) (princ (strcat txt "\n") fw) (setq index (1+ index))) (close fw)) 

Lisp của bạn rất tuyệt

Mình thử dùng "ha" cho các text có nội dung như này: D400,L30. Nó là đường kính cống tròn và chiều dài của nó.Cũng xuất ra được excel gồm 2 cột là 2 text D400 và L30

Bạn có cách nào lọc được các số 30 sau chữ L rồi tính tổng của chúng => kết quả vừa hiện trên dòng command vừa có lựa chọn thay vào 1 text có sẵn trên bản vẽ luôn không?

Giúp mình với. Mình cần lấy tổng chiều dài của nhiều đoạn cống đã được ghi chú như thế mà không phải cộng tay từng đoạn một.Thanks trước nhé


<<

Filename: 183499_ha.lsp
Tác giả: haanh
Bài viết gốc: 56577
Tên lệnh: rep
Hỏi cách chuyển đổi vị trí tọa độ đầu cuối của 1 polyline
Có thể Doanduyhung lấy ví dụ không điển hình nên mọi người đã hiểu nhầm. Trong một số trường hợp, chiều của polyline (liên quan đến điểm xuất phát của...
>>
Có thể Doanduyhung lấy ví dụ không điển hình nên mọi người đã hiểu nhầm. Trong một số trường hợp, chiều của polyline (liên quan đến điểm xuất phát của polyline) là quan trọng. Với polyline chỉ gồm 2 điểm thì đơn giản là rotate 180 độ tại trung điểm là coi như xong. Nhưng với polyline có nhiều điểm hơn thì không làm được như vậy, nếu rotate (hay align) thì chiều polyline thay đổi nhưng kéo theo các đỉnh cũng bị dịch chuyển so với hình gốc.

 

Các bạn thử dùng lisp này xem sao. Lệnh là REP (REverse Polyline)

(defun c:rep( / c10 tt)
 (setq 
tt (entget (car (entsel "\nHay pick vao mot Polyline: ")))
c10 (reverse (vl-remove-if '(lambda (x) (/= (car x) 10)) tt))
tt (mapcar '(lambda (x) (if (= 10 (car x)) (setq e (car c10) c10 (cdr c10) e e) x)) tt)
 )
 (entmod tt)
 (princ)
)
(vl-load-com)

Lisp này chỉ áp dụng cho các polyline không chứa arc.

Em thấy ý kiến của bác Hoành hoàn toàn hợp lý vì bác đưa ra trường hợp tổng quát chung cho mọi trường hợp. Vì bác doanduyhung chỉ đưa ra 1 trường hợp cụ thể nên em cũng ... thú thực với bác là ăn nói chưa được tổng hợp ...có gì ko phải bác bỏ qua cho em nhá! Em xin cảm ơn bác và sẽ rút kinh nghiệm trước khi nhận xét đáng giá một việc gì đó!


<<

Filename: 56577_rep.lsp
Tác giả: Danh Cong
Bài viết gốc: 423524
Tên lệnh: cong
Chuyển đường nét, màu sắc đối tượng theo mã màu, mã đường nét của layer hiện hành

Đoạn code lấy đường nét và màu sắc : 


(defun c:CONG ( / layer Color Ltype)
  (setq Layer (getvar "Clayer"))
  (setq Color (cdr (assoc 62 (Tblsearch "LAYER" layer)))
    Ltype (cdr (assoc 6  (Tblsearch "LAYER" layer))))
  (princ))


Filename: 423524_cong.lsp
Tác giả: gia_bach
Bài viết gốc: 111424
Tên lệnh: chutoso
chuyển chữ thành số
Dạo này ít người yêu cầu viết lisp quá nên mình viết nghịch chơi cái lisp này.

Ngày xưa các bác chắc cũng từng thương thầm chộm nhớ một người nào...

>>
Dạo này ít người yêu cầu viết lisp quá nên mình viết nghịch chơi cái lisp này.

Ngày xưa các bác chắc cũng từng thương thầm chộm nhớ một người nào đấy. Muốn viết thư cho người ta mà lại e ngại không biết ý người ta thế nào.

Thế là các bác này nghĩ ra cái chò viết thư bằng số.

Ý nghĩa là nếu người ta có thích mình thì sẽ tìm cách mày mò để dịch (điều này kiểm tra luôn IQ của người đó). Nếu người đó không thích mình thì vèo một cái bay vào sọt rác.

Code đây (dành cho các bác nhát gan). Chú ý chữ để dịch phải không có dấu.

;; free lisp from cadviet.com
(defun c:chutoso()
.............................

Cậu này nhát gan quá, phải tự tin khi viết thư cho ngừoi ấy chứ.

Phòng khi đằng ấy hỏi "mật mã", Bác làm ơn cho 1 Lisp So2Chu (để dịch nguợc í mà).


<<

Filename: 111424_chutoso.lsp
Tác giả: mrphuocvie
Bài viết gốc: 393977
Tên lệnh: mc
Chuyển Dtext Thành Mtext Và Setp Justify Cho Mtext Vừa Chuyển
(defun c:mc()
	(setq ss (ssget '((0 . "*TEXT"))))
	(foreach en (acet-ss-to-list ss)
		(command "_txt2mtxt" en "")
		(acet-tjust en "MC"); set justify cho Mtext vua moi chuyen thanh
		)
)

Em tìm thấy code chuyển Dtext thành Mtext, nhưng em không tìm thấy nút để trả lời bên topic đó nên mạo mụi tạo topic này.

Tình hình là em muốn setup justify cho Mtext vừa được tạo ra nhưng làm hoài...

>>
(defun c:mc()
	(setq ss (ssget '((0 . "*TEXT"))))
	(foreach en (acet-ss-to-list ss)
		(command "_txt2mtxt" en "")
		(acet-tjust en "MC"); set justify cho Mtext vua moi chuyen thanh
		)
)

Em tìm thấy code chuyển Dtext thành Mtext, nhưng em không tìm thấy nút để trả lời bên topic đó nên mạo mụi tạo topic này.

Tình hình là em muốn setup justify cho Mtext vừa được tạo ra nhưng làm hoài không được. Nhờ mọi người sửa giúp!

Cảm ơn!

(defun c:mc()
    (setq ss (ssget '((0 . "*TEXT"))))
    (foreach en (acet-ss-to-list ss)
        (command "_txt2mtxt" en "")
        (acet-tjust en "MC"); set justify cho Mtext vua moi chuyen thanh
        )
)


<<

Filename: 393977_mc.lsp
Tác giả: thanhduan2407
Bài viết gốc: 102022
Tên lệnh: rft
lisp Phun tọa độ các điểm từ file txt vào CAD
Bạn cần sửa hàm SPLIT để đổi giá trị Code thành kiểu String.

(defun c:RFT(/ data ten f h line str Code Stt X Y Z ELE Code Code1 Pnt);;;;;Read...
>>
Bạn cần sửa hàm SPLIT để đổi giá trị Code thành kiểu String.

(defun c:RFT(/ data ten f h line str Code Stt X Y Z ELE Code Code1 Pnt);;;;;Read File Txt
(vl-load-com)
(defun Split (Str Char / Lst str pos)
 (while (setq pos (vl-string-search Char Str))
   (if (null Lst)
     (setq Lst (list (substr Str 1 pos)))
     (setq Lst (append Lst (list (read (substr Str 1 pos))))))
   (setq Str (substr Str (+ pos 2)) ))
 (setq Lst (append Lst (list Str)))  )  

 (if (setq ten (getfiled "Chon File txt" (getvar "dwgprefix") "txt" 8))
   (progn
     (setq f (open (findfile ten) "r"))
     (while
(setq Line (read-line f))	
(if (vl-string-search "\t" Line)
  (progn
    (setq data (split Line "\t" ))
    (setq Stt (nth 0 data))
    (setq X (nth 1 data))
    (setq Y (nth 2 data))
    (setq Z (nth 3 data))
    (setq Code (nth 4 data))	    
    (setq ELE (rtos z 2 2))
    (setq Pnt (list X Y Z))	    
    (command "insert"  "D_chitiet"  Pnt  1 1 0  Stt  ELE Code)	    ) ) ) ) )
 (command "zoom" "extents")
 (princ)
 )

Đã kiểm tra với dữ liệu :

1 4.376 5.577 12.000 123

2 3.576 3.777 10.000 abc

0 4.176 5.577 13.000 444

a 3.876 3.977 10.000 ddd

Chú ý : thêm dòng (setvar "AttReq" 1) vào Lisp nếu cần thiết.

Bác à! Nếu cháu có file txt mà các phần tử được phân biệt bởi nhiều dấu cách, hoặc nhiều dấu Tab hoặc nhiều sổ phẩy thì phải làm thế nào hả bác. Nếu trên mộ t dòng có cả dấu cách, dấu Tab, dấu phẩy thì phải làm thế nào hả bác VD của cháu đây:

Stt “dấu cách” tọa độ X “dấu Tab” tọa độ Y “dấu phẩy” tọa độ Z “dấu cách” Mã Code

Cảm ơn bác đã quan tâm đến bài của cháu.

Vì cháu cũng đang nghiên cứu lập trình Lisp nên còn nhiều bỡ ngỡ.

Cảm ơn bác rất nhiễu


<<

Filename: 102022_rft.lsp
Tác giả: Tue_NV
Bài viết gốc: 193312
Tên lệnh: cy
lisp copy tăng số mà chứ giữa nguyên

Đây bạn!

; Doan Van Ha CADViet.com; Ngay: 15-3-2012
; Copy cac doi tuong, rieng Text (Mtext) co chua so thi tang giam theo...
>>

Đây bạn!

; Doan Van Ha CADViet.com; Ngay: 15-3-2012
; Copy cac doi tuong, rieng Text (Mtext) co chua so thi tang giam theo gia so, chap nhan so co tien to va hau to.
; Neu co nhieu Text chua so duoc chon thi chi 1 Text chon sau cung duoc tang/giam. So chu so thap phan (neu co) lay theo Text chon.
; Chap nhan ca nhung so co chu so 0 dang truoc. VD: "CN: 01XD" tang thanh "CN: 02XD"...
(defun C:CY (/ dsdt dt dt1 dt2 p1 p2 sl x kwrd strt strp num sym ds daup giaso)
(vl-load-com) (command "undo" "be") (setq osm (getvar "osmode") cmd (getvar "cmdecho"))
(setq giaso (getreal "\nGia so tang/giam: "))
(princ "\nChon cac doi tuong can Copy tang/giam...")
(setq dsdt (vl-remove-if 'listp (mapcar 'cadr (ssnamex (setq dt (ssget)))))
  		dt1 dt p1 (getpoint "\nDiem goc: ") x 1)
(foreach n dsdt
 (if (or (= "TEXT" (cdr (assoc 0 (entget n)))) (= "MTEXT" (cdr (assoc 0 (entget n)))))
  (if (KT_NUM (cdr (assoc 1 (entget n))))
(setq dt2 n))))
(if dt2 (setq dt1 (ssdel dt2 dt) dt3 dt1))
(while (setq p2 (getpoint p1 "\nDiem den: "))
 (setvar "osmode" 0) (setvar "cmdecho" 0)
 (if dt2
  (progn
(command ".copy" dt2 "" p1 p2)
(CHIA3 (cdr (assoc 1 (entget dt2))))
(setq daup (if (not (vl-string-search "." (cadr ds))) 0 (- (strlen (cadr ds)) (vl-string-search "." (cadr ds)) 1)))
(entmod (subst (cons 1 (strcat (car ds) (THEM0 (cadr ds) (rtos (+ (atof (cadr ds)) (* x giaso)) 2 daup)) (caddr ds))) (assoc 1 (entget (entlast))) (entget (entlast))))
(entupd (entlast))
(setq x (1+ x))))
 (if dt1
  (command ".copy" dt1 "" p1 p2)))
(command "undo" "e") (setvar "osmode" osm) (setvar "cmdecho" cmd) (princ))
;----- Chia text ra tiento_num_hauto.
(defun CHIA3 (str / trai phai lstt lstn)
(setq lstt (vl-string->list str) lstn (reverse lstt))
(while lstt
 (cond ((or (< (car lstt) 48) (> (car lstt) 57)) (setq trai (cons (car lstt) trai) lstt (cdr lstt)))
			(T (setq lstt nil))))
(while lstn
 (cond ((or (< (car lstn) 48) (> (car lstn) 57)) (setq phai (cons (car lstn) phai) lstn (cdr lstn)))
			(T (setq lstn nil))))
(setq ds (list (vl-list->string (reverse trai))
                   	(if (= (strlen str) (strlen (vl-list->string (reverse trai)))) "" (vl-string-right-trim (vl-list->string phai) (vl-string-left-trim (vl-list->string trai) str)))
                   	(if (= (strlen str) (strlen (vl-list->string (reverse trai)))) "" (vl-list->string phai)))))
;----- Kiem tra 1 text co chua num hay khong?
(defun KT_NUM(str / ds kt)
(foreach n (vl-string->list str)
 (if (and (>= n 48) (<= n 57)) (setq kt T)))
kt)
;----- Thong ke so chu so truoc dau thap phan.
(defun KT_FIX(str / m)
(setq m 0)
(while (and (> (strlen str) 0) (/= (substr str 1 1) "."))
 (setq m (1+ m) str (substr str 2)))
m)
;----- Them so chu so 0 vao dau text cho phu hop.
(defun THEM0(strt strs)
(while (> (- (KT_FIX strt) (KT_FIX strs)) 0)
 (setq strs (strcat "0" strs)))
strs)

Nếu tiền tố hoặc hậu tố có chứa số thì Lisp chạy không còn đúng nữa?

 

Hàm KT_NUM ; ;----- Kiem tra 1 text co chua num hay khong?

có thể viết gọn lại :

(defun KT_NUM(str) (wcmatch str "*#*"))

 

Hàm KT_FIX ;----- Thong ke so chu so truoc dau thap phan.

có thể viết gọn lại :

(defun KT_FIX(str) (vl-string-position (ascii ".") str))


<<

Filename: 193312_cy.lsp

Trang 245/330

245