Jump to content
InfoFile
Tác giả: HoangSon614
Bài viết gốc: 73817
Tên lệnh: len
đo SPL nhanh nhất _ HTR
Bạn sài thử LISP này :

Chấp nhận các đối tuợng : LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE

(defun c:len (/ *error*...
>>
Bạn sài thử LISP này :

Chấp nhận các đối tuợng : LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE

(defun c:len (/ *error* vl ov ob p1 p2 pa1 pa2 len)
 (defun *error* (msg)
   (if ov (mapcar 'setvar vl ov))
   (redraw ob 4)
   (if (not(wcmatch (strcase msg) "*BREAK,*EXIT*,*CANCEL*"))
     (princ (strcat "\n** Error: " msg " **")))
   (princ))

 (vl-load-com)
 (setq vl '("CMDECHO" "OSMODE" "orthomode")
       ov (mapcar 'getvar vl))
 (mapcar 'setvar vl '(0 33 0))
 (while
   (not
     (and
(setq ob (car(entsel "\nChon doi tuong can do (LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE) : ")))
(if ob (wcmatch (cdr (assoc 0 (entget ob))) "*LINE,ARC,CIRCLE") )
)
     )
   (alert "\nDoi tuong da chon khong phu hop.
           \nChap nhan cac doi tuong : LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE
    \nChon lai :")
   )
 (redraw ob 3)
 (while (and
   (setq p1 (getpoint "\nTu diem :"))
   (setq p2 (getpoint "\nDem diem :"))
   )
   (if (and
  (setq pa1 (vlax-curve-getParamAtPoint ob p1))
  (setq pa2 (vlax-curve-getParamAtPoint ob p2))
  )
     (progn
(setq len (abs (- (vlax-curve-getdistatparam ob pa1)
		  (vlax-curve-getdistatparam ob pa2))) )
(princ (strcat "\nChieu dai la : " (rtos len) "\n-------------------"))
)
     (alert "\nDiem chon khong thuoc doi tuong can do ! \nChon lai :" )
     )
   )
 (redraw ob 4)
 (mapcar 'setvar vl ov)
 (princ)
)

Lisp sử dụng tốt rồi, nhưng có thể linh hoạt hơn tý nữa thì tốt quá

Cụ thể như: gia_bach thêm vào như sau

- Đo tổng chiều dài của các đoạn thẳng khi kết thúc đo từng đoạn (có thể ghi chiều dài ra màn hình luôn thì OK)

VD: Đoạn AB=5, CD=10, DE=15 => Tổng = 30 và ghi ra màn hình Tổng = 30

(lưu ý thêm: khi chỉ có 1 đoạn thẳng thì tổng chiều dài bằng chiều dài của đoạn thẳng đó)

Cảm ơn gia_bach


<<

Filename: 73817_len.lsp
Tác giả: mr.trunghd
Bài viết gốc: 193661
Tên lệnh: ha
Nhờ anh em giúp lisp ghi cao độ mặt cắt ngang

@cocobubu: lần sau post bài nhớ đọc kỹ nội quy kẻo bị đưa qua tạm trú ở thùng rác thì khổ.

Code nhanh cho bạn...

>>

@cocobubu: lần sau post bài nhớ đọc kỹ nội quy kẻo bị đưa qua tạm trú ở thùng rác thì khổ.

Code nhanh cho bạn đây:

(defun C:HA( / y0 y1 ent)
(command "ucs" "w")
(setq y0 (cadr (cdr (assoc 10 (entget (car (entsel "\nChon Line de lam duong chuan: ")))))))
(while
 (and
  (setq y1 (cadr (getpoint "\nPick diem de lay cao do: ")))
  (setq ent (car (entsel "\nChon Text de sua cao do: ")))
  (entmod (subst (cons 1 (rtos (- y1 y0) 2 2)) (assoc 1 (entget ent)) (entget ent)))))
(princ))

Không ổn lắm bạn ah, đánh cốt thì phải kèm ký hiệu "âm, dương" chứ?


<<

Filename: 193661_ha.lsp
Tác giả: tuvanthietke.hcm
Bài viết gốc: 150329
Tên lệnh: co
lisp copy tăng số mà chứ giữa nguyên

Bạn đã thử tìm chưa ??

;01-10-2010***Copy Inte..******************************************
(defun ketthuc ()
(setvar "cmdecho"...
>>

Bạn đã thử tìm chưa ??

;01-10-2010***Copy Inte..******************************************
(defun ketthuc ()
(setvar "cmdecho" luuecho)
(setq *error* luu
luu nil
luuecho nil
);setq
(princ)
)
;*********************************************************************
(defun modau ()
(setq luu *error
luuecho (getvar "cmdecho")
*error (ketthuc)
)
)
;*********************************************************************
(defun xulytext (text / kytu ma sokt luusokt lui )
(setq kytu (substr text (strlen text))
ma (ascii kytu)
sokt (read kytu)
lui 1
)
(if (numberp sokt)
(progn
(setq luusokt (1+ sokt))
(if (and (numberp sokt)
(> (strlen text) 1)
)
(progn
(setq kytu (substr text (1- (strlen text)))
sokt (read kytu)
)
(if (numberp sokt)
(setq luusokt (1+ sokt)
lui 2

)
)
);progn
)
(if (= luusokt 100) (setq luusokt 0))
(setq kytu (rtos luusokt 2 0)

text (strcat (substr text 1 (- (strlen text) lui)) kytu)
)
);progn
(if (or (= kytu "z")
(= kytu "Z")
)
(setq text (strcat text "0")
textxl "0"
)
(setq ma (1+ ma)
text (strcat (substr text 1 (1- (strlen text))) (chr ma))
)
);if
);if
)
;*********************************************************************
(defun doitext(tendoituong / chuoi doituong thoat tam dsach kieu text vitri10 vitri11 dem canle)
;Neu doi tuong la text thi tiep tuc
(setq doituong (entget tendoituong)
kieu (cdr (assoc 0 doituong))
canle (cdr (assoc 72 doituong))
)
(if (or (= kieu "TEXT")
(= kieu "MTEXT")
)
(progn
(setq textxl (xulytext textxl)
text (cons 1 textxl)
vitri10 (cdr (assoc 10 doituong))
vitri10 (list (+ (car vitri10) (car vitrilech)) (+ (nth 1 vitri10) (nth 1 vitrilech)))
vitri10 (cons 10 vitri10)
vitri11 (cdr (assoc 11 doituong))
vitri11 (list (+ (car vitri11) (car vitrilech)) (+ (nth 1 vitri11) (nth 1 vitrilech)))
vitri11 (cons 11 vitri11)
dem 0
dsach nil
)
(foreach tam doituong
(cond
((= (car tam) 1) (setq dsach (append dsach (list text))))
((= (car tam) 10) (setq dsach (append dsach (list vitri10))))
((= (car tam) 11) (setq dsach (append dsach (list vitri11))))
((setq dsach (append dsach (list tam))))
)
)
(entmake dsach)
);progn
);if
);
;*********************************************************************
;sao doi tuong cu sang vi tri moi

(defun copy_dt (tendoituong )
(command "copy" tendoituong "" goc toi )
);defun

;*********************************************************************
(defun c:co ( / cumdt dodai thoat dem ten doituong textxl dem goc toi)
; Khoi dau cua chuong trinh
(princ "\nCopy thong minh...\n")
(setq luuecho (getvar "cmdecho")
luu *error*
*error* ketthuc
cumdt (ssget)
dodai (sslength cumdt)
goc (getpoint "\nDiem goc copy:")
thoat nil
dem 0
textxl nil
);
(setvar "cmdecho" 0)
; Loc ra duoc ong text de xu ly
(while (and (= thoat nil)
(< dem dodai)
)
(setq ten (ssname cumdt dem)
dem (1+ dem)
doituong (entget ten)
kieu (cdr (assoc 0 doituong))
)

(if (or (= kieu "TEXT")
(= kieu "MTEXT")
)
(setq thoat T
textxl (cdr (assoc 1 doituong))
)
)
);
(while T
(setq toi (getpoint "\nDiem dat doi tuong: " goc)
vitrilech (list (- (car toi) (car goc)) (- (nth 1 toi) (nth 1 goc)))
dem 0
)
(while (< dem dodai)
(setq ten (ssname cumdt dem)
dem (1+ dem)
doituong (entget ten)
kieu (cdr (assoc 0 doituong))
)

(if (or (= kieu "TEXT")
(= kieu "MTEXT")
)
(doitext ten)
(copy_dt ten)

);if
)
);while
(ketthuc)
);defun
(princ)
;Note: bien toan cuc: textxl vitrilech

 

 

Bạn ơi nó chỉ cho copy đến 100 thôi còn lại là trở về 0 à, sao cho nó copy được đến 999


<<

Filename: 150329_co.lsp
Tác giả: Tue_NV
Bài viết gốc: 219190
Tên lệnh: chon
Lisp ghi kích thước Polyline ra text

Bạn có thể thứ

Tên lệnh "CHON"

Cách sử dụng

Pick chọn Dim1 (dùng để lấy chiều dài- giá trị đầu tiên sau chữ...

>>

Bạn có thể thứ

Tên lệnh "CHON"

Cách sử dụng

Pick chọn Dim1 (dùng để lấy chiều dài- giá trị đầu tiên sau chữ PL)

Pick chọn Dim2 (dùng để lấy chiều rộng_giá trị cuối của Text)

Pick chọn text bị thay đổi

(defun c:chon (/ ent1 ent2 ass1 ass2 X1 X2 day NDnew)
 (setvar "cmdecho" 0)
 (or #day# (setq #day# 10))
 (command "undo" "begin")
 (setq ass1 (cdr(assoc 1 (setq ent1 (entget(car (entsel "\nChon Dim1") )))))
ass2 (cdr(assoc 1 (setq ent2 (entget(car (entsel "\nChon Dim2") )))))
)
 (if (= ass1 "")
(setq X1 (cdr(assoc 42 ent1)))
(setq X1 (atof ass1)))
 (if (= ass2 "")
(setq X2 (cdr(assoc 42 ent2)))
(setq X2 (atof ass2)))
 (setq #day# (cond ((getreal (strcat "\nNhap chieu day <" (rtos #day# 2 0) ">:")))(#day#)))
 (setq NDnew (strcat "PL" (rtos X1 2 0 ) "x" (rtos #day# 2 0) "x" (rtos X2 2 0)))
 (setq dt (entget(car(entsel "\nChon Text"))))
 (entmod(subst (cons 1 NDnew) (assoc 1 dt) dt))
 (command "undo" "end")
 (setvar "cmdecho" 1)
 )

 

uẩy còn vụ Fake dim nữa để mình sửa lại đã

Ok giờ thì xong rồi, hơi loằng ngoằng nhưng nói chung là đủ dùng

- Nếu chiều dài luôn lớn hơn (hoặc =) chiều rộng thì làm luôn 1 cặp 2 dim (hàm ssget), không cần phải pick từng chú dim 1 :)


<<

Filename: 219190_chon.lsp
Tác giả: nhimret
Bài viết gốc: 423880
Tên lệnh: zz
Convert các đối tượng trong block về layer chính
;; Convert Layer cua cac doi tuong ben trong block (co the long nhau) ve cung Layer cua Block chinh. De Undo tat ca: dung lenh "U" + "Regen"
;; Doan Van Ha - CadViet.com - ngay 21/7/2013
(defun C:zz ( / doc blkname lay)
 (princ "\nChon cac Blocks...")
 (if (ssget '((0 . "INSERT")))
  (progn
   (vlax-for obj (vla-get-ActiveSelectionSet (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))))
    (setq blkname...
>>
;; Convert Layer cua cac doi tuong ben trong block (co the long nhau) ve cung Layer cua Block chinh. De Undo tat ca: dung lenh "U" + "Regen"
;; Doan Van Ha - CadViet.com - ngay 21/7/2013
(defun C:zz ( / doc blkname lay)
 (princ "\nChon cac Blocks...")
 (if (ssget '((0 . "INSERT")))
  (progn
   (vlax-for obj (vla-get-ActiveSelectionSet (setq doc (vla-get-ActiveDocument (vlax-get-acad-object))))
    (setq blkname (vla-get-Name obj)
          lay (vla-get-Layer obj))
    (mapcar '(lambda(o) (vla-put-Layer o lay)) (Get_lst_Obj doc blkname)))
   (vla-Regen doc acActiveViewport))))
(defun Get_lst_Obj (doc blkname / lst)
 (vlax-for blk (vla-Item (vla-get-Blocks doc) blkname)
  (if (/= (vla-get-ObjectName blk) "AcDbBlockReference")
   (if (not (vl-position blk lst))
    (setq lst (cons blk lst)))
   (setq lst (append (Get_lst_Obj doc (vla-get-Name blk)) lst)))))

Tôi đang dùng lisp của bác @Doan Van Hamấy năm rất hiệu quả, nhưng hiện giờ gặp một vấn đề là nếu như đối tượng trong layer không để bylayer, mà để màu tự chọn, thì lisp này không đổi được màu của nó, chỉ đổi layer.

 

Nhờ các bác chỉnh sửa hộ lisp này để gõ lệnh thì các đối tượng trong layer chuyển được về hết bylayer hộ. 

 

Cám ơn rất nhiều


<<

Filename: 423880_zz.lsp
Tác giả: tuan138
Bài viết gốc: 408938
Tên lệnh: test
Nhờ Tư Vấn Lisp Chuyển Polyline Sang Arc

 

Vẫn làm đc ^_^ nhưng sẽ không chính xác 1 số góc cong. Thử cái này xem nhé.

(defun c:test (/ ss pLlst vLst...
>>

 

Vẫn làm đc ^_^ nhưng sẽ không chính xác 1 số góc cong. Thử cái này xem nhé.

(defun c:test (/ ss pLlst vLst n p1 p2 p3)
  (command "ucs" "name" "save" "temp")
  (command "ucs" "w")
  (if (not (setq ss (ssget '((0 . "LWPOLYLINE")))))
    (print "Ban da khong chon pline.")
    (progn
      (setq pLlst (vl-remove-if
		    'listp
		    (mapcar 'cadr (ssnamex ss))
		  )
      )
      
      (foreach pl pLlst
	(setq vLst   (mapcar 'cdr
			     (vl-remove-if-not
			       '(lambda (x) (= 10 (car x)))
			       (entget pl)
			     )
		     )
	)				;setq
	(setq n 0)
	(while (< 1 (length vLst))
	  (setq	p1 (nth n vLst)
		p2 (nth (+ n 1) vLst)
		p3 (nth (+ n 2) vLst)
	  )				;setq
	  (command "_arc" "_none" p1 "_none" p2 "_none" p3)
	  (setq vLst (cddr vLst))
	)				;while
      )					;foreach
    )					;progn
  )					;if
  (command "ucs" "name" "restore" "temp")
  (command "ucs" "name" "delete" "temp")
  (princ)
)					;defun

Bác Bee ơi. 

Cảm ơn bác đã viết code mới.

Nhưng em chạy nó báo lỗi bác ạ " error: bad argument type: fixnump: nil"

 

Em cảm ơn bác quocmanh04tt

Code của bác hoạt động hiệu quả đối với em.

Nếu thêm được tính năng như bác Bee nói thì tốt quá ạ. 

 

Theo em nghĩ có thể tùy chọn cấp độ chi tiết của đường cong, lúc này cho người dùng nhập vào cấp độ (VD:1 hoặc 2) được không bác.

Thật sự là em chưa nghĩ được ý tưởng nào để có thể đơn giản hóa theo cách của bác. 

Hoặc nếu như thuật toán như bác @DuongTrungHuy đề cập thì có thể căn cứ vào khoảng cách (X,Y) của các điểm neo polyline để xác định có vẽ cung đó hay không và lấy thông tin các điểm không vẽ đó để tính toán vẽ arc lớn hơn.

Hoặc nữa là căn cứ theo các arc có bán kính cong xấp xỉ nhau để merge.

 

Em xin lỗi bác Bee và Bác Quocmanh04tt vì chưa thể đóng góp ý kiến cho code vì mới đang học để đọc hiểu code các bác viết, đọc còn chưa thấu nên chưa đủ khả năng.

 

Lần nữa cảm ơn các bác rất nhiều cho vấn đề của em.


<<

Filename: 408938_test.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 230230
Tên lệnh: xpt xpt1
Nhờ viết lisp lọc các đối tượng là text trong một vùng kín xuất ra Excel

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

>>

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

Hề hề hề,

Mình đã xem bản vẽ của bạn và có một vài ý kiến như sau:

1/- Một cụm point của bạn gồm có 4 đối tượng là; 1 text trên lớp "Dh_Caodo", 1 point trên lớp "Dh_Point", 1 text trên lớp "Dh_stt" và 1 text trên lớp "Dh_Code". Vì sao bạn không nhóm cả 4 đối tượng này vào một block thuộc tính để dễ dàng truy xuất nó mà để rời rạc như vậy. Điều này gây khó khăn cho việc chọn đối tượng cần truy xuất do khá nhiều điểm của bạn nằm liền kề nhau và có chung các thuộc tính chọn lựa.

2/- Với 4 đối tượng trong nhóm nhưng bạn chỉ cần truy xuất hai đối tượng là text trên lớp "Dh_stt" và point tên lớp "Dh_Point" thôi ư?? Các đối tượng khác có cần quan tâm không?? Nếu có thì nhét chúng vào đâu???

3/- Việc viết lisp này tuy không quá khó, nhưng trên diễn đàn cũng có khá nhiều lisp tương tự với yêu cầu của bạn rồi, sao bạn không thử tìm kiếm và lấy về dùng thử. Nếu có lisp nào bạn thấy gần phù hợp nhất với yêu cầu của bạn thì post lên để mọi người chỉnh giúp chỉnh sửa cho phù hợp, như vậy sẽ nhanh hơn nhiều là việc làm mới bạn ạ. Bạn cũng nên thông cảm với các lisper trên diễn đàn vì thời gian và sự kiên nhẫn hạn chế bạn ạ.

Hề hề hề,...

Và đây là lisp theo yêu cầu của bạn:

 

(defun c:xpt ( / oldos fn f ssc p1 p2 txt )
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(command "undo" "be")
(setq  fn (getfiled "Select Data File" "" "csv" 0)
          f (open fn "w")
          ssc (acet-ss-to-list (ssget "w" (setq p1 (getpoint "\n Chon diem goc tren ben trai vung chon"))
                                                             (setq p2 (getpoint p1 "\n Chon diem goc duoi ben phai vung chon"))
                                                             (list (cons 0 "point") (cons 8 "Dh_Point")))) 
          txt "" )
(foreach po ssc
        (setq txt (strcat (cdr (assoc 1 (entget (car (acet-ss-to-list (ssget "w" p1 p2
                                        (list (cons 0 "text") (cons 11 (cdr (assoc 10 (entget po)))) (cons 8 "Dh_stt")))))))) 
                                  (chr 44) (rtos (cadr (assoc 10 (entget po))) 2 2) 
                                  (chr 44) (rtos (caddr (assoc 10 (entget po))) 2 2)))
        (write-line txt f)
)
(close f)
(command "undo" "e")
(setvar "osmode" oldos)
(princ)
)
 
Chúc bạn vui
 
Khuyến mãi cho bạn một lisp khác đơn giản hơn với cách dùng như cụ:

(defun c:xpt1 ( / oldos fn f ssc p1 p2 txt )
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(command "undo" "be")
(setq  fn (getfiled "Select Data File" "" "csv" 0)
          f (open fn "w")
          ssc (acet-ss-to-list (ssget "w" (setq p1 (getpoint "\n Chon diem goc tren ben trai vung chon"))
                                                             (setq p2 (getpoint p1 "\n Chon diem goc duoi ben phai vung chon"))
                                                             (list (cons 0 "text") (cons 8 "Dh_stt")))) 
          txt "" )
(write-line  "STT diem , Toa do X , Toa do Y , Ghi chu" f)
(foreach tex ssc
      (setq txt (strcat (cdr (assoc 1 (entget tex))) (chr 44) (rtos (cadr (assoc 11 (entget tex))) 2 2) 
                                 (chr 44) (rtos (caddr (assoc 11 (entget tex))) 2 2)) )
      (write-line txt f)
)
(close f)
(command "undo" "e")
(setvar "osmode" oldos)
(princ)
)
 

<<

Filename: 230230_xpt_xpt1.lsp
Tác giả: huaductiep
Bài viết gốc: 317431
Tên lệnh: tty+%C2%A0
Nhờ sửa Lisp Copy Text Cad sang Excel

Cảm ơn Bác Tot 77. Lisp này của bác dùng rất tốt rồi. Nhưng bác có thể chỉnh giúp mình lsao để mình có thể chọn hết xong rồi mới ấn enter dc ko? Chứ lisp này là cứ mỗi lần chọn lại enter 1 lần thì hơi chậm 1 tý ^^

>>

Cảm ơn Bác Tot 77. Lisp này của bác dùng rất tốt rồi. Nhưng bác có thể chỉnh giúp mình lsao để mình có thể chọn hết xong rồi mới ấn enter dc ko? Chứ lisp này là cứ mỗi lần chọn lại enter 1 lần thì hơi chậm 1 tý ^^

 

Cái này cũng gần giống cái trên.

 

(defun c:tty  (/ ss ss1 y xlApp xlCells row col i iPt)
  (vl-load-com)
  (setq xlApp   (vlax-get-or-create-object "Excel.Application")
            xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                          (vlax-invoke-method
                            (vlax-get-property xlApp "Workbooks")
                            "Add") "Sheets") "Item" 1) "Cells") row 0 col 1)
  (vla-put-visible xlApp :vlax-true)
  
  (while (setq ss (ssget '((0 . "*TEXT"))))      
      (setq ss (mapcar '(lambda (x) (list (vlax-get (vlax-ename->vla-object x) 'InsertionPoint)
 (vlax-ename->vla-object x))) 
      (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))    
      (while ss
(setq  ss (vl-sort ss '(lambda (x y) (> (cadr (car x)) (cadr (car y)))))
      ss1 (vl-remove-if-not '(lambda (x) (equal (cadr (caar ss)) (cadr (car x)) 0.2)) ss)
      ss1 (vl-sort ss1 '(lambda (x y) (< (caar x) (caar y))))
      ss (vl-remove-if '(lambda (x) (member x ss1)) ss)
)
(foreach z ss1
          (setq iPt (car z)
y (list (vla-get-TextString (last z))  (rtos (car iPt) 2 2)  (rtos (cadr iPt) 2 2) (rtos (caddr iPt) 2 2))
 ) 
          (if (> row 65536) (setq col 5))
          (setq i -1 row (1+ row))
          (mapcar '(lambda (x) (vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) x)) y)
)
      )
    )
  (mapcar 'vlax-release-object (list xlApp xlCells))
  (princ)
)

<<

Filename: 317431_tty+%C2%A0.lsp
Tác giả: minhphuong_humg
Bài viết gốc: 268278
Tên lệnh: ha
Lisp lấy giá trị của dimenson, text và xuất ra file text

 

 

 

Ðây bạn:

(defun C:HA( / lst fn fw index x y z txt)	;Doan Van Ha Cadviet.com
...
>>

 

 

 

Ðây bạn:

(defun C:HA( / lst fn fw index x y z txt)	;Doan Van Ha Cadviet.com
 (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))

Nhờ Bác Doan Van Ha và các Bác trong diễn ðàn có thể giúp em sửa lisp này với mục ðích sau ðýợc không ạ:

Trýờng hợp 1 :

Lựa chọn (Seclect) Dimension ðầu tiên (Dimension 1) rồi chọn Dimension cuối (Dimension n). Cuối cùng cho ra file excel có dạng:

STT                               Khoảng cách

Dimension 1                  37

Dimension 2                  26

Dimension 3                  29

Dimension 4                  37

Dimension 5                  32

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

Dimension 29                40

Link file:

http://www.cadviet.com/upfiles/3/2883_hoi_3.dwg

Em trân trọng cảm õn!


<<

Filename: 268278_ha.lsp
Tác giả: unbroken
Bài viết gốc: 250481
Tên lệnh: ltt
Lisp làm tròn số ( là Text) trong CAD ???????

 

Tue_NV vẫn chưa hiểu là trong bản vẽ của bạn vừa có cả số thập phân (0.34) và có cả số %(0.34) hay không?. Vì bạn chưa nói...

>>

 

Tue_NV vẫn chưa hiểu là trong bản vẽ của bạn vừa có cả số thập phân (0.34) và có cả số %(0.34) hay không?. Vì bạn chưa nói rõ

 

Thế này nhé :

Tue_NV sẽ lược bỏ theo ý của bạn : 0.34% -> thì kết qủa giữ nguyên = 0.34

Nếu số 2.00% thì bỏ bớt số phía sau đi = 2

 

Còn đuôi % thì bạn sử dụng Lisp thêm Text thêm vào vậy vì lí do :

 

Tue_NV vẫn chưa hiểu là trong bản vẽ của bạn vừa có cả số thập phân (0.34) và có cả số % (0.34%) hay không?

Vì bạn chưa nói rõ

 

Code này có chỉnh lại Lisp của bác ssg 1 chút :

;;;-------------------------------------------------------
(defun etype (e);;;Entity Type
(cdr (assoc 0 (entget e)))
)
;;;-------------------------------------------------------
(defun C:LTT( / ss n i oldDimzin e d v S)
(if (not n0) (setq n0 2))
(setq
ss (ssget '((0 . "TEXT,MTEXT")))
n (getint (strcat "\nSo chu so thap phan <" (itoa n0) ">:"))
i 0
oldDimzin (getvar "dimzin")
)
(if n (setq n0 n) (setq n n0))
(setvar "dimzin" 8)
(repeat (sslength ss)
(setq e (ssname ss i))
(if (= (etype e) "MTEXT") (progn
(command "explode" e "")
(setq e (entlast))
))
(setq
d (entget e)
v (atof (cdr (assoc 1 d)))
S (rtos v 2 n)
d (subst (cons 1 S) (assoc 1 d) d)
)
(entmod d)
(setq i (1+ i))
)
(setvar "dimzin" oldDimzin)
(princ)
)
s_big.gif

cái bạn sửa vẫn chưa ổn


<<

Filename: 250481_ltt.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 229675
Tên lệnh: xtsn
Lisp up nội dung từ Excel vào Cad

 

(defun c:XTSN (/ oldos sslst tlst filename f sslst1 C1 C2 C3 C4 )  ;C1 C2 C3 C4 C5 C6 C7 C8
(vl-load-com)
(command "undo"...
>>

 

(defun c:XTSN (/ oldos sslst tlst filename f sslst1 C1 C2 C3 C4 )  ;C1 C2 C3 C4 C5 C6 C7 C8
(vl-load-com)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq sslst (acet-ss-to-list (ssget (list (cons 0 "circle") (cons 62 63) (cons 8 "SN_circleKQ"))))
          tlst ""   )
(setq filename (getfiled "Select a File" "" "csv" 1))
(setq f (open filename "w")) 
(write-line "SN_STTO,SN_CCTC,SN_DTIH,SN_KLUG," f)
(foreach e sslst
         (setq sslst1 (acet-ss-to-list (ssget "w" (list (- (cadr (assoc 10 (entget e))) (cdr (assoc 40 (entget e))))
                                                                                 (- (caddr (assoc 10 (entget e))) (cdr (assoc 40 (entget e))))
                                                                          )
                                                  (list (+ (cadr (assoc 10 (entget e))) (cdr (assoc 40 (entget e))))
                                                                                 (+ (caddr (assoc 10 (entget e))) (cdr (assoc 40 (entget e))))
                                                                          )
                                                 (list (cons 0 "text"))     ))  )
       
		  (setq C1 nil C2 nil C3 nil C4 nil )
         (foreach en sslst1
                  (if (= (cdr (assoc 8 (entget en))) "SN_STTO")
                      (setq C1 (cdr (assoc 1 (entget en))) )
                  )
         )
         (foreach en sslst1
                  (if (= (cdr (assoc 8 (entget en))) "SN_CCTC")
                      (setq C2 (cdr (assoc 1 (entget en))) )
                  )
         )
         (foreach en sslst1
                  (if (= (cdr (assoc 8 (entget en))) "SN_DTIH")
                     (setq C3 (cdr (assoc 1 (entget en))) )
                  )
         )
         (foreach en sslst1
                  (if (= (cdr (assoc 8 (entget en))) "SN_KLUG")
                      (setq C4 (cdr (assoc 1 (entget en))) )
                  )
         )
        
         (setq tlst (strcat (if C1 C1 " ") (chr 44) 
							(if C2 C2 " ") (chr 44) 
							(if C3 C3 " ") (chr 44) 
							(if C4 C4 " ") (chr 44)                       
							))
         (write-line tlst f)
         (setq tlst "")
)
(close f)
(setvar "osmode" oldos)
(command "undo" "e")
(princ)
)

Mình sưu tầm được lisp xuất các nội dung trong ô vòng tròn ra excel được rất nhiều cột .

muốn chỉ xuất 4 nội dung trong ô gồm SN_STTO, SN_CCTC, SN_DTiH, SN_KLUG.

Rieng ô vong tron có tên lớp SN_CircleKQ riêng.

Rất mong được bạn xem sửa giúp để thực hiện việc xuất ra excel.

Cám ơn

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

Hề hề hề,

Cấu trúc cái lisp bạn gửi khá giống với cái líp của mình. Mình đã test trên bản vẽ bạn gửi thì kết quả rất ngon lành. Vì sao bạn lại test không được nhỉ??? Hãy gửi cái bản vẽ bạn đã test lên để mình kiểm tra nhé. Việc sửa cái lisp bạn gửi không khó nhưng chỉ sợ vẫn không phù hợp yêu cầu của bạn nếu như bạn không gửi cái bản vẽ của bạn lên.

Hề hề hề,...


<<

Filename: 229675_xtsn.lsp
Tác giả: taipham
Bài viết gốc: 392694
Tên lệnh: tt%C2%A0
Nhờ Viết Lisp Tạo Table Nhanh Cho Text Có Sẵn

Thì ra nhiều loại bảng, mỗi bảng có khoảng cách giữa các hàng lại khác nhau.

Lisp sửa lại này sẽ tự động dãn...

>>

Thì ra nhiều loại bảng, mỗi bảng có khoảng cách giữa các hàng lại khác nhau.

Lisp sửa lại này sẽ tự động dãn hàng theo Text có sẵn:

(defun c:tt  (/ Make_line TxtWidth list-deldups ||| ent first-row hei i ins last-col lst-p1 lst-p2 max-wid old-sty p1 p2 poi-txt ss sty txt widt-txt make_text dis)
 (defun Make_line  (p1 p2)
  (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "00-TIEU DE"))))
 (defun TxtWidth  (val h / txt minp maxp msp)
  (setq msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
  (setq txt (vla-addtext msp val (vlax-3d-point '(0 0 0)) h))
  (vla-getboundingbox txt 'minp 'maxp)
  (vla-erase txt)
  (- (car (vlax-safearray->list maxp)) (car (vlax-safearray->list minp))))
 (defun list-deldups  (lst)
    (if lst
      (cons (car lst) (list-deldups (vl-remove (car lst) (cdr lst))))))
 ;; Main
 (if (setq ss (ssget '((0 . "*TEXT"))))
  (progn (setq old-sty (getvar "TEXTSTYLE"))
         (repeat (setq i (sslength ss))
          (setq ent (entget (ssname ss (setq i (1- i))))
                txt (cdr (assoc 1 ent))
                hei (cdr (assoc 40 ent))
                sty (cdr (assoc 7 ent))
                ins (cdr (assoc 10 ent)))
          (setq poi-txt (list-deldups (cons (cons ins txt) poi-txt))
                poi-txt (vl-sort poi-txt
                                 '(lambda (x y)
                                   (cond ((equal (cadr (car x)) (cadr (car y))) (< (car (car x)) (car (car y))))
                                         ((< (cadr (car x)) (cadr (car y)))))))))
         (foreach x  poi-txt
          (if (equal (car (car x)) (car (car (last poi-txt))) (* hei 2))
           (setq last-col (cons x last-col))))
         (setvar "TEXTSTYLE" sty)
         (foreach x last-col (setq widt-txt (cons (TxtWidth (cdr x) hei) widt-txt)))
         (setq max-wid (apply 'max widt-txt))
         (foreach x  poi-txt
          (if (equal (cadr (car x)) (cadr (car (last poi-txt))) hei)
           (setq first-row (cons (car x) first-row)
                 first-row (vl-sort first-row '(lambda (x y) (< (car x) (car y)))))))
         (setq first-row (cons (polar (last first-row) (* pi 0) (+ max-wid (* hei 2))) first-row))
         ;; Dat bang vi tri moi
         (defun make_text  (/ lst-make p-org poi poi-x poi-j poi-new first-new)
          (if (setq poi (getpoint "\nDiem chen bang: "))
           (progn (repeat (setq i (sslength ss))
                   (setq lst-make (cons (vl-remove-if '(lambda (x) (member (car x) '(-1 5 330 410))) (entget (ssname ss (setq i (1- i)))))
                                        lst-make)))
                  (setq p-org (car (vl-sort first-row '(lambda (x y) (< (car x) (car y))))))
                  (foreach x  lst-make
                   (setq poi-x (polar (cdr (assoc 10 x)) (angle p-org poi) (distance p-org poi))
                         poi-j (polar (cdr (assoc 11 x)) (angle p-org poi) (distance p-org poi)))
                   (setq x (subst (cons 10 poi-x) (assoc 10 x) x))
                   (setq x (subst (cons 11 poi-j) (assoc 11 x) x))
                   (entmakex x))
                  (foreach x  first-row
                   (setq poi-new   (polar x (angle p-org poi) (distance p-org poi))
                         first-new (cons poi-new first-new)))
                  (setq first-row first-new))))
         (make_text)
         ;; Ke bang
         (setq dis (/ (distance (car (car last-col)) (car (last last-col))) (1- (length last-col))))
         (foreach x  first-row
          (setq p1 (polar (polar x (* pi 1.0) hei) (* pi 0.5) (* 0.75 dis))) ;hei 1.5
          (setq p2 (polar p1 (* pi 1.5) (* dis (length last-col)))) ;2 hei
          (setq lst-p1 (cons p1 lst-p1)
                lst-p2 (cons p2 lst-p2))
          (Make_line p1 p2))
         (setq lst-p1 (vl-sort lst-p1 '(lambda (x y) (< (car x) (car y)))))
         (setq i 0)
         (repeat (+ (length last-col) 1)
          (setq p1 (polar (car lst-p1) (* pi 1.5) (* dis i)) ;2 hei
                p2 (polar (last lst-p1) (* pi 1.5) (* dis i))) ;2 hei
          (Make_line p1 p2)
          (setq i (1+ i)))
         (setvar "TEXTSTYLE" old-sty)))
 (princ))​

+ Số cột phụ thuộc vào hàng đầu tiên.

+ Các hàng phải có khoảng cách đều.

Mình đang nghiên cứu viết cho AutocadTable, sẽ khắc phục được các vấn đề trên.

Cảm ơn anh rất nhiều nhé! anh nhiệt tình quá, hehe, hy vọng và chờ đợi anh nghiên cứu thành công AutocadTable! :)


<<

Filename: 392694_tt%C2%A0.lsp
Tác giả: Trang72
Bài viết gốc: 121023
Tên lệnh: input
Xuất dữ liệu cad sang EXCEL lần lượt
Mình thắc mắc không hiểu sao bác lại thích như vậy. Nhưng thôi kệ. Chắc công việc của bác cần như thế.

Bác xem đoạn code dưới đây có vừa ý không.

- Copy DCL...

>>
Mình thắc mắc không hiểu sao bác lại thích như vậy. Nhưng thôi kệ. Chắc công việc của bác cần như thế.

Bác xem đoạn code dưới đây có vừa ý không.

- Copy DCL vào C:\ hoặc sửa lại đườg dẫn theo ý bác

- Nhập liệu bằng TAB- Close để kết thúc

- STT tự gia tăng. Nếu không thích bác có thể sửa code lại

(defun c:input (/ filename f number)
(setq filename (getfiled "Select a File" "" "xls" 1))
 (if filename
  (progn
(setq f (open filename "w"))		
(setq id (load_dialog "C:/input.dcl"))	
(new_dialog "input" id)
(set_tile "filename" (strcat "File name:" filename))
(mode_tile "number" 2)
(action_tile "note" "(PROGN
			  (write-line (strcat
			(setq number (get_tile \"number\")) \"\t\"
			(get_tile \"code\") \"\t\"
			  (get_tile \"distance\") \"\t\"
			(get_tile \"note\") \"\t\") f)
			(set_tile \"number\" (itoa (1+ (atoi number))))
			(mode_tile \"code\" 2)
			  )")

(start_dialog)
(done_dialog)
(unload_dialog id)
(close f)	

 ))  

 )

input:dialog {
label="Write to file";
: text {key="filename";}
: boxed_row {
label="Row data";
: column {: text {label="Number";} : edit_box {key="number";edit_width=5;}}
: column {: text {label="Code";} : edit_box {key="code";edit_width=8;}}
: column {: text {label="Distance";} : edit_box {key="distance";edit_width=8;}}
: column {: text {label="Notes";} : edit_box {key="note";edit_width=20;}}
}
: button {
	label="Close";
	fixed_width=true;
	is_cancel=true;
	key="cancel";
	is_default=true;
	alignment=right;
		}
}

 

 

Cám ơn Bác npham đã giúp em đúng như công việc em cần . Bác Cho em hỏi 1 chút Bác có cách nào làm cho hộp hội thoại dialog của lisp này vẫn hiện trên màn hình mà vẫn thực hiện được lệnh pan hoặc Zom các đối tượng trên màn hình cad được không ạ.Bác giúp em nhé Cám ơn Bác nhiều.


<<

Filename: 121023_input.lsp
Tác giả: vodoifx
Bài viết gốc: 412458
Tên lệnh: sw
Lisp chọn nhiều đối tượng giống nhau

 

K biết bạn thất bại cái j, ở đâu, mình cũng thử xoá và vẫn thấy dùng bình thường. Nhớ là xoá chữ All đi rồi thì thao tác...

>>

 

K biết bạn thất bại cái j, ở đâu, mình cũng thử xoá và vẫn thấy dùng bình thường. Nhớ là xoá chữ All đi rồi thì thao tác chọn sẽ làm 2 lần

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/56306-da-xong-lisp-chon-nhieu-doi-tuong-giong-nhau/
(defun c:sw(/ aaa ls dt dt1 sdt sdt1 ent ent1 id id1)
  (setq AAA(SSGET)
sdt (sslength AAA)
id 0
dt (ssadd)
)
  (repeat sdt;;repeat1
	(setq ent (ssname AAA id)
id (1+ id)
);;setq
	(setq ls (entget ent))
	(if (= (cdr (assoc 0 ls)) "INSERT")
  	(get-block ent)
  	(setq dt1 (ssget (list(assoc 0 ls) (assoc 8 ls))))
  	);;if
	(setq sdt1 (sslength dt1)
   id1 -1)
	(while (setq ent1(ssname dt1 (setq id1 (1+ id1))))
  	(setq dt (ssadd ent1 dt))
  	);;While
	(sssetfirst dt dt)
	(princ)
	);;repeat1
  )
;;;;;;;;;;;;;;;;;;;;;;;;
(defun get-block(entm / sdtb idb ent2 entb dtm namem name BBB entb)
  (setq dtm (vlax-ename->vla-object entm))
  (setq namem (if(vlax-property-available-p dtm 'effectivename)
   (vla-get-effectivename dtm)
   (vla-get-name dtm)
   ));;;
  (setq BBB(SSGET  (list(cons 0 "INSERT") (assoc 8 (entget entm))))
sdtb (sslength BBB)
idb 0
dt1 (ssadd)
)
  (repeat sdtb;;repeat1
	(setq entb (ssname BBB idb)
idb (1+ idb)
)
	(setq ent2(vlax-ename->vla-object entb))
	(setq name (if(vlax-property-available-p ent2 'effectivename)
   (vla-get-effectivename ent2)
   (vla-get-name ent2)
   ))
	(if (= name namem)
  	(setq dt1 (ssadd entb dt1))
  	)
	)
  )

Em chào anh. Anh xem lại giúp em đối với đối tượng khi là block ạ.

Các đối tượng khác thì ok. Nhưng Block thì chưa được đâu ạ.


<<

Filename: 412458_sw.lsp
Tác giả: minhphuong_humg
Bài viết gốc: 101247
Tên lệnh: fu
Giúp chuyển text từ cad sang Excel?
Sorry ! :D

Có thể do không tuơng thích Assembly (compile với CAD2010).

Do tại cơ quan không có sẵn Cad2008, hẹn bạn sau nhé...

>>
Sorry ! :D

Có thể do không tuơng thích Assembly (compile với CAD2010).

Do tại cơ quan không có sẵn Cad2008, hẹn bạn sau nhé !

 

 

Đúng là AutoCAD thao tác với unicode rất khó khăn.

 

Dưới đây là lisp để biến file txt của bạn thành file txt unicode (mở bằng Wordpad hoặc MS Word). Tuy nhiên không triệt để bởi vì Autolisp không thể tạo ra một dấu xuống dòng unicode được. chính vì vậy, tạm thời dấu xuống dòng được biến thành dấu chấm phẩy ( ; ) vào trong word hoặc excel bạn biến nó thành ngắt dòng sau.

 

Lệnh là FU (FixUnicode), sẽ tạo một file nằm cùng thư mục của file được chọn, có hậu tố _u.

(setq breaklinecharacter ";")
(defun c:FU ()
 (defun t2h ( c )
   (1-	(length	(member	c
		(reverse (vl-string->list
			   "0123456789ABCDEF"
			 )
		)
	)
)
   )
 )
 (defun getunicode (lst)
   (setq hexlist (vl-string->list "0123456789ABCDEF"))
   (if	(and
  (= (nth 0 lst) (ascii "\\"))
  (= (nth 1 lst) (ascii "U"))
  (= (nth 2 lst) (ascii "+"))
  (member (nth 3 lst) hexlist)
  (member (nth 4 lst) hexlist)
  (member (nth 5 lst) hexlist)
  (member (nth 6 lst) hexlist)
)
     (progn
(setq
  u2 (+ (* (t2h (nth 3 lst)) 16) (t2h (nth 4 lst)))
  u1 (+ (* (t2h (nth 5 lst)) 16) (t2h (nth 6 lst)))
)
(list u1 u2)
     )
     nil
   )
 )
 (setq	fi  (getfiled "Chon file text" "" "txt" 0)
fo  (strcat (vl-filename-directory fi)
	    "\\"
	    (vl-filename-base fi)
	    "_u.txt"
    )
fih (open fi "r")
foh (open fo "w")
cur nil
 )
 (write-char 255 foh)
 (write-char 254 foh)

 (while (setq ch (read-char fih))
   (setq cur (append cur (list ch)))
   (if	(>= (length cur) 7)
     (if (setq uni (getunicode cur))
(progn
  (write-char (car uni) foh)
  (write-char (cadr uni) foh)
  (setq cur nil)
)
(progn
  (setq a (car cur))
  (if (/= a 13)
    (progn
      (if (= a 10) (setq a (ascii breaklinecharacter)))
      (write-char a foh)
      (write-char 256 foh)	  	      
    )
  )
  (setq cur (cdr cur))
)
     )      
   )
 )
 (foreach ch cur
   (write-char (car cur) foh)
   (write-char 256 foh)
 )
 (close fih)
 (close foh)
 (princ "Done!!!")
 (princ)
)

 

Nếu bạn sử dụng quen excel, bạn có thể dễ dàng biến file text ngăn bằng dấu ; thành các hàng trong excel.

Em cảm ơn 2 bác Gia Bạch và Nguyễn Hoành. Trong lúc cấp bách phải nộp gần 100 bộ hồ sơ thì em lại thấy có một cách, không biết có phải là ý hay không. Nhưng em xin chia sẻ để nếu có ai gặp phải trường hợp như em có thể giải quyết được.

Đầu tiên em chọn các đối tượng và vào menu Express của cad. Chọn Text> Text to Mtext ---> sau đó em copy ra Excel và làm thao tác tách ra (cái này thì đơn giản với người nào quen làm excel). Thế là em đã làm và hoàn thành! Xin cảm ơn sự giúp đỡ của 2 bác!


<<

Filename: 101247_fu.lsp
Tác giả: proconeng86
Bài viết gốc: 241582
Tên lệnh: ha
Lisp đổi đầu arrow của leader

 

Lisp thay đổi Arrowhead của Leader và Dimension. Tưởng bạn đã...

>>

 

Lisp thay đổi Arrowhead của Leader và Dimension. Tưởng bạn đã quên ai ngờ vẫn nhớ.

 

;; Thay doi Arrowhead cua cac Leader va Dimension duoc chon.
;; Doan Van Ha - CadViet.com - ngay 16/7/2013
(vl-load-com)
(defun C:HA( / lst ss txt i ent L->Ptr #String:Replace)
 (defun L->Ptr(lst)
  (vl-string-trim "()" (vl-princ-to-string lst)))
 (defun #String:Replace(new old str / inc len)
  (setq len (strlen new) inc 0)
  (while (setq inc (vl-string-search old str inc))
   (setq str (vl-string-subst new old str inc) inc (+ inc len)))
  str)
 (setq lst
 '(("01.ClosedFilled" acArrowDefault)
   ("02.Dot" acArrowDot)
   ("03.DotSmall" acArrowDotSmall)
   ("04.DotBlank" acArrowDotBlank)
   ("05.OriginIndicator" acArrowOrigin)
   ("06.OriginIndicator2" acArrowOrigin2)
   ("07.Open" acArrowOpen)
   ("08.RightAangle" acArrowOpen90)
   ("09.Open30" acArrowOpen30)
   ("10.Closed" acArrowClosed)
   ("11.DotSmallBlank" acArrowSmall)
   ("12.None" acArrowNone)
   ("13.Oblique" acArrowOblique)
   ("14.BoxFilled" acArrowBoxFilled)
   ("15.Box" acArrowBoxBlank)
   ("16.ClosedBlank" acArrowClosedBlank)
   ("17.DatumTriangleFilled" acArrowDatumFilled)
   ("18.DatumTriangle" acArrowDatumBlank)
   ("19.Integral" acArrowIntegral)
   ("20.ArchitecturalTick" acArrowArchTick)))
 (setq lst (list (mapcar 'car lst) (mapcar 'cadr lst)))
 (if
  (and 
   (princ "\nChon cac Leader can thay doi Arrowhead...")
   (setq ss (ssget '((0 . "LEADER,DIMENSION"))))
   (not (initget (strcat (L->Ptr (car lst)) " _" (L->Ptr (cadr lst)))))
   (setq txt (getkword (strcat "\nNhap 1 tuy chon tu 01 den 20 : "))))
  (repeat (setq i (sslength ss))
   (if (eq (cdr (assoc 0 (entget (setq ent (ssname ss (setq i (1- i))))))) "LEADER")
    (vla-put-ArrowheadType (vlax-ename->vla-object ent) (eval (read txt)))
(progn
     (vla-put-Arrowhead1Type (vlax-ename->vla-object ent) (eval (read txt)))
     (vla-put-Arrowhead2Type (vlax-ename->vla-object ent) (eval (read txt)))))))
 (princ))
 

Cám ơn bạn Ha nhiều nhé. lisp rất trực quan, chọn leader rồi đưa ra bảng chọn hết các loại luôn, quá tuyệt vời.

cám ơn bạn nhiều, chúc bạn mạnh khỏe và thành công trong công việc


<<

Filename: 241582_ha.lsp
Tác giả: NguyenNgocSon
Bài viết gốc: 158000
Tên lệnh: srt
Lisp cộng - trừ - nhân - chia 2 hàng số cho ra hàng thứ 3

Cái này mình viết hồi mới tập tọe Lisp, dùng có mấy lần rồi chẳng bao giờ dùng nữa. có thể có những lỗi người viết không...

>>

Cái này mình viết hồi mới tập tọe Lisp, dùng có mấy lần rồi chẳng bao giờ dùng nữa. có thể có những lỗi người viết không lường trước vì hồi đó còn gà. Nếu dùng nó gặp lỗi gì thì thông báo lại để mình sửa.

;===========================================================================
(prompt"\nCmd:SRT-  by Thaistreetz - huuthais@yahoo.com\n")
;===========================================================================
(defun c:srt (/ cmd ss lst data i lst1 lst2)
(setq ctnc (cond (ctnc) ("Cong")))
(initget "Cong Tru Nhan CHia")
(setq ctnc (cond ((getkword (strcat "\nChon phep tinh:  <" ctnc ">"))) (ctnc)))
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(command "ucs" "world")
(prompt"\nChon hang-cot text thu nhat\n")
(if (setq ss1 (ssget (list (cons 0 "TEXT"))))
(progn
(setq lst1 (vl-sort (mapcar 'entget (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss1))))
		   '(lambda (x y) (if (equal (car(setq x1 (cdr (assoc 10 x)))) (car(setq y1 (cdr (assoc 10 y)))))
				      (> (cadr x1) (cadr y1)) (< (car x1) (car y1))))))))
(prompt"\nChon hang-cot text thu 2\n")
(if (setq ss2 (ssget (list (cons 0 "TEXT"))))
(if (< (- (cadr (cdr(assoc 10 (nth 0 lst1)))) (cadr (cdr(assoc 10 (nth 1 lst1))))) 
                (- (car (cdr(assoc 10 (nth 1 lst1)))) (car (cdr(assoc 10 (nth 0 lst1))))))
	(setq lst2 (vl-sort (mapcar 'entget (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss2))))
                       '(lambda (x y) (if (equal (car(setq x2 (cdr (assoc 10 x)))) (car(setq y2 (cdr (assoc 10 y)))))
                        (> (cadr x2) (cadr y2))  (< (car x2) (car y2))))))
	(setq lst2 (vl-sort (mapcar 'entget (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss2))))
                       '(lambda (x y) (if (equal (car(setq x2 (cdr (assoc 10 x)))) (car(setq y2 (cdr (assoc 10 y)))))
                        (< (cadr x2) (cadr y2)) (> (car x2) (car y2))))))
	))
(if (/= (sslength ss2) (sslength ss1)) (alert "\n    Hai tap hop text co so \ndoi tuong khong bang nhau!")
(progn
 (setq ptkq (getpoint "\nChon diem ghi ket qua hoac enter de ghi ket qua vao hang-cot text khac\n"))
 (if (= ptkq nil) 
 (progn
(prompt"\nChon hang-cot text ghi ket qua\n")
(if (setq ss3 (ssget (list (cons 0 "TEXT"))))
(progn
(setq lst3 (vl-sort (mapcar 'entget (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss3))))
		   '(lambda (x y) (if (equal (car(setq x3 (cdr (assoc 10 x)))) (car(setq y3 (cdr (assoc 10 y)))))
				      (> (cadr x3) (cadr y3))  (< (car x3) (car y3))))))))
(if (/= (sslength ss2) (sslength ss3)) (alert "\nTap hop text ghi ket qua \nthua hoac thieu doi tuong!"))
 );progn
 );if
);progn
);if
;----------------------------------
(command "undo" "be")
(setq angbs (getvar "angbase"))
(setq oldos (getvar "osmode"))
(setq Ladim (getvar "Dimzin"))
(setq olstyle (getvar "textstyle"))
(setq olcol (getvar "CEColor"))
(setvar "Dimzin" 0)
(setq txti 0)

(while (< txti (sslength ss1))
(if (eq ctnc "Cong") (setq kqi (+ (atof (cdr(assoc 1 (nth txti lst1)))) (atof (cdr(assoc 1 (nth txti lst2)))))))
(if (eq ctnc "Tru")  (setq kqi (- (atof (cdr(assoc 1 (nth txti lst1)))) (atof (cdr(assoc 1 (nth txti lst2)))))))
(if (eq ctnc "Nhan") (setq kqi (* (atof (cdr(assoc 1 (nth txti lst1)))) (atof (cdr(assoc 1 (nth txti lst2)))))))
(if (eq ctnc "CHia") (setq kqi (/ (atof (cdr(assoc 1 (nth txti lst1)))) (atof (cdr(assoc 1 (nth txti lst2)))))))
(if ptkq
 (progn
 (if (< (- (cadr (cdr(assoc 10 (nth 0 lst1)))) (cadr (cdr(assoc 10 (nth 1 lst1))))) 
    (- (car (cdr(assoc 10 (nth 1 lst1)))) (car (cdr(assoc 10 (nth 0 lst1)))))) 
 (setq ptkqi (list (car (cdr(assoc 10 (nth txti lst1)))) (cadr ptkq)))
 (setq ptkqi (list (car ptkq) (cadr (cdr(assoc 10 (nth txti lst1)))))))
 (command "textstyle" (cdr(assoc 7 (nth txti lst1))) "osmode" 0 "angbase" 0 "color" 1)
 (command "text" ptkqi (cdr(assoc 40 (nth txti lst1))) (/ (* 180 (cdr(assoc 50 (nth txti lst1)))) pi) (rtos kqi 2 2))
 );progn
 (entmod (subst (cons 1 (rtos kqi 2 2)) (assoc 1 (nth txti lst3)) (nth txti lst3)))
);if
(setq txti (1+ txti))
);while
;----------------------------------
(command "ucs" "p")
(setvar "textstyle" olstyle)
(setvar "Dimzin" Ladim)
(setvar "CECOLOR" olcol) 
(setvar "angbase" angbs)
(setvar "osmode" oldos)
(command "undo" "e")
(setvar "cmdecho" cmd)
(princ)
)

Lisp rất hay.Tuy nhiên mình muốn chuyển giá trị text kết quả thành màu xanh thì làm thế nào.

Trường hợp chuyển thành màu 3 khi ghi kết quả là màn hình là ok.

Trường hợp chọn nhóm text ghi nội dung chưa làm được ?

Cám ơn !


<<

Filename: 158000_srt.lsp
Tác giả: hoquangvinh
Bài viết gốc: 407938
Tên lệnh: tc td
edit nhanh 1 nhóm text trong cad

dùng cách Find and Replace không khả thi, và co bất cập, vì như vậy chỉ thay thế tất cả các ký tự "10" thành "32a150"

===> chưa...

>>

dùng cách Find and Replace không khả thi, và co bất cập, vì như vậy chỉ thay thế tất cả các ký tự "10" thành "32a150"

===> chưa giải quyết được vấn đề.

 

Nếu bản vẽ của bạn chỉ có 1 loại thép 10-32a150, bạn có thể ẩn hết các đương kích thước đi, rồi copy text theo lệnh TC

 

(defun copy-add-text-content (mode / err oer sta res sel mtx dim chc chg
hig sor rdw dec temp
sou data)
;
(defun err(s)
(if (and (/= s "Function cancelled")(/= s "quit / exit abort"))
(princ (strcat "\n--->> Error: " s))
)
(res)
)
;
(defun res()
(if hig (setvar "HighLight" hig))
(if sor (setvar "Sortents" sor))
(if pst (setvar "Pickstyle" pst))
(if rdw (chc 0))
(command "_.Undo" "_End")
(setq *error* oer)
(setvar "Cmdecho" 1)
(princ)
)
;
(defun sta()
(setq oer *error*
*error* err
hig (getvar "HighLight")
sor (getvar "Sortents")
pst (getvar "Pickstyle")
dec (getvar "Dimdec")
)
(setvar "Cmdecho" 0)
(command "_.Undo" "_Group")
(setvar "HighLight" 1)
(setvar "Sortents" 1)
(setvar "Pickstyle" 0)
(graphscr)
)
;
(defun sel(/ loop lis typ intro)
(if (null del-mode)(setq del-mode "0"))
(if (null mat-mode)(setq mat-mode "0"))
(setq loop T
lis '("TEXT" "MTEXT" "DIMENSION" "ARCALIGNEDTEXT")
)
(if (= mode 0)
(setq intro "\nSelect copy source text ")
(setq intro "\nSelect additon source text ")
)
(while loop
(initget "Exit Delete Match MD DM")
;(setq del T);;;
(setq sou (entsel (strcat intro ": ")))
(cond
((= sou "Exit")(exit))
((null sou)(exit))
((= sou "Delete")
(if (= del-mode "0")
(setq del-mode "1")
(setq del-mode "0")
)
)
((= sou "Match")
(if (= mat-mode "0")
(setq mat-mode "1")
(setq mat-mode "0")
)
)
((or (= sou "MD")(= sou "DM"))
(progn
(if (= del-mode "0")
(setq del-mode "1")
(setq del-mode "0")
)
(if (= mat-mode "0")
(setq mat-mode "1")
(setq mat-mode "0")
)
)
)
((progn
(setq data (entget (car sou))
typ (cdr (assoc 0 data))
)
(if (not (member typ lis))
(princ "Invalid selection.")
(progn
(setq temp (assoc 1 data)
loop nil
)
(cond
((= typ "MTEXT")(mtx))
((= typ "DIMENSION")(dim))
)
)
); if end
))
); cond end
)
(chc 1)
(setq rdw T)
)
;
(defun mtx(/ con test)
(setq con (cdr temp)
test (substr con 1 1)
)
(if (= test "\\")(setq temp (cons 1 (substr con 5))))
)
;
(defun dim(/ con)
(setq con (cdr temp))
(if (or (= con "")(= con "<>"))
(setq temp (cons 1 (rtos (cdr (assoc 42 data)) 2 dec)))
)
)
;
(defun chc(mode / col)
(cond
((and (= del-mode "1") (= mat-mode "0"))(setq col "230"))
((and (= del-mode "0") (= mat-mode "1"))(setq col "110"))
((and (= del-mode "1") (= mat-mode "1"))(setq col "30"))
((setq col "140"))
)
(if (= mode 0)
(progn
(command "_.Chprop" sou "" "_Color" "BYLAYER" "")
(redraw (car sou) 4)
)
(progn
(command "_.Chprop" sou "" "_Color" col "")
(redraw (car sou) 3)
)
)
)
;
(defun chg(/ ss inc data-)
(if (= mode 0)
(princ "\nSelect destiantion texts to change: ")
(princ "\nSelect destiantion texts to add: ")
)
(setq ss (ssget '((-4 . "<OR")
(0 . "TEXT")(0 . "MTEXT")(0 . "DIMENSION")(0 . "ARCALIGNEDTEXT")
(-4 . "OR>")
)))
(if (null ss)(exit))
(setq inc 0)
(repeat (sslength ss)
(setq data- (entget (ssname ss inc))
inc (1+ inc))
(if (= mode 1)
(setq temp (cons 1 (strcat (cdr (assoc 1 data-)) "x" (cdr temp))))
)
(entmod (subst temp (assoc 1 data-) data-))
)
(if (= mat-mode "1")
(progn
(if rdw (chc 0))
(command "_.MatchProp" sou ss "")
)
)
(if (= del-mode "1")
(progn
(entdel (car sou))
(setq rdw nil)
)
)
)
;
(sta)
(sel)
(chg)
(res)
)

(defun c:TC()(copy-add-text-content 0))
(defun c:TD()(copy-add-text-content 1))
(princ)

lisp này dùng tốt rồi nhưng nếu muốn đổi màu các đối tuợng đã thay đổi giá trị thì làm sao nhỉ

nhờ các bạn giúp đỡ với


<<

Filename: 407938_tc_td.lsp
Tác giả: Bee
Bài viết gốc: 423370
Tên lệnh: test
LISP CHUYỂN MÀU LAYER
58 phút trước, DuongTrungHuy đã nói:

Nếu Quang gặp khó khăn khi...

>>
58 phút trước, DuongTrungHuy đã nói:

Nếu Quang gặp khó khăn khi muốn trở về màu thành Bylayer thì dùng cái này thử xem.

Xài tạm vì chưa thử nhiều (mới thử trên bản vẽ của Bạn sau khi cùng lệnh ColorX của Tây).

Lệnh là:    Re_Color

 

(Defun LaydsBlock(/ ds dsphu ds1)
  (setq ds (tblnext "Block"T) dsBlock (list (cdr (assoc 2 ds))) dsphu (list (cons (cdr (assoc 2 ds)) (list ds))))
  (while (/= ds nil)
    (setq ds (tblnext "Block") ds1 (cdr (assoc 2 ds)))
    (if (/= ds nil)
    (Progn
      (If (/= (substr ds1 1 1) "*")
      (Setq dsBlock (append dsBlock (list ds1)) dsphu (append dsphu (list (cons ds1 (list ds))))))
    )
    )
  )
)  


(Defun c:Re_Color()  
  (LaydsBlock)
  (command "Undo" "be")  
  (Foreach pt dsblock
    (command "bedit" pt) (command "change" "all" "L" "" "P" "COLOR" "Bylayer" "") (command "BCLOSE" "")
  )
  (command "change" "all" "L" "" "P" "COLOR" "Bylayer" "")
  (command "Undo" "e")  
)

Hì hì, bác Huy tham khảo cái này, chứ làm theo của bác em thấy hơi hoa mắt ^_^ 

acbylayer 

;;;Lee_Mac
(defun c:test  (/ d)
  (vlax-for b  (vla-get-blocks (setq d (vla-get-activedocument (vlax-get-acad-object))))
    (if (and (= :vlax-false (vla-get-isxref b)) (not (wcmatch (vla-get-name b) "`*D*,_*")))
      (vlax-for o b (vl-catch-all-apply 'vla-put-color (list o acbylayer)))
      )
    )
  (vla-regen d acallviewports)
  (princ)
  )
(vl-load-com)
(princ)

 


<<

Filename: 423370_test.lsp
Tác giả: tanhung112003
Bài viết gốc: 364331
Tên lệnh: xcd
Nhờ viết lisp dim kích thước các pline và xuất ra file cel

 

 Tặng bạn. Lệnh xcd, line hay pline đều ok.

(defun c:xcd ( / tapchon fn dt m...
>>

 

 Tặng bạn. Lệnh xcd, line hay pline đều ok.

(defun c:xcd ( / tapchon fn dt m )
	(setq	tapchon (ssget '((-4 . "<OR")
                         (0 . "LINE")
						 (-4 . "<AND") (0 . "LWPOLYLINE") (70 . 0)(-4 . "AND>")
						 (-4 . "OR>")))
			fn	(getfiled "Chon Noi Luu File" (getvar "dwgprefix") "csv" 1)
			fn	(open fn "w")
	)
	(repeat (sslength tapchon)
			(setq	dt (ssname tapchon 0)
					tapchon (ssdel dt tapchon)
					dt	(entget dt)
					dt	(vl-remove-if-not
										'(lambda (x) (or (= (car x) 10) (= (car x) 11) ) ) dt
						)
					m	0
			)
			(repeat	(1- (length dt) )
					(setq	chieudai (distance (cdr (nth m dt)) (cdr (nth (+ m 1) dt)))
							m	(1+ m)
					)
					(write-line (rtos chieudai 2 3) fn)			
			)
	)
	(close fn)
	(princ)	
)

Giup em sua lai cho nay la chieu dai day cung di bac,em xuat no ra khoang cach điểm đầu và điểm cuối của cung bác ạ.


<<

Filename: 364331_xcd.lsp

Trang 249/304

249