Jump to content
InfoFile
Tác giả: phamthanhbinh
Bài viết gốc: 122824
Tên lệnh: nst
Hỏi: Cách nội suy tâm đường tròn 3D

Chào các bác,
Đây là cái lisp mình sửa lại bỏ các hàm gọi command của CAD và thay bằng các hàm trong lisp. Mình sử dụng sự trợ giúp của bác Dương Trung Huy để lấy tâm và bán kính của vòng tròn đi qua ba điểm không thẳng hàng


Kết quả mình có vài nhận xét như sau:
1/- Quả nhiên là lisp chạy nhanh hơn hẳn về tốc độ.
2/- Khi số lượng đối tượng đủ lớn,...
>>

Chào các bác,
Đây là cái lisp mình sửa lại bỏ các hàm gọi command của CAD và thay bằng các hàm trong lisp. Mình sử dụng sự trợ giúp của bác Dương Trung Huy để lấy tâm và bán kính của vòng tròn đi qua ba điểm không thẳng hàng


Kết quả mình có vài nhận xét như sau:
1/- Quả nhiên là lisp chạy nhanh hơn hẳn về tốc độ.
2/- Khi số lượng đối tượng đủ lớn, lisp chạy bị lỗi xóa không hết các vòng tròn cần xóa bởi lệnh (entdel (cadr cir)) thay vì (command "erase" (cadr cir) "")
3/- Khi chạy lisp các vòng tròn được tạo bởi hàm enmake xuất hiện chỉ sau khi có hàm thông báo alert, khác với khi dùng lệnh command "circle" của CAD.
Khi đó các vòng tròn xuất hiện lần lượt trứớc khi bảng thông báo alert xuất hiện. Điều này chừng nào đó gây khó hiểu cho người dùng.
4/- Kết luận của mình, có nhẽ chậm mà chắc, cứ nên xài thằng command của CAD có nhẽ nó ổn định và theo đúng ý đồ của người viết hơn các bác nhể.
5/- Các bác có thể giải thích được vì sao có những hiện tượng như vầy hay không, phải chăng các hàm lisp nó chạy nhanh quá nên bỏ sót lỗi????
Chúc các bác luôn vui.
<<

Filename: 122824_nst.lsp
Tác giả: Tot77
Bài viết gốc: 287650
Tên lệnh: test
Lisp xuất text khối lượng sang excell theo hàng và cột

Bạn không cài Express sao? nên mới có lỗi như vậy, tôi sửa lại như sau.

Bạn có thể chọn 1 lượt nhưng bảo đàm là text số liệu phải trong layer "DIENDIENTICH".

 

(defun c:test(/ file L L1 n)
  (defun dxf(id v) (cdr (assoc id (entget v))))
  (defun layText() (dxf 1 (nth (setq n (1+ n)) L1)))
  (defun ssto(ss) (if ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) nil))
 ...
>>

Bạn không cài Express sao? nên mới có lỗi như vậy, tôi sửa lại như sau.

Bạn có thể chọn 1 lượt nhưng bảo đàm là text số liệu phải trong layer "DIENDIENTICH".

 

(defun c:test(/ file L L1 n)
  (defun dxf(id v) (cdr (assoc id (entget v))))
  (defun layText() (dxf 1 (nth (setq n (1+ n)) L1)))
  (defun ssto(ss) (if ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) nil))
  ;;;
  (setq file (open (strcat (getvar "dwgprefix") "Dao dap.txt") "a"))
  (write-line "S bun\tS dao\tS dap duong\tS dap bp kenh" file)
  (setq L (vl-sort (ssto (ssget '((0 . "*TEXT")(8 . "DIENDIENTICH") (1 . "~**"))))
       '(lambda(x y) (< (car (dxf 11 x)) (car (dxf 11 y))))))
  (while L
    (setq L1 (vl-remove nil (mapcar '(lambda(x)
(if (equal (car (dxf 11 x)) (car (dxf 11 (car L))) 1) x nil)) L))
 L1 (vl-sort L1 '(lambda(x y) (> (cadr (dxf 11 x)) (cadr (dxf 11 y)))))
 L (vl-remove nil (mapcar '(lambda(x)(if (member x L1) nil x )) L))
 n -1)    
    (while (< n (1- (length L1)))
      (write-line (strcat (layText) "\t"  (layText) "\t" (layText) "\t" (layText)) file))
  )
  (close file)
)
 


<<

Filename: 287650_test.lsp
Tác giả: NguyenNdait
Bài viết gốc: 122455
Tên lệnh: noisuy
Hỏi: Cách nội suy tâm đường tròn 3D
Mình thử viết lại chương trình của ptbinh theo hướng :
Chọn tập hợp gồm n điểm (Ví dụ: Cho n = 5 ta có : tập hợp (1 2 3 4 5) phần tử. trong đó 1 = p1 2 = p2 ...)
Tìm tập hợp là tổ hợp chập 3 của n phần tử như trên
((123) (124) (125) (134) (135) (145) (234) (235) (245) (345))
Tìm tâm của các đtròn trên bằng cách giải hệ 2 phương trình đường tròn qua 3 điểm.
(1 ptrình đtròn...
>>
Mình thử viết lại chương trình của ptbinh theo hướng :
Chọn tập hợp gồm n điểm (Ví dụ: Cho n = 5 ta có : tập hợp (1 2 3 4 5) phần tử. trong đó 1 = p1 2 = p2 ...)
Tìm tập hợp là tổ hợp chập 3 của n phần tử như trên
((123) (124) (125) (134) (135) (145) (234) (235) (245) (345))
Tìm tâm của các đtròn trên bằng cách giải hệ 2 phương trình đường tròn qua 3 điểm.
(1 ptrình đtròn đc làm cho suy biến bằng cách cho nó đi qua gốc tọa độ)
Vẽ pline qua các điiểm này.
Cụ thể như sau :

@Duyminh86: Bạn chạy thử xem và cho ý kiến tiếp theo phải làm gì nhé . Hoặc giả mình không hiểu đc ý bạn ở chỗ nào ? Chúng ta sẽ cùng làm tiếp.
<<

Filename: 122455_noisuy.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 122796
Tên lệnh: nst
Hỏi: Cách nội suy tâm đường tròn 3D


Chào bác Tue_NV,
Rất cám ơn bác đã góp ý.
Ý 1 và ý 3 của bác mình đã bổ sung được vào lisp và có thể nói là khá yên tâm.
Tuy nhiên ở ý 2, việc khống chế giá trị của bán kính vòng tròn phải nhỏ hơn Dmax/2 theo mình là chưa hợp lý lắm vì thực tế với một tam giác đều hay ngũ giác đều thì bán kính vòng tròn ngoại tiếp của nó lớn hơn 1/2 cái đường chéo của nó bác...
>>

Chào bác Tue_NV,
Rất cám ơn bác đã góp ý.
Ý 1 và ý 3 của bác mình đã bổ sung được vào lisp và có thể nói là khá yên tâm.
Tuy nhiên ở ý 2, việc khống chế giá trị của bán kính vòng tròn phải nhỏ hơn Dmax/2 theo mình là chưa hợp lý lắm vì thực tế với một tam giác đều hay ngũ giác đều thì bán kính vòng tròn ngoại tiếp của nó lớn hơn 1/2 cái đường chéo của nó bác ạ, (với tam giác đều thì là cạnh). Vì thế theo mình nghĩ thì việc khống chế bán kính này nên lấy ở giá trị (Dmax / (sqrt 2)) có nhẽ sẽ hợp lý hơn bác ạ.
Vì thế mình đã bổ sung thành cái lisp như sau, rất mong các bác góp ý để hoàn thiện nó.


@Bác NguyenNdait,
Việc dùng hàm entmake trong trường hợp này sẽ phải lập công thức tính toán tọa độ tâm và bán kính của vòng tròn qua ba điểm cho trước. Về Lý thuyết hoàn toàn khả thi song thực tế ngồi mò mẫm lại cái đám công thức phổ thông này cũng hơi đau đầu bác ạ vả cũng khá dài dòng. Việc này mong bác thư thư cho một chút để mình còn mò mẫm chứ chưa thử ngay được bác ạ.
<<

Filename: 122796_nst.lsp
Tác giả: NguyenNdait
Bài viết gốc: 123104
Tên lệnh: noisuy
Hỏi: Cách nội suy tâm đường tròn 3D

Mình viết ctrình này như sau :

Tốc độ rất đạt. Nên có thể dùng trong 3D đc với đk phải chia tập hợp n điểm ban đầu thành nhiều tập con chỉ gồm những điểm đồng phẳng.
(P1 P2 . . . Pn) -> ((Pni Pnk ...) (...)) Trong đó (Pn Pnk ... ) là tập hợp con chỉ gồm các điểm có cùng độ cao z

Filename: 123104_noisuy.lsp
Tác giả: Tot77
Bài viết gốc: 287733
Tên lệnh: test
Lisp xuất text khối lượng sang excell theo hàng và cột

Vậy dùng cái này, nhưng phải thống nhất 1 kiểu S, vì lisp sẽ xem "S bùn:" khác với "Sbùn:" hay "S bùn  :" 

(defun c:test(/ file L L0 L1 st st1 n os)
  (defun dxf(id v) (cdr (assoc id (entget v))))
  (defun layText(L / as) (if (setq as (assoc (nth (setq n (1+ n)) st) L)) (cadr as) ""))
  (defun ssto(ss) (if ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) nil))
  (defun battext(vt / ss) (if (setq ss...
>>

Vậy dùng cái này, nhưng phải thống nhất 1 kiểu S, vì lisp sẽ xem "S bùn:" khác với "Sbùn:" hay "S bùn  :" 

(defun c:test(/ file L L0 L1 st st1 n os)
  (defun dxf(id v) (cdr (assoc id (entget v))))
  (defun layText(L / as) (if (setq as (assoc (nth (setq n (1+ n)) st) L)) (cadr as) ""))
  (defun ssto(ss) (if ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))) nil))
  (defun battext(vt / ss) (if (setq ss (ssget "C" vt (polar vt 0 -5) '((0 . "TEXT") (1 . "S*")))) (dxf 1 (ssname ss 0)) nil))
  (defun leftList(L n) (reverse (member (nth (1- n) L) (reverse L))))
  (defun rightList(L n) (member (nth n L) L))
  (defun tach(L / n n1) (setq n -1)
    (repeat (1- (length L))
      (if (not (equal (dxf 11 (nth (setq n (1+ n)) L)) (dxf 11 (nth (1+ n) L)) 10)) (setq n1 (1+ n))))
    (setq L0 (append L0 (list (leftList L n1))) L0 (append L0 (list (rightList L n1)))))
 
  ;;;  
  (setq file (open (strcat (getvar "dwgprefix") "Dao dap.txt") "a")
L (vl-sort (ssto (ssget '((0 . "*TEXT")(8 . "DIENDIENTICH") (1 . "~**"))))
  '(lambda(x y) (< (car (dxf 11 x)) (car (dxf 11 y)))))
L0 nil
st nil
os (getvar "osmode"))
  (setvar "osmode" 0)
  (while L
    (setq L1 (vl-remove nil (mapcar '(lambda(x)
(if (equal (car (dxf 11 x)) (car (dxf 11 (car L))) 1) x nil)) L))
 L1 (vl-sort L1 '(lambda(x y) (> (cadr (dxf 11 x)) (cadr (dxf 11 y)))))
 L (vl-remove nil (mapcar '(lambda(x)(if (member x L1) nil x )) L)))
    (tach L1))
  
   (setq L0 (mapcar '(lambda(Lv)
              (mapcar '(lambda(x) (if (and (setq bt (battext (dxf 11 x))) (not (member bt st)))
  (setq st (append st (list bt))))
(list bt (dxf 1 x))) Lv)) L0)
n -1 st1 "")
  
  (write-line (repeat (length st) (setq st1 (strcat st1 (nth (setq n (1+ n)) st) "\t"))) file)
  (foreach Lv L0
    (setq n -1 st1 "")
    (repeat (length st) (setq st1 (strcat st1 (laytext Lv) "\t")))
    (write-line st1 file))
  
  (setvar "osmode" os)
  (close file)
)
 


<<

Filename: 287733_test.lsp
Tác giả: HungDHXD
Bài viết gốc: 264626
Tên lệnh: main
Gọi form vba bằng lisp

Bạn thêm đoạn mã sau vào module1 trong file DVB của mình :

 

Sub main()
    AutoShopDrawing.show
End Sub

 

 

** Tạo 1 lisp :

 

(defun C:Main()
(command "-VBARUN" "main")
)

--> load cả 2 file DVD và lisp trên vào : gõ lệnh Main ===> thưởng thức và báo kết quả

Sub...
>>

Bạn thêm đoạn mã sau vào module1 trong file DVB của mình :

 

Sub main()
    AutoShopDrawing.show
End Sub

 

 

** Tạo 1 lisp :

 

(defun C:Main()
(command "-VBARUN" "main")
)

--> load cả 2 file DVD và lisp trên vào : gõ lệnh Main ===> thưởng thức và báo kết quả

Sub main()
    AutoShopDrawing.show
 

 

Sub main()
    AutoShopDrawing.show
 

 

Sub main()
    AutoShopDrawing.show
End Sub

 

 

 

(defun C:Main()
(command "-VBARUN" "main")
)

 

 

Sub main()
    AutoShopDrawing.show
End Sub
 
Sau đó tạo 1 lisp với nội dung như sau :
(defun C:Main()
(command "-VBARUN" "main")
)
 
****==> load cả 2 file DVB, và lisp trên vào 
Tại autocad gõ lệnh Main --> và thưởng thức !!!

<<

Filename: 264626_main.lsp
Tác giả: tranpro
Bài viết gốc: 278612
Tên lệnh: ddd
đo đường polyline

bác ơi có thể chỉnh để nó xuất hiện 1 text duy nhất ghi kích của cả đoạn pline đó được ko nhỉ? chứ nó ghi tất các text mỗi đoạn trong pline ra thì rối hình quá :D

;dim nhanh
(defun c:DDD( / sel pl pre group)
(setq sel (car (entsel "\nChon polyline: ")))
(command ".copy" sel "" (list 0 0 0) "@0,0,0")
(setq pl (entlast))
(command ".explode" pl)
(setq pre pl
	group (ssadd)
	)
(while (setq pre (entnext...
>>

bác ơi có thể chỉnh để nó xuất hiện 1 text duy nhất ghi kích của cả đoạn pline đó được ko nhỉ? chứ nó ghi tất các text mỗi đoạn trong pline ra thì rối hình quá :D

;dim nhanh
(defun c:DDD( / sel pl pre group)
(setq sel (car (entsel "\nChon polyline: ")))
(command ".copy" sel "" (list 0 0 0) "@0,0,0")
(setq pl (entlast))
(command ".explode" pl)
(setq pre pl
	group (ssadd)
	)
(while (setq pre (entnext pre))
		(setq group (ssadd pre group))
)
(setq i 0)
(while (< i (sslength group))
(progn
(setq ename (ssname group i)
	info (entget ename)
	)
(command ".DIMALIGNED" (cdr (assoc 10 info)) (cdr (assoc 11 info)) (polar (cdr (assoc 10 info)) (+ (angle (cdr (assoc 10 info)) (cdr (assoc 11 info))) (/ pi 2)) 10))
(setq i (1+ i))
))
(command ".erase" group "")
(princ)
)


<<

Filename: 278612_ddd.lsp
Tác giả: namnhim
Bài viết gốc: 287850
Tên lệnh: mcha
Nối các line, arc, lwpolyline không chạm nhau

Trước khi dùng:
pedit_Truoc.gif

>>

Trước khi dùng:
pedit_Truoc.gif

Sau khi dùng:
pedit_Sau.gif

có thể dùng Lisp nào dùng để nối nó được không anh

Cái này có thể dùng lisp này giải quyết đơn giản hơn không cần quan tâm đến không cách xa hay gần.

(defun c:mcha ( / *error* mid AssocOn ss i ent p1 p2 lin linn lins flins ptlst1 pt1 pt11 ptlst2 pt2 pt22 chpts chamfers )
  (vl-load-com)  
  (defun *error* ( msg )
    (if chma (setvar 'chamfera chma))
    (if chmb (setvar 'chamferb chmb))
    (if chmm (setvar 'chammode chmm))
    (vla-endundomark (vla-get-activedocument (vlax-get-acad-object))))
  (defun mid ( p1 p2 )
    (mapcar '(lambda ( a b ) (/ (+ a b) 2.0)) p1 p2))
  (defun AssocOn ( SearchTerm Lst func fuzz )
    (car (vl-member-if (function
          (lambda (pair) (equal SearchTerm (apply func (list pair)) fuzz))) lst)))
  (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
  (mapcar 'set '(chma chmb chmm) (mapcar 'getvar '(chamfera chamferb chammode)))
  (mapcar 'setvar '(chamfera chamferb chammode) '(0 0 0))
  (prompt "\nSelect line entities")
  (while (not (setq ss (ssget "_:L" '((0 . "LINE"))))))
  (setq i -1)
  (while (setq ent (ssname ss (setq i (1+ i))))
    (setq p1 (trans (vlax-curve-getstartpoint ent) 0 1))
    (setq p2 (trans (vlax-curve-getendpoint ent) 0 1))
    (setq lin (list p1 p2))
    (setq lins (cons lin lins)))
  (setq flins (apply 'append lins))
  (foreach lin lins
    (setq ptlst1 (vl-sort flins '(lambda ( a b ) (< (distance (car lin) a) (distance (car lin) b)))))
    (if (equal (cadr ptlst1) (cadr lin) 1e-8) (setq pt1 (caddr ptlst1)) (setq pt1 (cadr ptlst1)))
    (if (setq linn (assocon pt1 lins 'car 1e-8)) (setq pt11 (mid (car linn) (cadr linn))))
    (if (setq linn (assocon pt1 lins 'cadr 1e-8)) (setq pt11 (mid (car linn) (cadr linn))))
    (setq ptlst2 (vl-sort flins '(lambda ( a b ) (< (distance (cadr lin) a) (distance (cadr lin) b)))))
    (if (equal (cadr ptlst2) (car lin) 1e-8) (setq pt2 (caddr ptlst2)) (setq pt2 (cadr ptlst2)))
    (if (setq linn (assocon pt2 lins 'car 1e-8)) (setq pt22 (mid (car linn) (cadr linn))))
    (if (setq linn (assocon pt2 lins 'cadr 1e-8)) (setq pt22 (mid (car linn) (cadr linn))))
    (setq chpts (list pt11 (mid (car lin) (cadr lin))) chamfers (cons chpts chamfers) chpts (list pt22 (mid (car lin) (cadr lin))) chamfers (cons chpts chamfers)))
  (foreach chpts chamfers
    (command "_.chamfer" (car chpts) (cadr chpts)))
  (*error* nil) (princ))

<<

Filename: 287850_mcha.lsp
Tác giả: Tot77
Bài viết gốc: 288132
Tên lệnh: copytext
Nhờ giúp viết lại lisp copy text từ cad ra excel

Bạn sửa lại như thế này, khi nó hỏi có chép đè lên file cũ không thì bạn cứ mạnh dạn ok nhé. :)

 

(defun c:copytext (/ hangdau)
  (defun sosanh (e1 e2 / p1 p2)
    (setq p1 (car e1)
 p2 (car e2)
    )
    (if (equal (cadr p1) (cadr p2) fuzz)
      (< (car p1) (car p2))
      (> (cadr p1) (cadr p2))
   ...
>>

Bạn sửa lại như thế này, khi nó hỏi có chép đè lên file cũ không thì bạn cứ mạnh dạn ok nhé. :)

 

(defun c:copytext (/ hangdau)
  (defun sosanh (e1 e2 / p1 p2)
    (setq p1 (car e1)
 p2 (car e2)
    )
    (if (equal (cadr p1) (cadr p2) fuzz)
      (< (car p1) (car p2))
      (> (cadr p1) (cadr p2))
    )
  )
  (setq
    ss    (ssget '((0 . "TEXT")))
    lst    (ss2ent ss)
    lst    (mapcar '(lambda (e)
      (cons (cdr (assoc 10 (entget e)))
    (cdr (assoc 1 (entget e)))
      )
    )
   lst
   )
    caotext (cdr (assoc 40 (entget (ssname ss 0))))
    fuzz    (* caotext 1.0)
    lst    (vl-sort lst 'sosanh)
    index   1
    oldy    nil
    fn    (getfiled "Chon file de save" "" "csv" 1)
    fid    (open fn "a")
  )
  (princ "\n" fid)
  
  (foreach e lst
    (if (equal oldy (cadr (car e)) fuzz)
      (progn
(princ "," fid)
(setq index (1+ index))
      )
      (progn
(if hangdau
 (progn
   (setq index 1)
   (princ "\n" fid)
 )
 (setq hangdau t)
)
      )
    )
    (princ (cdr e) fid)
    (setq oldy (cadr (car e)))
  )
  (close fid)
)

 

Cái hàm ss2ent nếu bạn có cài Express thì thay bằng acet-ss-to-list cũng tương đương.


<<

Filename: 288132_copytext.lsp
Tác giả: duvanngoc
Bài viết gốc: 288122
Tên lệnh: vla-rename
Đổi tên Block được chọn !

Xin lỗi các bạn hôm trước mình đã sửa rồi quên up lại nên bị sai tí chút
code fix

(defun c:dt ()
  (setq oldos (getvar "osmode"))
  (setvar "osmode" 0)
  (command "undo" "be")
  (setq ten (cdr(assoc 2 (entget(car(entsel "\nChon block dien hinh: "))))))
  (princ "\nChon block can doi ten: ")
 ...
>>

Xin lỗi các bạn hôm trước mình đã sửa rồi quên up lại nên bị sai tí chút
code fix

(defun c:dt ()
  (setq oldos (getvar "osmode"))
  (setvar "osmode" 0)
  (command "undo" "be")
  (setq ten (cdr(assoc 2 (entget(car(entsel "\nChon block dien hinh: "))))))
  (princ "\nChon block can doi ten: ")
  (setq	ssc (ssget (list(cons 0 "INSERT")(cons 2 ten)))
	tm (getstring "\nNhap ten moi: ")
	)
  (command "rename" "b" ten tm)
  (command "copyclip" ssc "")
  (command "block" "block_temp" "0,0" ssc "")
  (command "insert" "block_temp" "0,0" 1 1 0)
  (setq el (entlast))
  (setq pt (car(acet-ent-geomextents el)))
  (command "undo" "e"
	   "undo" 1)
  (command "erase" ssc "")
  (command "pasteclip" pt)
  (setvar "osmode" oldos)
  )

Bạn cho hiển thị tên block cũ vào trước đoạn chèn tên block mới thì tốt, dễ kiểm soát (xem hình đính kèm)

1609588_638393552882417_6017030616240096

Mình trích

(vl-load-com)
(or *kpblc-activedoc*
    (setq *kpblc-activedoc* (vla-get-activedocument (vlax-get-acad-object)))
    ) ;_ end of or

(defun c:vla-rename (/ ent name)
  (vla-startundomark *kpblc-activedoc*)
  (if
    (and (not (vl-catch-all-error-p
		(vl-catch-all-apply
		  '(lambda ()
		     (setq ent (car (entsel "\nSelect a block to be renamed")))
		     ) ;_ end of lambda
		  ) ;_ end of vl-catch-all-apply
		) ;_ end of vl-catch-all-error-p
	      ) ;_ end of not
	 ent
	 (= (cdr (assoc 0 (entget ent))) "INSERT")
	 (/= (substr (cdr (assoc 2 (entget ent))) 1 2) "*U")
	 (not (vl-catch-all-error-p
		(vl-catch-all-apply
		  '(lambda ()
		     (setq name	(getstring t
					   (strcat "\nEnter new name <"
						   (cdr (assoc 2 (entget ent)))
						   "> : "
						   ) ;_ end of strcat
					   ) ;_ end of getstring
			   ) ;_ end of setq
		     ) ;_ end of lambda
		  ) ;_ end of vl-catch-all-apply
		) ;_ end of vl-catch-all-error-p
	      ) ;_ end of not
	 (/= (vl-string-trim " " name))
	 ) ;_ end of and
     (if (vl-catch-all-error-p
	   (vl-catch-all-apply
	     '(lambda ()
		(vla-put-name
		  (vla-item (vla-get-blocks *kpblc-activedoc*)
			    (cdr (assoc 2 (entget ent)))
			    ) ;_ end of vla-item
		  name
		  ) ;_ end of vla-put-name
		) ;_ end of lambda
	     ) ;_ end of vl-catch-all-apply
	   ) ;_ end of vl-catch-all-error-p
       (princ (strcat "\nCan't rename a block "
		      (cdr (assoc 2 (entget ent)))
		      " with new name "
		      name
		      ) ;_ end of strcat
	      ) ;_ end of princ
       ) ;_ end of if
     (princ (strcat "\nA error has been catched:"
		    "\nSelection error | Selected entity isn't a block "
		    "| It's a unnamed or dynamic block"
		    ) ;_ end of strcat
	    ) ;_ end of princ
     ) ;_ end of if
  (vla-endundomark *kpblc-activedoc*)
  (princ)
  ) ;_ end of defun 

 

đoạn code có tính năng đó lên cho bạn tham khảo:


<<

Filename: 288122_vla-rename.lsp
Tác giả: tien2005
Bài viết gốc: 288110
Tên lệnh: ofl
lisp mở file mới rồi thực hiện các lệnh trên file vừa mở

Các Bạn giúp mình lisp như sau:

1. mở 1 file

2. kiểm tra file đã được mở xong chưa

3. thực hiện các lệnh hoặc lisp khác trên file được mở ở bước 1

4. đóng file được mở ở bước 1 có tùy chọn lưu hay không lưu file

5. kiểm tra file đã được đóng xong chưa

 

Bên dưới là líp do tôi viết nhưng chưa làm được từ bước 2

(defun...
>>

Các Bạn giúp mình lisp như sau:

1. mở 1 file

2. kiểm tra file đã được mở xong chưa

3. thực hiện các lệnh hoặc lisp khác trên file được mở ở bước 1

4. đóng file được mở ở bước 1 có tùy chọn lưu hay không lưu file

5. kiểm tra file đã được đóng xong chưa

 

Bên dưới là líp do tôi viết nhưng chưa làm được từ bước 2

(defun c:ofl ()
  ;1 - mo file bat ky
  (command "ai_editcustfile"
	   (getfiled "Mo 1 file bat ki" "" "dwg" 0)
  )
  ;2 - kiem tra da mo file xong chua
  ;3 - chay cac lisp khac trong ban ve mo vua mo, vd ve duong thang, duong tron
  (entmake (list (cons 0 "line")
		 (cons 10 (list 0 0 0))
		 (cons 11 (list 1000 1000 0))
	   )
  )
  (entmake (list (cons 0 "circle")
		 (cons 10 (list 500 500 0))
		 (cons 40 500)
	   )
  )
  ;4 - close file co tuy chon save file
  ;5 - kiem tra file da duoc close xong chua(muc dich la de thuc hien tiep vong lap o buoc 1
  (princ)
)

Thanks


<<

Filename: 288110_ofl.lsp
Tác giả: Tot77
Bài viết gốc: 288111
Tên lệnh: test
Nhờ các pro sửa hộ em lisp này theo yêu cầu với ạ

Bạn dùng cái này, theo thứ tự :

- Chọn polyline

- Chọn điểm đầu polyline

- Chọn text cao độ điểm đầu

- Chọn 3 đường giới han.

 

(defun c:test(/ li dd cd cdd 3dg x y xvt)
  (defun getVertex(v / n L)
    (setq v (vlax-ename->vla-object v)      
          n 0 L nil)
    (repeat (1- (/ (length (vlax-safearray->list (vlax-variant-value...
>>

Bạn dùng cái này, theo thứ tự :

- Chọn polyline

- Chọn điểm đầu polyline

- Chọn text cao độ điểm đầu

- Chọn 3 đường giới han.

 

(defun c:test(/ li dd cd cdd 3dg x y xvt)
  (defun getVertex(v / n L)
    (setq v (vlax-ename->vla-object v)      
          n 0 L nil)
    (repeat (1- (/ (length (vlax-safearray->list (vlax-variant-value (vla-get-Coordinates v)))) 3))
      (setq L (append L (list (vlax-safearray->list (vlax-variant-value (vla-get-Coordinate v
(setq n (1+ n)))))))))
  )  
  (defun laydxf (id v) (assoc id (entget v)))  
  (defun tb(a b) (* 0.5 (+ a b)))
  
  ;;;
  (setq li (getVertex (car (entsel "\nChon polyline:")))
dd (getpoint "\nDiem bat dau:")
cdd (atof (cdr (assoc 1 (entget (setq cd (car (entsel "\nCao do diem dau:"))))))))
  
  (if (not (equal dd (car li) 1)) (setq li (reverse li)))
 
  (princ "\nChon 3 line gioi han:")
  (setq 3dg (vl-sort (mapcar '(lambda(x) (cadr (cdr (assoc 10 (entget x)))))
 (acet-ss-to-list (ssget '((0 . "LINE"))))) '<))
  (setvar "DIMZIN" 1)
  (foreach d (cdr li)
    (setq y (+ (- (cadr d) (cadr dd)) cdd)
 xvt (car (nth (1- (vl-position d li)) li))
 x (- (car d) xvt))
    
    (entmakex (list (cons 0  "TEXT") (laydxf 8 cd)
   (cons 10 (list (car d) (cadr (dxf 10 cd))))
   (cons 11 (list (car d) (cadr (dxf 11 cd))))
   (laydxf 40 cd) (laydxf 50 cd) (laydxf 72 cd) (laydxf 73 cd) 
   (cons 1 (rtos y 2 3))))
    
    (entmakex (list (cons 0  "TEXT") (laydxf 8 cd)
   (cons 10 (list (tb (car d) xvt) (tb (car 3dg) (cadr 3dg))))
   (cons 11 (list (tb (car d) xvt) (tb (car 3dg) (cadr 3dg))))
   (laydxf 40 cd) (cons 50 (if (< x 1.5) (* 0.5 pi) 0))
   (cons 72 1) (laydxf 73 cd) 
   (cons 1 (rtos x 2 3))))
    
    (entmakex (list (cons 0 "LINE") (laydxf 8 cd)
   (cons 10 (list (car d) (car 3dg)))
   (cons 11 (list (car d) (cadr 3dg)) )))
    
    (entmakex (list (cons 0 "LINE") (laydxf 8 cd)
   (cons 10 (list (car d) (last 3dg)))
   (cons 11 (list (car d) (cadr d)) )))
   )
  (princ)
)


<<

Filename: 288111_test.lsp
Tác giả: hochoaivandot
Bài viết gốc: 288302
Tên lệnh: ttt
Nhờ viết lisp xuất text từ cad sang excel dạng cột theo thứ tự chọn
Đây bạn. Test thử nếu có gì thì Reply liền nhé

Xin cảm ơn bạn. Mình mới nhờ lần đầu tiên bạn ạh và cũng là chủ đề duy nhất. Đây là file cad
http://www.cadviet.com/upfiles/3/104866_vd.dwg


(defun LM:writecsv ( lst csv / des sep )
(if (setq...
>>
Đây bạn. Test thử nếu có gì thì Reply liền nhé

Xin cảm ơn bạn. Mình mới nhờ lần đầu tiên bạn ạh và cũng là chủ đề duy nhất. Đây là file cad
http://www.cadviet.com/upfiles/3/104866_vd.dwg


(defun LM:writecsv ( lst csv / des sep )
(if (setq des (open csv "w"))
(progn
(setq sep (cond ((vl-registry-read "HKEY_CURRENT_USER\\Control Panel\\International" "sList")) (",")))
(foreach row lst (write-line (LM:lst->csv row sep) des))
(close des)
t
)
)
)
(defun LM:lst->csv ( lst sep )
(if (cdr lst)
(strcat (LM:csv-addquotes (car lst) sep) sep (LM:lst->csv (cdr lst) sep))
(LM:csv-addquotes (car lst) sep)
)
)

(defun LM:csv-addquotes ( str sep / pos )
(cond
( (wcmatch str (strcat "**"))
(setq pos 0)
(while (setq pos (vl-string-position 34 str pos))
(setq str (vl-string-subst "\"\"" "\"" str pos)
pos (+ pos 2)
)
)
(strcat "\"" str "\"")
)
( str )
)
)

(defun C:ttt(/ lst ss i el x fn)
(setq lst (list) ss (ssget (list (cons 0 "TEXT"))) )
(repeat (setq i (sslength ss))
(setq x (ssname ss (setq i (1- i))))
(setq el (entget x))
(if (= (cdr (assoc 0 el)) "TEXT")
(setq lst (append lst (list (list (cdr (assoc 1 el))))))
)
)
(setq fn (vl-filename-mktemp nil nil ".csv"))
(if (and lst (LM:WriteCSV (reverse lst) fn))
(startapp "explorer" fn)
)
)

<<

Filename: 288302_ttt.lsp
Tác giả: hiepttr
Bài viết gốc: 288193
Tên lệnh: vt
Nhờ các pro sửa hộ em lisp này theo yêu cầu với ạ

Hôm qua mạng chổ mình lỗi

Giờ mới thông, lỡ rồi, up lên cho loét luôn

Cách dùng tương tự Tot77:

;Lisp lam cho y/c nay:
;;http://www.cadviet.com/forum/topic/98661-nho-cac-pro-sua-ho-em-lisp-nay-theo-yeu-cau-voi-a/
(defun c:vt( / old VAR ent pt_lst pt1 txt base_pt y1 info t_inf chenh i  h ss j lst_ygh text n)
(command "undo" "be")
(setq old (mapcar 'getvar (setq VAR '("osmode" "cmdecho" "AUNITS"))))
(mapcar 'setvar VAR...
>>

Hôm qua mạng chổ mình lỗi

Giờ mới thông, lỡ rồi, up lên cho loét luôn

Cách dùng tương tự Tot77:

;Lisp lam cho y/c nay:
;;http://www.cadviet.com/forum/topic/98661-nho-cac-pro-sua-ho-em-lisp-nay-theo-yeu-cau-voi-a/
(defun c:vt( / old VAR ent pt_lst pt1 txt base_pt y1 info t_inf chenh i  h ss j lst_ygh text n)
(command "undo" "be")
(setq old (mapcar 'getvar (setq VAR '("osmode" "cmdecho" "AUNITS"))))
(mapcar 'setvar VAR '(0 0 1))
(while (not ent)
	(prompt "\nChon polynie: ")
	(setq ent (ssget "_+.:E:S" '((0 . "*POLYLINE"))))
)
(setq pt_lst (acet-geom-vertex-list (ssname ent 0)))
(setvar "osmode" 1)
(initget 1)
(setq pt1 (getpoint "\nChon diem bat dau polyline: "))
(cond
	((not 
		(or (equal pt1 (car pt_lst) 0.01)
			(equal pt1 (last pt_lst) 0.01)
		)
	)
	(prompt "\nDiem chon khong thuoc polyline _ vui long lam lai tu dau !")
	(mapcar 'setvar VAR old)
	(exit)
	)
	((not (equal pt1 (car pt_lst) 0.01))
	(setq pt_lst (reverse pt_lst)))
)
(setvar "osmode" 0)
(while (not txt)
	(prompt "\nChon text cao do diem bat dau: ")
	(setq txt (ssget "_+.:E:S" '((0 . "*TEXT"))))
)
(setq base_pt (cdr (assoc 10 (setq info (entget(ssname txt 0)))))
	y1 (atof (cdr (assoc 1 info)))
	chenh (- (cadr (car pt_lst)) y1)
	i 0)
(while (< i (1- (length pt_lst)))
	(setq h (- (cadr (nth (setq i (1+ i)) pt_lst)) chenh))
	(command ".copy" txt "" base_pt (list (car (nth i pt_lst)) (cadr base_pt)))
	(entmod (subst (cons 1 (rtos h 2 3)) (assoc 1 (setq t_inf (entget (entlast)))) t_inf))
)
(while (or (not ss) (/= 3 (sslength ss)))
	(prompt "\nChon 3 duong gioi han: ")
	(setq ss (ssget '((0 . "LINE"))))
)
(setq j 0)
(repeat 3
	(setq lst_ygh (cons (caddr (assoc 10 (entget (ssname ss j)))) lst_ygh)
		j (1+ j)
	)
)
(setq lst_ygh (vl-sort lst_ygh '<))
(foreach pt (cdr pt_lst)
	(entmake (list (cons 0 "LINE") (cons 10 pt) (list 11 (car pt) (last lst_ygh))))
	(entmake (list (cons 0 "LINE") (list 10 (car pt) (cadr lst_ygh)) (list 11 (car pt) (car lst_ygh))))
)
(setq n 0)
(repeat (1- (length pt_lst))
	(setq text (abs (- (car (nth (1+ n) pt_lst)) (car (nth n pt_lst)))))
	(command ".text" 
		"s" (cdr (assoc 7 info))
		"j" "MC"
		(list (/ (+ (car (nth n pt_lst)) (car (nth (1+ n) pt_lst))) 2.0) (/ (+ (car lst_ygh) (cadr lst_ygh)) 2.0))
		(cdr(assoc 40 info))
		(if (< text (* 4 (cdr(assoc 40 info)))) 90 0)
		(rtos text 2 3)
	)
	(setq n (1+ n))
)
(mapcar 'setvar VAR old)
(command "undo" "end")
(princ)
)

p/s: Chỉ là bài thực hành trong lúc chưa có bài học, mong đc chỉ giáo thêm !

:D :D :D


<<

Filename: 288193_vt.lsp
Tác giả: Tot77
Bài viết gốc: 288367
Tên lệnh: test
đếm block tuy chọn

Của bạn đây.

 

(defun c:test(/ ten soluong diem)
  (setq ten (cdr (assoc 2 (entget (car (entsel "\nChon Block:")))))
soluong (sslength (ssget (list '(0 . "INSERT") (cons 2 ten))))
diem (getpoint "\nDiem dat text:"))
  (entmakex (list (cons 0  "TEXT") (cons 10 diem) (cons 11 diem)
 (cons 40 1) (cons 1 (itoa soluong))))
  (princ)  
)

(defun c:test()
 ...
>>

Của bạn đây.

 

(defun c:test(/ ten soluong diem)
  (setq ten (cdr (assoc 2 (entget (car (entsel "\nChon Block:")))))
soluong (sslength (ssget (list '(0 . "INSERT") (cons 2 ten))))
diem (getpoint "\nDiem dat text:"))
  (entmakex (list (cons 0  "TEXT") (cons 10 diem) (cons 11 diem)
 (cons 40 1) (cons 1 (itoa soluong))))
  (princ)  
)

(defun c:test()
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (setq ten (dxf 2 (car (entsel "\nChon Block:")))
soluong (length (vl-remove nil (mapcar '(lambda(x) (if (= ten (dxf 2 x)) x nil))
      (acet-ss-to-list (ssget '((0 . "INSERT")))))))
diem (getpoint "\nDiem dat text:"))
  (entmakex (list (cons 0  "TEXT") (cons 10 diem) (cons 11 diem)
 (cons 40 1) (cons 1 (itoa soluong))))
  (princ)  
)

<<

Filename: 288367_test.lsp
Tác giả: Tot77
Bài viết gốc: 288512
Tên lệnh: test
đếm block tuy chọn

Thử cái này, text mẫu chỉ hỏi 1 lần thôi, lần sau không hỏi nữa.

(defun c:test(/ lten lsoluong ss diem diem1 n cao)
  (defun dxf(id v) (cdr (assoc id (entget v))))
  
  (princ "\nChon Block:")
  (setq lten nil)  
  (mapcar '(lambda(x) (if (not (member (setq tm (dxf 2 x)) lten)) (setq lten (cons  tm lten))))
 (acet-ss-to-list (ssget (list '(0 ....
>>

Thử cái này, text mẫu chỉ hỏi 1 lần thôi, lần sau không hỏi nữa.

(defun c:test(/ lten lsoluong ss diem diem1 n cao)
  (defun dxf(id v) (cdr (assoc id (entget v))))
  
  (princ "\nChon Block:")
  (setq lten nil)  
  (mapcar '(lambda(x) (if (not (member (setq tm (dxf 2 x)) lten)) (setq lten (cons  tm lten))))
 (acet-ss-to-list (ssget (list '(0 . "INSERT")))))
 
  (princ "\nTrong cac doi tuong:")
  (setq ss (acet-ss-to-list (ssget (list '(0 . "INSERT"))))
lsoluong (mapcar '(lambda(y) (length (vl-remove nil (mapcar '(lambda(x) (if (= y (dxf 2 x)) x nil)) ss)))) lten))
 
  (if (not textmau) (setq textmau (car (entsel "Chon Text mau:"))))
 
  (setq diem (getpoint "\nDiem dat text so luong:")
n -1
cao (dxf 40 textmau))
  (foreach v lten
    (entmakex (list (cons 0  "TEXT") (cons 10 (setq diem1 (polar diem (* -0.5 pi) (* 2 cao (setq n (1+ n))))))
   (cons 11 diem1) (cons 40 cao) (cons 7 (dxf 7 textmau)) (cons 71 (dxf 71 textmau)) (cons 72 (dxf 72 textmau))
   (cons 1 (strcat (nth n lten) " : " (itoa (nth n lsoluong))))))
  )
  (princ)  
)
 

@anh tuan : bạn có file nào có anonymous block cần đếm thì đưa lên tôi test cho.


<<

Filename: 288512_test.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 277495
Tên lệnh: chay
Nhớ các Bác sửa giúp cái tùy chọn radio_button của 1 dialog!

Nói chung, lisp điều khiển dialog của bạn có lắm vấn đề. Tôi sửa lisp giúp bạn và bạn tự rút ra kết luận nhé.

(Defun c:chay ( / dcl_id key_1 key_2 flag)
 (setq dcl_id (load_dialog "dialog1.dcl"))
 (if (not (new_dialog "dialog1" dcl_id)) (exit))
 (action_tile "key_1" "(setq key_1 $value)")
 (action_tile "key_2" "(setq key_2 $value)")
 (action_tile "cancel" "(done_dialog 0)")
 (action_tile "accept"...
>>

Nói chung, lisp điều khiển dialog của bạn có lắm vấn đề. Tôi sửa lisp giúp bạn và bạn tự rút ra kết luận nhé.

(Defun c:chay ( / dcl_id key_1 key_2 flag)
 (setq dcl_id (load_dialog "dialog1.dcl"))
 (if (not (new_dialog "dialog1" dcl_id)) (exit))
 (action_tile "key_1" "(setq key_1 $value)")
 (action_tile "key_2" "(setq key_2 $value)")
 (action_tile "cancel" "(done_dialog 0)")
 (action_tile "accept" "(done_dialog 1)")
 (setq flag (start_dialog))
 (if (= flag 1)
  (if (= key_1 "1")
   (princ "Ban da chon la: \"Co\"")
   (princ "Ban da chon la: \"Khong\"")))
 (princ))

<<

Filename: 277495_chay.lsp
Tác giả: toai
Bài viết gốc: 98323
Tên lệnh: brln
Viết lisp theo yêu cầu [phần 2]

Ban tien2005 sử dụng thử code sau :

Bác Tue_NV ơi, tôi đã down lisp về và dùng rồi (Acad 2008) nhưng sau khi chọn line, nhập số đoạn cần chia thì line ban đầu vẫn k chia thành từng đoạn (vẫn là 1 đoạn thẳng).Nhờ bác xem lại giùm!
Đây là dòng lệnh mà tôi đã nhập:
http://www.4shared.com/photo/adFcEccJ/lenh_lnbr.html

Filename: 98323_brln.lsp
Tác giả: Tue_NV
Bài viết gốc: 99421
Tên lệnh: ctla
Viết lisp theo yêu cầu [phần 2]

'romeo1982' sử dụng thử code này :

Filename: 99421_ctla.lsp

Trang 154/330

154