Jump to content
InfoFile
Tác giả: tien2005
Bài viết gốc: 445542
Tên lệnh: tcdt
Nhờ các bác chỉnh giùm em lisp ghi chiều dài đoạn polyline vào block attributes

@vanhuyou Bạn dùng thử

(defun c:tcdt (/ att ent len ss)
  (setvar 'DIMZIN 0)
  (and (setq ss (ssget "_+.:S:E" '((0 . "*LINE"))))
       (setq ent (ssname ss 0))
       (not (redraw ent 3))
      ...
>>

@vanhuyou Bạn dùng thử

(defun c:tcdt (/ att ent len ss)
  (setvar 'DIMZIN 0)
  (and (setq ss (ssget "_+.:S:E" '((0 . "*LINE"))))
       (setq ent (ssname ss 0))
       (not (redraw ent 3))
       (setq att (car (nentsel "\nPick Att: ")))
       (eq (cdr (assoc 0 (entget att))) "ATTRIB")
       (setq
	 len (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent))
       ) ;_ end of setq
       (not
	 (vla-put-textstring
	   (vlax-ename->vla-object att)
	   (strcat (vla-get-textstring (vlax-ename->vla-object att))
		   " - "
		   (rtos len 2 0)
	   ) ;_ end of strcat
	 ) ;_ end of vla-put-textstring
       ) ;_ end of not
       (redraw ent 4)
  ) ;_ end of and
  (princ)
) ;_ end of defun

 


<<

Filename: 445542_tcdt.lsp
Tác giả: kokono939
Bài viết gốc: 111166
Tên lệnh: textblock
Lisp sửa bề rộng text của block thuôc tính????
Cũng không rõ nữa vẫn báo lỗi thế này.

1_14.jpg

Nhưng thôi kệ nó đã. Bác test lại với block của bác...

>>
Cũng không rõ nữa vẫn báo lỗi thế này.

1_14.jpg

Nhưng thôi kệ nó đã. Bác test lại với block của bác nhé

(defun c:textblock (/ C40 ENT H I M N N40 SS SSN ENT1 SSN1 RONG C10 C11 C41 C72 C73 N41 N72 N73)
(vl-load-com)
(princ "\nChon block")
(setq ss (ssget '((0 . "INSERT"))))
(setq i 0)
(setq n (sslength ss))
(setq m -1)
(setq h (getreal "\n Nhap chieu cao chu: "))
(setq rong (getreal "\n Nhap be rong chu: "))
(while (< i n)
(setq ssn (ssname ss (setq m (1+ m))))
(setq ent (entget ssn))
(if(= (cdr(assoc 66 ent)) 1)
(progn
(setq ssn1(entnext ssn))
(setq ent1(entget ssn1))
(while (/= (cdr(assoc 0 ent1)) "SEQEND")
(setq c40 (assoc 40 ent1))
(setq n40 (cons 40 h))
(setq c41 (assoc 41 ent1))
(setq n41 (cons 41 rong))
(if (and(/= (cdr(assoc 72 ent1)) 1)(/=(cdr(assoc 73 ent1)) 2))
 (progn
   (setq c11 (assoc 11 ent1))
   (setq c10 (cons 11 (cdr(assoc 10 ent1))))
   (setq c72 (assoc 72 ent1))
   (setq c73 (assoc 73 ent1))
   (setq n72 (cons 72 1))
   (setq n73 (cons 73 2))
   (setq ent1 (subst c10 c11 ent1))
   (setq ent1 (subst n72 c72 ent1))
   (setq ent1 (subst n73 c73 ent1))
   )
 )
(setq ent1 (subst n40 c40 ent1))
(setq ent1 (subst n41 c41 ent1))  
(entmod ent1)
(setq ssn1(entnext ssn1))
(setq ent1(entget ssn1))
)
)
)
(setq i (+ 1 i))
)
(entupd ssn)
(princ)
)

Nếu còn bị nhảy thì báo lại cho mình nhé.

 

 

Thank bác. Chữ ko bị nhảy nữa rồi!Lisp đến đây là chuẩn theo yêu cầu ban đầu rồi.Chúc bác làm việc tốt!


<<

Filename: 111166_textblock.lsp
Tác giả: vtd_xd
Bài viết gốc: 111149
Tên lệnh: textblock
Lisp sửa bề rộng text của block thuôc tính????

Cũng không rõ nữa vẫn báo lỗi thế này.

1_14.jpg

Nhưng thôi kệ nó đã. Bác test lại với block của bác...

>>
Cũng không rõ nữa vẫn báo lỗi thế này.

1_14.jpg

Nhưng thôi kệ nó đã. Bác test lại với block của bác nhé

(defun c:textblock (/ C40 ENT H I M N N40 SS SSN ENT1 SSN1 RONG C10 C11 C41 C72 C73 N41 N72 N73)
(vl-load-com)
(princ "\nChon block")
(setq ss (ssget '((0 . "INSERT"))))
(setq i 0)
(setq n (sslength ss))
(setq m -1)
(setq h (getreal "\n Nhap chieu cao chu: "))
(setq rong (getreal "\n Nhap be rong chu: "))
(while (< i n)
(setq ssn (ssname ss (setq m (1+ m))))
(setq ent (entget ssn))
(if(= (cdr(assoc 66 ent)) 1)
(progn
(setq ssn1(entnext ssn))
(setq ent1(entget ssn1))
(while (/= (cdr(assoc 0 ent1)) "SEQEND")
(setq c40 (assoc 40 ent1))
(setq n40 (cons 40 h))
(setq c41 (assoc 41 ent1))
(setq n41 (cons 41 rong))
(if (and(/= (cdr(assoc 72 ent1)) 1)(/=(cdr(assoc 73 ent1)) 2))
 (progn
   (setq c11 (assoc 11 ent1))
   (setq c10 (cons 11 (cdr(assoc 10 ent1))))
   (setq c72 (assoc 72 ent1))
   (setq c73 (assoc 73 ent1))
   (setq n72 (cons 72 1))
   (setq n73 (cons 73 2))
   (setq ent1 (subst c10 c11 ent1))
   (setq ent1 (subst n72 c72 ent1))
   (setq ent1 (subst n73 c73 ent1))
   )
 )
(setq ent1 (subst n40 c40 ent1))
(setq ent1 (subst n41 c41 ent1))  
(entmod ent1)
(setq ssn1(entnext ssn1))
(setq ent1(entget ssn1))
)
)
)
(setq i (+ 1 i))
)
(entupd ssn)
(princ)
)

Nếu còn bị nhảy thì báo lại cho mình nhé.

 

 

Text không nhảy nữa, nhưng cho tôi hỏi, nếu trong Block đó có nhiều text ATTRIBUTE thi nó đều thay đổi hết, bạn thử chỉnh lại nếu kich vào text nào trong block thì chỉ có text đó thay đổi thôi

Thank bạn


<<

Filename: 111149_textblock.lsp
Tác giả: thiep
Bài viết gốc: 446551
Tên lệnh: dkcb
Nhờ ACE giúp đỡ về đo khoảng cách trong Block att

Lisp đo khoảng cách từ điểm insert block A đến các điểm insert block B, C; đưa các số đo khoảng cách vào trong 1 Table, có tạo field các khoảng cách này vào cột distance. Sau khi chạy lisp xong, nếu người dùng move các block A, B, C, thì giá trị khoảng cách sẽ thay đổi theo, sau khi đánh lệnh redraw.

Nên nhớ: để tìm các block B, C từ block A, lisp yêu cầu người dùng nhập "bán...

>>

Lisp đo khoảng cách từ điểm insert block A đến các điểm insert block B, C; đưa các số đo khoảng cách vào trong 1 Table, có tạo field các khoảng cách này vào cột distance. Sau khi chạy lisp xong, nếu người dùng move các block A, B, C, thì giá trị khoảng cách sẽ thay đổi theo, sau khi đánh lệnh redraw.

Nên nhớ: để tìm các block B, C từ block A, lisp yêu cầu người dùng nhập "bán kính ảnh hưởng", nghĩa là từ tâm là điểm insert block A, lisp sẽ tạo 1 đường gần như tròn, trong "đường tròn" này phải có các block B và C nằm trong. Người dùng lisp phải chọn "bán kính ảnh hưởng" sao cho phù hợp để từ block A nó tìm ra được các block B, C gần nó nhất.

Kỳ công của lisp này là tạo field khoảng cách 2 điểm insertpoint của block đưa vào cell của table đó.

 

;;  Lisp "Statistics table: Add field Distance of insertionPoints of blocks"
;;;         by  : Trân Thiêp
;;;         tel : 0918841230
;;;         date: 04/2020
(defun DXF (code en) (cdr (assoc code (entget en))))
(defun po-20p (p R / lp n)
    (setq n 1)
    (repeat 20 (setq lp (cons (polar p (* pi 0.1 n) R) lp)) (setq n (1+ n)))
    lp
)
(defun c:dkcb (/       ssA
               ApCad   actDoc
               *Model* *TextStyles*
               FontFile
               prec    col
               row     l1
               l2      pTab1
               pTab2   objTable
               n       ssB-C
               ent-L_A ent-L_BC
               tag_lst dX
               dX*     dY
               dX*     str
               obj1    obj2
               ID1     ID2
               dis     Rad
               len
              )
    (command "undo" "be")
    (setq ApCad        (vlax-get-acad-object)
          actDoc       (vla-get-ActiveDocument ApCad)
          *Model*      (vla-get-ModelSpace actDoc)
          *TextStyles* (vla-get-TextStyles actDoc)
    )
    (setq FontFile "C:\\Windows\\Fonts\\Times.ttf")
    (if (not (tblobjname "STYLE" "TNR"))
        (progn (setq tsobj (vla-add *TextStyles* "TNR"))
               (vla-put-FontFile tsobj FontFile)
        )
    )
    (defun *error* (msg)
        (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
            (princ (strcat "\n** Error: " msg " **"))
        )
        (acet-sysvar-restore)
        (command "undo" "en")
        (princ)
    )
    (acet-sysvar-set '("cmdecho" 0 "osmode" 0))
    (setq A2k (atof (substr (getvar 'acadver) 1 4))) ;
    (Setq col 3
          row 3
          L1  nil
    )
    (setq W 15)
    (setq pTab1 (getvar "Extmin"))
    (setq pTab1 (list (- (car pTab1) (* W col)) (- (cadr pTab1) (* W row)) 0.0))
    (if (> A2k 16)
        (progn (setq objTable (vla-AddTable *Model*
                                            (vlax-3D-point pTab1)
                                            row
                                            col
                                            5
                                            W
                              )
               )
               (vla-SetTextHeight objTable acTitleRow 2.0)
               (vla-SetTextStyle objTable (+ acHeaderRow acTitleRow) "TNR")
               (vla-SetRowHeight objTable 0 10)
               (vla-setText
                   objTable
                   0
                   0
                   "Statistics table: Distance of insertionPoints of blocks"
               )
               (vla-setText objTable 1 0 "Blocknames")
               (vla-setText objTable 1 2 "Distance    (m)")
               (vla-MergeCells objTable 1 1 0 1)
               (vla-MergeCells objTable 1 2 2 2)
               (vla-setText objTable 2 0 "from")
               (vla-setText objTable 2 1 "to")
               (setq n 3)
               (setq ssA (ssget '((0 . "INSERT") (2 . "A"))))
               (if (null (setq
                             prec (getint
                                      (acet-str-format
                                          "\nEnter number of decimal places: <%1> "
                                          (itoa (getvar "useri1"))
                                      )
                                  )
                         )
                   )
                   (setq prec (getvar "useri1"))
               )
               (setvar "useri1" prec)
               (or (/= (getvar "userr1") 0.0) (setvar "userr1" 14))
               (if (null (setq Rad (getreal (acet-str-format
                                                "\nEnter Influence radius: <%1> "
                                                (rtos (getvar "userr1") 2 prec)
                                            )
                                   )
                         )
                   )
                   (setq Rad (getvar "userr1"))
               )
               (setvar "userr1" Rad)
               (if ssA
                   (progn (setq ent-L_A (acet-ss-to-list ssA))
                          (mapcar '(lambda (e)
                                       (setq tag_lst (acet-insert-attrib-get e))
                                       (setq L1 (append L1
                                                        (list (list (strcat (cadar tag_lst)
                                                                            (cadadr tag_lst)
                                                                    )
                                                                    e
                                                              )
                                                        )
                                                )
                                       )
                                   )
                                  ent-L_A
                          )
                          (setq L1 (vl-sort L1 '(lambda (e1 e2) (< (car e1) (car e2))))
                          )
                          (foreach lst L1
                              (setq name1 (car lst)
                                    entA  (cadr lst)
                              )
                              (setq obj1 (vlax-ename->vla-object entA)
                                    ID1  (vla-get-objectid obj1)
                              )
                              (setq lstpo (po-20p (dxf 10 entA) Rad))
                              (setq ssB-C (ssget "CP"
                                                 lstpo
                                                 '((0 . "INSERT") (2 . "B,C"))
                                          )
                              )
                              (setq L2 nil)
                              (if ssB-C
                                  (progn (setq ent-L_BC (acet-ss-to-list ssB-C))
                                         (setq len (length ent-L_BC))
                                         (vla-InsertRows objTable row 5 len)
                                         (setq row (+ row len))
                                         (mapcar '(lambda (e)
                                                      (setq L2 (append L2
                                                                       (list (list (dxf 2 e) e))
                                                               )
                                                      )
                                                  )
                                                 ent-L_BC
                                         )
                                         (setq L2 (vl-sort L2
                                                           '(lambda (e1 e2)
                                                                (< (car e1) (car e2))
                                                            )
                                                  )
                                         )
                                         (foreach lst L2
                                             (setq name2 (car lst)
                                                   entBC (cadr lst)
                                             )
                                             (setq name2 (dxf 2 entBC))
                                             (setq obj2 (vlax-ename->vla-object entBC)
                                                   ID2  (vla-get-objectid obj2)
                                             )
                                             (setq dX (strcat
                                                          (acet-str-format
                                                              "(%<\\AcObjProp Object(%<\\_ObjId %1>%).InsertionPoint \\f \"%lu2%pt1%pr%2\">%-"
                                                              (itoa ID2)
                                                              (itoa prec)
                                                          )
                                                          (acet-str-format
                                                              "%<\\AcObjProp Object(%<\\_ObjId %1>%).InsertionPoint \\f \"%lu2%pt1%pr%2\">%)"
                                                              (itoa ID1)
                                                              (itoa prec)
                                                          )
                                                      )
                                             )
                                             (setq dY (strcat
                                                          (acet-str-format
                                                              "(%<\\AcObjProp Object(%<\\_ObjId %1>%).InsertionPoint \\f \"%lu2%pt2%pr%2\">%-"
                                                              (itoa ID2)
                                                              (itoa prec)
                                                          )
                                                          (acet-str-format
                                                              "%<\\AcObjProp Object(%<\\_ObjId %1>%).InsertionPoint \\f \"%lu2%pt2%pr%2\">%)"
                                                              (itoa ID1)
                                                              (itoa prec)
                                                          )
                                                      )
                                             )
                                             (setq dX* (strcat dX "*" dX)
                                                   dY* (strcat dY "*" dY)
                                             )
                                             (setq dis
                                                      (strcat "sqrt" "(" dX* "+" dY* ")")
                                             )
                                             (setq str
                                                      (acet-str-format
                                                          "%<\\AcExpr (%1) \\f \"%lu2%pr%2\">%"
                                                          dis
                                                          (itoa prec)
                                                      )
                                             )
                                             (vla-setText objTable n 0 name1)
                                             (vla-setText objTable n 1 name2)
                                             (vla-setText objTable n 2 str)
                                             (setq n (+ n 1))
                                         )
                                  )
                              )
                          )
                   )
               )
               (vla-SetTextStyle objTable acDataRow "TNR")
               (setq rowtypes (list acHeaderRow acTitleRow acDataRow))
               (mapcar '(lambda (x) (vla-SetAlignment objTable x acMiddleCenter))
                       rowtypes
               )
               (vla-SetTextHeight objTable (+ acHeaderRow acDataRow) 1.8)
               (setq pTab2 (acet-ss-drag-move
                               (ssadd (vlax-vla-object->ename objTable))
                               pTab1
                               "\n<<< Pick a point for set place of Table >>> "
                           )
               )
               (vla-move objTable (vlax-3d-point pTab1) (vlax-3d-point pTab2))
               (vlax-release-object objtable)
        )
        (acet-ui-message "This autoCad version doesn't support addTable"
                         "Warning"
                         4144
        )
    ) ;_if
    (acet-sysvar-restore)
    (command "undo" "en")
    (princ "\nOK")
    (princ)
)

 


<<

Filename: 446551_dkcb.lsp
Tác giả: thiep
Bài viết gốc: 446623
Tên lệnh: geta
autolisp diện tích giống lệnh area nhưng có thêm mục ghi text ra luôn

Lisp này chắc phù hợp ý của @nguyen hai son

(defun lstpoint (/ ptemp PT lstp)
    (setq lstp (list (setq PT (getpoint "\nPick the first point "))))
    (setq ptemp pt)
    (while (setq...
>>

Lisp này chắc phù hợp ý của @nguyen hai son

(defun lstpoint (/ ptemp PT lstp)
    (setq lstp (list (setq PT (getpoint "\nPick the first point "))))
    (setq ptemp pt)
    (while (setq PT (getpoint ptemp "\nPick the next point "))
        (grdraw ptemp PT 8 1)
        (setq lstp (append lstp (list pt)))
        (setq ptemp pt)
    )
    lstp
)     
(defun SetClipBoardText	(text / htmlfile result) ; By XShrimp
  (if (= 'STR (type text))
    (progn
      (setq htmlfile (vlax-create-object "htmlfile")
	    result   (vlax-invoke
		       (vlax-get (vlax-get htmlfile 'ParentWindow)
				 'ClipBoardData
		       )
		       'SetData
		       "Text"
		       text
		     )
      )
      (vlax-release-object htmlfile)
      text
    )
  )
)
(defun GetArea (lst )
    (/ (apply
           '+
           (mapcar '(lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b))))
                   lst
                   (cons (last lst) lst)
           )
       )
       2
    )
)
(defun c:getA (/)
    (command "undo" "be")
    (acet-sysvar-set '("cmdecho" 0 "osmode" 545))
    (SetClipBoardText (rtos (abs (GetArea (lstpoint)))))
    (command "_pasteclip")
    (acet-sysvar-restore)
    (redraw)
    (command "undo" "en")
    (princ "\nOk")
)

 


<<

Filename: 446623_geta.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 446626
Tên lệnh: te
Nhờ viết lisp căn dãn khoảng cách giữa các đối tượng
4 giờ trước, xaydungcadviet đã nói:

Cảm ơn anh đã quan tâm,...

>>
4 giờ trước, xaydungcadviet đã nói:

Cảm ơn anh đã quan tâm, em đã gửi bản vẽ đính kèm đây ạ, có gì diễn đạt không kỹ lắm mong anh em bỏ qua nhé, cảm ơn

TEST.dwg

(Defun c:te (/ ss p1 p2 x a e)
  (Setq ss (ssget '(( 0 . "INSERT"))))
  (setq p1 (getpoint  "pick diem chen")
	p2 (getpoint p1 "pick phuong, khoang cach"))
  (setq x (distance p1 p2) a (angle p1 p2))
  (while (setq e (ssname ss 0))
    (setq ss (ssdel e ss))
    (command "copy" e "" "_NON" (cdr (assoc 10 (entget e))) "_NON" p1)
    (setq p1 (polar p1 a x)))
  )

ezgif.com-gif-maker.gif.ae785db1323bef504b5db86519e564ae.gif


<<

Filename: 446626_te.lsp
Tác giả: ksdung
Bài viết gốc: 210470
Tên lệnh: bt 10
Lisp ghi bước thép với khoảng cách thép đều nhau

Thêm 1 phương án :

(defun C:bt(/ ctc ss)
 (or *ctc* (setq *ctc* 200))
 (initget 6)
 (setq ctc (getint (strcat"\nNhap buoc thep...
>>

Thêm 1 phương án :

(defun C:bt(/ ctc ss)
 (or *ctc* (setq *ctc* 200))
 (initget 6)
 (setq ctc (getint (strcat"\nNhap buoc thep <" (itoa *ctc*) ">:")) )
 (if ctc (setq *ctc* ctc))
 (if (setq ss (ssget"_:L" (list (cons 0 "DIMENSION")) ))
(progn
 	(command "_.undo" "_begin")    
 	(foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(vla-put-TextOverride (vlax-ename->vla-object ent)
  (strcat (itoa (fix(/ (cdr (assoc 42 (entget ent))) *ctc*)))
"x" (itoa *ctc*) "=<>"))	)
 	(command "_.undo" "_end") (princ)  )))
(defun C:10(/ num ss)
 (if (setq ss (ssget"_:L"))
(progn
 	(command "_.undo" "_begin")
 	(or *num* (setq *num* 15))
 	(initget 4)
 	(setq num (getint (strcat"\nNhap color <" (itoa *num*) ">:")) )
 	(while (not (if num (<= num 256)T) )
(princ "\nGia tri <=256.")
(setq num (getint (strcat"\nNhap color <" (itoa *num*) ">:")) ))
 	(if num (setq *num* num))
 	(foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(vla-put-Color (vlax-ename->vla-object ent)*num* )	)
 	(command "_.undo" "_end") (princ)  )))

 

 

Bạn sửa giúp mình kết quả lẻ 2 số thập phân được ko, thanks bạn


<<

Filename: 210470_bt_10.lsp
Tác giả: thiep
Bài viết gốc: 445405
Tên lệnh: fdt1 fdt2 fdt3 fdt4 fdt5 re1
LINK ĐỐI TƯỢNG CHO DIM VÀ TEXT
7 giờ trước, Kieu Tan đã nói:
7 giờ trước, Kieu Tan đã nói:

@thiepbạn có thể chỉnh sửa tí để lisp ổn định hơn đi bạn, như trường hợp này sẽ dẫn đến sai sót trong quá trình làm bản vẽ

Tại bảng Properties, khi người dùng thay đổi thuộc tính từ TextOverwrite sang Measurement hoặc ngược lại của textDim thì biểu thức field đã gán cho text có sẵn sẽ không update được vì nó chỉ update giá trị của thuộc tính đã định sẵn trong biểu thức field, không update việc thay đổi thuộc tính.

Lisp sau Thiep đã update, cho trường này. Tuy nhiên, sau khi thay đổi thuộc tính từ TextOverwrite sang Measurement hoặc ngược lại, các bạn phải đánh lệnh RE1 thay cho lệnh RE để tái tạo tạo màn hình. Sau đó, trên màn hình các bạn chỉnh sửa giá trị textDim (TextOverwrite)  hoặc co giản dim (Measurement) thì vẫn dùng lệnh RE để update giá trị thuộc tính thay đổi.

Chú ý: Lệnh Re1, chỉ hoạt động khi bản vẽ dùng lệnh fdt1 của lisp, khi đó giá trị biến trong lisp chưa bị mất đi. Còn khi người dùng tắt bản vẽ và mở lại, lệnh Re1 không thực hiện được nữa, khi đó phải tải lisp dưới đây và dùng lệnh fdt1 trở lại.

 

;;; LISP  FIELD SUM DIMENSIONS, TEXTs, MTEXTs, LENGTHs, AREAs, CIRCUMFERENCEs TO A TEXT
;;;          by TrânThiêp 04/2020
;;;		09188411230
;;;=======================================================
;;; command         fdt1 : field sum DIMENSIONS                        
;;; command         fdt2 : field sum TEXTs, MTEXTs                     
;;; command         fdt3 : field sum LENGTHs                           
;;; command         fdt4 : field sum AREAs                             
;;; command         fdt5 : field sum CIRCUMFERENCEs
;;; command         re1 :  update field sum DIMENSIONs when change properti TextOverride dim to Measurement dim or reverse 
;;;                                                       
(defun DXF (code en) (cdr (assoc code (entget en))))
(vl-load-com)
(defun *error* (msg)
        (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
            (princ (strcat "\n** Error: " msg " **"))
        )
        (acet-sysvar-restore)
        (command "undo" "en")
        (princ)
    )
;;;===========================================================================1: sum DIMENSIONs =========
(defun c:fdt1 (/ ss ent_T)
    (command "undo" "be")
    (acet-sysvar-set '("cmdecho" 0 "osmode" 0))
    (acet-ui-status "Select DIMENSIONs FOR GET SUM" "Prompt")
    (setq ss (ssget '((0 . "DIMENSION"))))
    (acet-ui-status)
    (while (OR (NOT (setq ent_T
                             (car (entsel
                                      "\nPick a Text object for set sum dimensions"
                                  )
                             )
                    )
               )
               (NOT (eq (cdr (assoc 0 (entget ent_T))) "TEXT"))
           )
        (prompt "\nPick not right TEXT object, please pick again")
    )
    (setq Obj_Text_thiep (vlax-ename->vla-object ent_T))
    (if (null (setq prec_thiep
                       (getint (acet-str-format
                                   "\nEnter number of decimal places: <%1> "
                                   (itoa (getvar "useri1"))
                               )
                       )
              )
        )
        (setq prec_thiep (getvar "useri1"))
    )
    (setvar "useri1" prec_thiep)
    (if ss
        (progn (mapcar '(lambda (x)
                            (setq Lobj_dim_thiep (CONS (vlax-ename->vla-object x)
                                                       Lobj_dim_thiep
                                                 )
                            )
                        )
                       (acet-ss-to-list ss)
               )
               (setq ID_Dim_lst_thiep (mapcar 'vla-get-objectid Lobj_dim_thiep))
               (Setq field_lst
                        (mapcar
                            '(lambda (ob id)
                                 (if (distof (vla-get-TextOverride ob))
                                     (acet-str-format
                                         "%<\\AcObjProp Object(%<\\_ObjId %1>%).%2>%+"
                                         (itoa id)
                                         "TextOverride"
                                     )
                                     (acet-str-format
                                         "%<\\AcObjProp Object(%<\\_ObjId %1>%).%3 \\f \"%lu2%pr%2\">%+"
                                         (itoa id)
                                         (itoa prec_thiep)
                                         "Measurement"
                                     )
                                 )
                             )
                            Lobj_dim_thiep
                            ID_Dim_lst_thiep
                        )
               )
               (setq strThiep (acet-str-format
                                  "%<\\AcExpr (%1) \\f \"%lu2%pr%2\">%"
                                  (vl-string-right-trim "+"
                                                        (apply 'strcat field_lst)
                                  )
                                  (itoa prec_thiep)
                              )
               )
               (vla-put-TextString Obj_Text_thiep strThiep)
        ) ;_PROGN
    ) ;_IF
    (ACET-SYSVAR-RESTORE)
    (command "undo" "en")
    (PRINC str)
    (princ "\nOK")
)
;;;===========================================================================2: sum TEXTs, MTEXTs NUMBER=========
(defun c:fdt2 (/ ss ent_T Obj_Text str prec Lobj_text ID_text_lst field_lst)
    (command "undo" "be")
    (acet-sysvar-set '("cmdecho" 0 "osmode" 0))
    (acet-ui-status "Select:  TEXT, MTEXT NUMBER FOR GET SUM" "Prompt")
    (setq ss (ssget '((0 . "*TEXT"))))
    (acet-ui-status)
    (if ss
        (progn (while (OR (NOT (setq ent_T
                                        (car
                                            (entsel
                                                "\nPick a Text object for set sum text number"
                                            )
                                        )
                               )
                          )
                          (NOT (eq (cdr (assoc 0 (entget ent_T))) "TEXT"))
                      )
                   (prompt "\nPick not right TEXT object, please pick again")
               )
               (setq Obj_Text (vlax-ename->vla-object ent_T))
               (if (null (setq
                             prec (getint
                                      (acet-str-format
                                          "\nEnter number of decimal places: <%1> "
                                          (itoa (getvar "useri2"))
                                      )
                                  )
                         )
                   )
                   (setq prec (getvar "useri2"))
               )
               (setvar "useri2" prec)
               (mapcar '(lambda (x)
                            (if (Numberp (atof (dxf 1 x)))
                                (setq Lobj_text (CONS (vlax-ename->vla-object x)
                                                      Lobj_text
                                                )
                                )
                            )
                        )
                       (acet-ss-to-list ss)
               )
               (setq ID_text_lst (mapcar 'vla-get-objectid Lobj_text))
               (setq field_lst
                        (mapcar
                            '(lambda (x)
                                 (acet-str-format
                                     "%<\\AcObjProp Object(%<\\_ObjId %1>%).TextString>% +"
                                     (itoa x)
                                 )
                             )
                            ID_text_lst
                        )
               )
               (setq str (acet-str-format
                             "%<\\AcExpr (%1)>%"
                             (vl-string-right-trim "+" (apply 'strcat field_lst))
                         )
               )
               (dos_clipboard str)
               (vla-put-TextString Obj_Text str)
        ) ;_PROGN
    ) ;_IF
    (ACET-SYSVAR-RESTORE)
    (command "undo" "en")
    (princ "\nOK")
    (PRINC)
)
;;;===========================================================================3: LENGTHs=========
(defun c:fdt3 (/ ss ent_T Obj_Text str prec Lobj_leng ID_leng_lst field_lst)
    (command "undo" "be")
    (acet-sysvar-set '("cmdecho" 0 "osmode" 0))
    (acet-ui-status "Select:  LINE, POLYLINE, for GET SUM LENGTH" "Prompt")
    (setq ss (ssget '((0 . "LINE,*POLYLINE"))))
    (acet-ui-status)
    (if ss
        (progn
            (while (OR (NOT (setq ent_T
                                     (car
                                         (entsel
                                             "\nPick a Text object for set sum length value"
                                         )
                                     )
                            )
                       )
                       (NOT (eq (cdr (assoc 0 (entget ent_T))) "TEXT"))
                   )
                (prompt "\nPick not right TEXT object, please pick again")
            )
            (setq Obj_Text (vlax-ename->vla-object ent_T))
            (if (null (setq
                          prec (getint
                                   (acet-str-format
                                       "\nEnter number of decimal places: <%1> "
                                       (itoa (getvar "useri3"))
                                   )
                               )
                      )
                )
                (setq prec (getvar "useri3"))
            )
            (setvar "useri3" prec)
            (mapcar
                '(lambda (x)
                     (if (vlax-property-available-p (vlax-ename->vla-object x)
                                                    'length
                         )
                         (setq Lobj_leng (CONS (vlax-ename->vla-object x)
                                               Lobj_leng
                                         )
                         )
                     )
                 )
                (acet-ss-to-list ss)
            )
            (setq ID_leng_lst (mapcar 'vla-get-objectid Lobj_leng))
            (setq field_lst
                     (mapcar
                         '(lambda (id)
                              (acet-str-format
                                  "%<\\AcObjProp Object(%<\\_ObjId %1>%).Length \\f \"%lu2%pr%2\">%+"
                                  (itoa id)
                                  (itoa prec)
                              )
                          )
                         ID_leng_lst
                     )
            )
            (setq str (acet-str-format
                          "%<\\AcExpr (%1) \\f \"%lu2%pr%2\">%"
                          (vl-string-right-trim "+" (apply 'strcat field_lst))
                          (itoa prec)
                      )
            )
            (vla-put-TextString Obj_Text str)
        ) ;_PROGN
    ) ;_IF
    (ACET-SYSVAR-RESTORE)
    (command "undo" "en")
    (princ "\nOK")
    (PRINC)
)
;;;===========================================================================4: AREAs=========
(defun c:fdt4 (/ ss ent_T Obj_Text Lobj_area ID_area_lst str prec field_lst)
    (command "undo" "be")
    (acet-sysvar-set '("cmdecho" 0 "osmode" 0))
    (acet-ui-status
        "Select: POLYLINE, HATCH, ARC, CIRCLE, REGION, ELLIPSE for GET SUM AREA"
        "Prompt"
    )
    (setq ss (ssget '((0 . "*POLYLINE,HATCH,ARC,CIRCLE,ELLIPSE,REGION"))))
    (acet-ui-status)
    (if ss
        (progn
            (mapcar
                '(lambda (x)
                     (if (vlax-property-available-p (vlax-ename->vla-object x)
                                                    'area
                         )
                         (setq Lobj_area (CONS (vlax-ename->vla-object x)
                                               Lobj_area
                                         )
                         )
                     )
                 )
                (acet-ss-to-list ss)
            )
            (if (null (setq
                          prec (getint
                                   (acet-str-format
                                       "\nEnter number of decimal places: <%1> "
                                       (itoa (getvar "useri4"))
                                   )
                               )
                      )
                )
                (setq prec (getvar "useri4"))
            )
            (setvar "useri4" prec)
            (setq ID_area_lst (mapcar 'vla-get-objectid Lobj_area))
            (setq field_lst
                     (mapcar
                         '(lambda (id)
                              (acet-str-format
                                  "%<\\AcObjProp Object(%<\\_ObjId %1>%).Area \\f \"%lu2%pr%2\">%+"
                                  (itoa id)
                                  (itoa prec)
                              )
                          )
                         ID_area_lst
                     )
            )
            (setq str (acet-str-format
                          "%<\\AcExpr (%1) \\f \"%lu2%pr%2\">%"
                          (vl-string-right-trim "+" (apply 'strcat field_lst))
                          (itoa prec)
                      )
            )
            (while (OR (NOT (setq ent_T
                                     (car
                                         (entsel
                                             "\nPick a Text object for set sum area value"
                                         )
                                     )
                            )
                       )
                       (NOT (eq (cdr (assoc 0 (entget ent_T))) "TEXT"))
                   )
                (prompt "\nPick not right TEXT object, please pick again")
            )
            (setq Obj_Text (vlax-ename->vla-object ent_T))
            (vla-put-TextString Obj_Text str)
        ) ;_PROGN
    ) ;_IF
    (ACET-SYSVAR-RESTORE)
    (command "undo" "en")
    (princ "\nOK")
    (PRINC)
)
;;;==================================================================    5: CIRCUMFERENCEs: CHU VI VÒNG TRÒN
(defun c:fdt5 (/ ss ent_T Obj_Text Lobj_CIR ID_CIR_lst str prec field_lst)
    (command "undo" "be")
    (acet-sysvar-set '("cmdecho" 0 "osmode" 0))
    (acet-ui-status "Select: CIRCLE for GET SUM CIRCUMFERENCE" "Prompt")
    (setq ss (ssget '((0 . "CIRCLE"))))
    (acet-ui-status)
    (while (OR (NOT (setq ent_T
                             (car
                                 (entsel
                                     "\nPick a Text object for set sum circumference value"
                                 )
                             )
                    )
               )
               (NOT (eq (cdr (assoc 0 (entget ent_T))) "TEXT"))
           )
        (prompt "\nPick not right TEXT object, please pick again")
    )
    (setq Obj_Text (vlax-ename->vla-object ent_T))
    (if ss
        (progn
            (mapcar
                '(lambda (x)
                     (setq Lobj_CIR (CONS (vlax-ename->vla-object x) Lobj_CIR))
                 )
                (acet-ss-to-list ss)
            )
            (if (null (setq
                          prec (getint
                                   (acet-str-format
                                       "\nEnter number of decimal places: <%1> "
                                       (itoa (getvar "useri5"))
                                   )
                               )
                      )
                )
                (setq prec (getvar "useri5"))
            )
            (setvar "useri5" prec)
            (setq ID_CIR_lst (mapcar 'vla-get-objectid Lobj_CIR))
            (setq field_lst
                     (mapcar
                         '(lambda (id)
                              (acet-str-format
                                  "%<\\AcObjProp Object(%<\\_ObjId %1>%).Circumference \\f \"%lu2%pr%2\">%+"
                                  (itoa id)
                                  (itoa prec)
                              )
                          )
                         ID_CIR_lst
                     )
            )
            (setq str (acet-str-format
                          "%<\\AcExpr (%1) \\f \"%lu2%pr%2\">%"
                          (vl-string-right-trim "+" (apply 'strcat field_lst))
                          (itoa prec)
                      )
            )
            (vla-put-TextString Obj_Text str)
        ) ;_PROGN
    ) ;_IF
    (ACET-SYSVAR-RESTORE)
    (command "undo" "en")
    (princ "\nOK")
    (PRINC)
)
;;;===================update field sum DIMENSIONs when change properti TextOverride dim to Measurement dim or reverse =====
(defun c:re1 (/)
    (command "undo" "be")
    (setq ID_Dim_lst_thiep (mapcar 'vla-get-objectid Lobj_dim_thiep))
    (Setq field_lst
             (mapcar
                 '(lambda (ob id)
                      (if (distof (vla-get-TextOverride ob))
                          (acet-str-format
                              "%<\\AcObjProp Object(%<\\_ObjId %1>%).%2>%+"
                              (itoa id)
                              "TextOverride"
                          )
                          (acet-str-format
                              "%<\\AcObjProp Object(%<\\_ObjId %1>%).%3 \\f \"%lu2%pr%2\">%+"
                              (itoa id)
                              (itoa prec_thiep)
                              "Measurement"
                          )
                      )
                  )
                 Lobj_dim_thiep
                 ID_Dim_lst_thiep
             )
    )
    (setq strThiep (acet-str-format
                       "%<\\AcExpr (%1) \\f \"%lu2%pr%2\">%"
                       (vl-string-right-trim "+" (apply 'strcat field_lst))
                       (itoa prec_thiep)
                   )
    )
    (vla-put-TextString Obj_Text_thiep strThiep)
    (command "undo" "en")
    (princ "\nOK")
)

 

field-sumOBJ2TEXT.LSP


<<

Filename: 445405_fdt1_fdt2_fdt3_fdt4_fdt5_re1.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 446697
Tên lệnh: te
Nhờ viết lisp căn dãn khoảng cách giữa các đối tượng

Giờ mới rảnh viết lại cho bạn đây:

Phần rời rạc khi hỏi pick hướng thì Enter để chọn tiếp tập chọn khác

(Defun c:te (/ ss p1 p2 x a e lst)
  
>>

Giờ mới rảnh viết lại cho bạn đây:

Phần rời rạc khi hỏi pick hướng thì Enter để chọn tiếp tập chọn khác

(Defun c:te (/ ss p1 p2 x a e lst)
  (setq lst (list))
  (Setq ss (ssget ))
  
  (setq p1 (getpoint  "pick diem chen hoac diem goc"))
 (if  (setq p2 (getpoint p1 "pick phuong, khoang cach")) (progn
  (setq x (distance p1 p2) a (angle p1 p2))
  (while (setq e (ssname ss 0))
    (setq ss (ssdel e ss))
    (command "copy" e "" "_NON" (cdr (assoc 10 (entget e))) "_NON" p1)
    (setq p1 (polar p1 a x)))
  ) (progn
   (setq lst (append lst (list (list ss p1))))
   (while (and (setq ss (ssget))
	       (setq p1 (getpoint "Pick diem goc")))
     (setq lst (append lst (list (list ss p1))))
     )
   (setq p1 (getpoint  "pick diem chen")
	 p2 (getpoint p1 "pick phuong, khoang cach"))
   (setq x (distance p1 p2) a (angle p1 p2))
   (while (setq l1 (car lst))
     (setq lst (cdr lst))
    (command "copy" (car l1) "" "_NON" (cadr l1) "_NON" p1)
    (setq p1 (polar p1 a x)))

   )))

584215259_ezgif.com-gif-maker(1).gif.e66de4b8f2e829f68bc682517c0d9210.gif


<<

Filename: 446697_te.lsp
Tác giả: study_forever
Bài viết gốc: 74802
Tên lệnh: dt
Lisp move text vào tâm hình chữ nhật
Update theo yêu cầu :
(defun c:dt (/ cen des obj src typ)
 (vl-load-com)
 (defun mid (ent / p1 p2)
   (vla-getboundingbox (vlax-ename->vla-object ent) 'p1 'p2)
   (setq p1...
>>
Update theo yêu cầu :
(defun c:dt (/ cen des obj src typ)
 (vl-load-com)
 (defun mid (ent / p1 p2)
   (vla-getboundingbox (vlax-ename->vla-object ent) 'p1 'p2)
   (setq p1 (vlax-safearray->list p1)
  p2 (vlax-safearray->list p2))
   (mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5))
   )
 (and
   (setq src (car (entsel "\nChon doi tuong can di chuyen: ")))
   (not(redraw src 3))
   (setq obj (vlax-ename->vla-object src)
  typ (vlax-get obj 'ObjectName))
   (setq des (car (entsel "\nDoi tuong dich: ")))
   (not(redraw src 4))
   (setq cen (vlax-3d-point(mid des)))    
   (cond
     ((= typ "AcDbText")
      (vla-put-alignment obj 10)
      (vla-put-TextAlignmentPoint obj cen)
      )
     ((= typ "AcDbMText")
      (vla-put-AttachmentPoint obj 5)
      (vla-put-InsertionPoint obj cen)
      )
     (t (vlax-invoke obj 'Move (mid src) (mid des) ) )
     )
   )
 (princ)
 )

:cheers: :cheers: :cheers:


<<

Filename: 74802_dt.lsp
Tác giả: leejang
Bài viết gốc: 65187
Tên lệnh: r lt an
Đoạn CODE củ chuối ??? Sửa mãi vẫn dở hơi, Đành nhờ mấy bác Pro dùng tuyệt chiêu ???
Chẳng phải tại bản vẽ củ chuối đâu mà do khi bạn chọn điểm bên trong mà cái boundary

nằm ngoài vùng nhìn sẽ phát sinh lỗi, khi đó nếu bạn nhấn esc sẽ thoát ra khỏi...

>>
Chẳng phải tại bản vẽ củ chuối đâu mà do khi bạn chọn điểm bên trong mà cái boundary

nằm ngoài vùng nhìn sẽ phát sinh lỗi, khi đó nếu bạn nhấn esc sẽ thoát ra khỏi chương trình và mất osnap.

Cái này trước đây cũng có người hỏi rồi.

Mình sửa lisp như sau đây, bạn test thử xem sao, cứ esc thoải mái.

Mình cũng ko chắc sau khi sửa lisp có giải quyết đc vấn đề hay ko.

 

(defun c:R (/ dtl dtcon pt1 pt2 ss et vsize)
 (setq temp *error* *error* myerror)
 (defun myerror(msg)
   (setvar "OSMODE" oslast)
   (setq *error* temp)
 )
 (command "dimzin" "0")
 (Setq CVAR (Getvar "CMDECHO"))
 (Setvar "CMDECHO" 0)
 (print)
 (if (= tle nil)
   (progn
     (setq tle (getreal "Ty le ban ve 1:X , X=?: "))
     (setq ntl (/ 1 tle))				
     (setq tl2 (* ntl ntl))
   )
 )
 (setq dtl 0)
 (setq ss (ssadd))
 (setq oslast (getvar "OSMODE"))
 (command "osnap" "")
 (print)
 (print)
 (setq pt1 (getpoint "\n Chon diem ben trong hinh : "))
 (while (/= pt1 nil)
   (command "-boundary" pt1 "")
   (setq et (entlast))
   (ssadd et ss)
   (command "area" "e" "last")				
   (setq et (entlast))
   (ssadd et ss)
   (setq dtcon (/ (getvar "AREA") tl2))
   (setq dtl (+ dtcon dtl))
   (prompt
     (strcat "\n Dien tich hinh vua chon=" (rtos dtcon 2 3))
   )
   (print)
   (print)
   (setq pt1 (getpoint "\nPick internal point : "))
 )
 (command "setvar" "OSMODE" oslast)
 (command "erase" ss "")
 (setq ss nil)
 (command "redraw")
 (prompt (strcat "\n Dien tich = " (rtos dtl 2 4)))
 (print)

 ;; ====== nua dien tich=======
 (setq xxx (/ dtl 2))
 (print)
 (prompt (strcat "\n 1/2 Dien tich = " (rtos xxx 2 4)))
 (print)

 ;;ghi chu dien tich ================
 (setq giatri (entget (car (entsel "\n Chon Text dien dien tich: "))))
 (setq gia (assoc 1 giatri))
 (setq nt1 (cons 1 (rtos dtl)))
 (setq giatri (subst nt1 gia giatri))
 (entmod giatri)
 (princ)
 (Command "")
 (Setvar "CMDECHO" CVAR)
 (setq *error* temp)
)
(princ)

				; Hide & Show 
(DEFUN C:LT () (COMMAND "LTSCALE"))

(defun c:an (/ SSet Count Elem)
 (defun Dxf (Id Obj)
   (cdr (assoc Id (entget Obj)))
 )				;end Dxf
 (prompt "\nChon doi tuong an di: ")
 (cond
   ((setq SSet (ssget))
    (repeat (setq Count (sslength SSet))
      (setq Count (1- COunt)
     Elem  (ssname SSet Count)
      )
      (if (/= 4 (logand 4 (Dxf 70 (tblobjname "layer" (Dxf 8 Elem)))))
 (if (Dxf 60 Elem)
   (entmod
     (subst '(60 . 1) (assoc 60 (entget Elem)) (entget Elem))
   )
   (entmod (append (entget Elem) (list '(60 . 1))))
 )
 (prompt "\nKhong the an,doi tuong da bi khoa !. ")
      )				;end if
    )					;end repeat
   )
 )					;end cond
 (princ)
)					;end c:InVis

kaka, được rùi, cảm ơn bác nhìu nhé !!!


<<

Filename: 65187_r_lt_an.lsp
Tác giả: Duong Nhat Duy
Bài viết gốc: 446883
Tên lệnh: m1
Nhờ viết Lisp đánh dấu đối tượng

Do gà nên mình chỉ viết được cái đầu tiên (ko biết dấu hiệu nhận biết hcn :)))), bạn dùng tạm nhé :)).

Lệnh M1

(defun C:m1 ()
  (foreach ent (acet-ss-to-list (ssget '((0 . "POLYLINE,LWPOLYLINE"))))
    (if (= (vla-get-Closed (vlax-ename->vla-object ent)) :vlax-true)
      (vla-put-Color (vlax-ename->vla-object ent) 2)
     ...
>>

Do gà nên mình chỉ viết được cái đầu tiên (ko biết dấu hiệu nhận biết hcn :)))), bạn dùng tạm nhé :)).

Lệnh M1

(defun C:m1 ()
  (foreach ent (acet-ss-to-list (ssget '((0 . "POLYLINE,LWPOLYLINE"))))
    (if (= (vla-get-Closed (vlax-ename->vla-object ent)) :vlax-true)
      (vla-put-Color (vlax-ename->vla-object ent) 2)
      (vla-put-Color (vlax-ename->vla-object ent) 3)
      )
    )
  (print)
  )

 

M1.lsp


<<

Filename: 446883_m1.lsp
Tác giả: ketxu
Bài viết gốc: 444451
Tên lệnh: test
Nhờ tạo lisp : chèn tâm đường tròn or nhiều đường tròn bằng điểm point

Tìm trên mạng 1s là có ngay này bạn
 

(defun c:Test (/ ss)
 (if (setq ss (ssget '((0 . "CIRCLE"))))
   ((lambda (i / sn e)
      (while (setq sn (ssname ss (setq i (1+ i))))
         (entmakex (list '(0 . "POINT") (assoc 10 (setq e (entget sn)))(assoc 8 e)))))
     -1
   )
   (princ)
 )
 (princ)
)

Tuy nhiên bài toán này bạn cũng có thể...

>>

Tìm trên mạng 1s là có ngay này bạn
 

(defun c:Test (/ ss)
 (if (setq ss (ssget '((0 . "CIRCLE"))))
   ((lambda (i / sn e)
      (while (setq sn (ssname ss (setq i (1+ i))))
         (entmakex (list '(0 . "POINT") (assoc 10 (setq e (entget sn)))(assoc 8 e)))))
     -1
   )
   (princ)
 )
 (princ)
)

Tuy nhiên bài toán này bạn cũng có thể làm bằng tay bằng cách Dataextraction toàn bộ tọa độ tâm đường tròn ra Excel rồi xử lý như chèn Block khi biết tọa độ vậy ^^


<<

Filename: 444451_test.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 446892
Tên lệnh: m2
Nhờ viết Lisp đánh dấu đối tượng
1 giờ} trướ}c, vanlam6408 đã nói:

Dạ,em cảm ơn bác đã hồi...

>>
1 giờ} trướ}c, vanlam6408 đã nói:

Dạ,em cảm ơn bác đã hồi âm ạ.Lisp 1 bác viết đã chạy chuẩn rồi bác ạ.em cảm ơn bác nhiều ạ!

Cái Lisp 2 em cũng xem trong bảng properties nhưng cũng không có dấu hiệu gì ở trong bảng này thể hiện sự khác nhau của ractang và region ạ,em cũng thử dùng filters để chọn ra region nhưng cũng không thấy được gì.Nếu các anh pro trên diễn đàn cũng không có cách gì phân biệt nó bằng lisp thì chắc chỉ còn cách thủ công chọn lựa chúng bằng mắt thôi bác ạ.

hihi!một lần nửa cảm ơn bác nhiều ạ!

Lệnh M2 theo bạn thế này đạt chưa:

(defun c:m2 ()
  (mapcar '(lambda (x)
	     (if (= (vla-get-Closed (vlax-ename->vla-object x)) :vlax-true)
	       (if (= (length (lm:unique (acet-geom-vertex-list x))) 4)
		 (vla-put-Color (vlax-ename->vla-object x) 2)
		 (vla-put-Color (vlax-ename->vla-object x) 3)
	       )
	     )
	   )
	  (acet-ss-to-list (ssget '((0 . "*POLYLINE"))))
  )
)
(defun LM:Unique (l)
  (if l
    (cons (car l) (LM:Unique (vl-remove (car l) (cdr l))))
  )
)

 


<<

Filename: 446892_m2.lsp
Tác giả: phuonganh
Bài viết gốc: 120970
Tên lệnh: dagiac
hỏi vấn đề tạo liên kết LSP và dialog DCL
bạn có thể tham khảo đoạn code thô dưới đây.

bạn cần :

- Tên dialog, key trong DCL không nên có chữ hoa vì dễ quên dẫn tới lỗi.

- Trình bày lại DCL cho đẹp...

>>
bạn có thể tham khảo đoạn code thô dưới đây.

bạn cần :

- Tên dialog, key trong DCL không nên có chữ hoa vì dễ quên dẫn tới lỗi.

- Trình bày lại DCL cho đẹp và khoa học.

- Định các biến cục bộ trong hàm

- Định việc lưu hay không lưu các biến đã chọn cho lần gọi hàm kế tiếp.

Chúc bạn thành công

(defun c:dagiac (/)


(setq datalist (list 3 5 7 9 11 13 15 17))
(setq numside 5)
(setq L 30)

(setq id (load_dialog "c:/dagiac.dcl"))
(new_dialog "Polygon" id)

(start_list "numside")
(mapcar 'add_list (mapcar 'itoa datalist))
(end_list)

(set_tile "numside" (itoa (vl-position numside datalist)))
(set_tile "L" (rtos L 2 2))

(action_tile "numside" "(setq numside (nth (atoi $value) datalist))")
(action_tile "L" "(setq L (distof $value))")  

(setq sta (start_dialog))
(done_dialog)
(unload_dialog id)

 (if (> sta 0)
  (progn
  (setq a (/ pi numside))
  (setq R (/ L 2 (sin a)))

  (command "polygon" numside (setq p1 (getpoint "Center point")) "" (polar p1 (* pi 0.5) R))
  )
)

 )

Có anh em nào sửa lại LSP này được không, LSP này không chạy được nè!


<<

Filename: 120970_dagiac.lsp
Tác giả: thiep
Bài viết gốc: 446967
Tên lệnh: cdim
Hiệu Chỉnh Text Dimension và Add thêm text bên dưới
Vào lúc 24/4/2020 tại 14:47, Luongquocsonxd đã nói:

Mình nhờ anh...

>>
Vào lúc 24/4/2020 tại 14:47, Luongquocsonxd đã nói:

Mình nhờ anh em bên diễn đàn giúp mình đoạn lisp thực hiện công việc như hình vẽ mình gửi. Cảm ơn nhiều!

Hieu-Chinh-Dimension.png

 

Bài liên quan:
  • Mẹo vặt với Computer - Thảo luận vỉa hè

    Hãy bình tĩnh và làm theo mẹo nhỏ dưới đây, bạn sẽ tiết kiệm được khá nhiều thời gian đấy! ... Add scheduled task: thêm các nhiệm vụ do bạn tự ấn định. ... Windows + Pause/Break: Với những người nâng cấp và điều chỉnh phần ... Anh muốn phát âm vào ô Use the following text to preview the voice rồi ...

Lisp này phù hợp với ý @Luongquocsonxd và dành cho các kỹ sư xây dựng.

Lisp có tạo 1 dimstyle là "kichthuoc", nếu sau khi chạy lisp thấy chưa phù hợp: textsize, textstyle, arrow ... thì vào lệnh dimsty để modify lại dimstyle này.

Yêu cầu autoCad phải cài đặt thêm menu Express

;;; Lisp addDimAlign chia 1 line, lwpolyline thành 3 phân: 1/4L | 2/4L | 1/4L by Trân Thiêp
;;;================================================================
(defun DXF (code en) (cdr (assoc code (entget en))))
;;;======================================================
(defun A_triangle (Pt1 Pt2 Pt3 / a b c p)
    (setq a (distance Pt1 Pt2)
          b (distance Pt2 Pt3)
          c (distance Pt3 Pt1)
          p (/ (+ a b c) 2)
    )
    (sqrt (* p (- p a) (- p b) (- p c)))
)

;;;================================================================
(defun CalcZ (Pt1 Pt2 Pt3 / v w)                  
    (setq v (mapcar '- Pt1 Pt2)
          w (mapcar '- Pt3 Pt2)
    )
    (- (* (car v) (cadr w)) (* (cadr v) (car w)))
)
;;;================================================================
(defun c:cdim (/ ApCad      ActDoc     *Model*    *dimstyles*
                 *TextStyles*          *lay*      ang        dis
                 po_dim     po1        po2        prec       objdimstyle
                 lay        newFontFile           tsobj      ss
                 entlst     hei_TDim   Epo        Spo        ang
                 Epara      dis                        entname
                 po_dim     objdim1    objdim1A   objdim2    objdim2B
                 objdim3    objdim3A   objdimstyle_th        h
                 bit
                )
    (command "undo" "be")
    (defun *error* (msg)
        (and doc (_EndUndo doc))
        (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
            (princ (strcat "\n** Error: " msg " **"))
        )
        (acet-sysvar-restore)
        (command "undo" "en")
        (princ)
    )
    (acet-sysvar-set '("cmdecho" 0 "osmode" 1))
    (setq ApCad        (vlax-get-acad-object)
          ActDoc       (vla-get-ActiveDocument ApCad)
          *Model*      (vla-get-ModelSpace ActDoc)
          *TextStyles* (vla-get-TextStyles actDoc)
          *lay*        (vla-get-layers actDoc)
          *dimstyles*  (vla-get-dimStyles actDoc)
    )
    (or (tblobjname "LAYER" "Kichthuoc")
        (vla-put-color (vla-add *lay* "Kichthuoc") 1)
    )
    (setvar "clayer" "Kichthuoc")
    (setq newFontFile (acet-file-find-font "arial.TTF"))
    (if (not (tblobjname "STYLE" "Arial"))
        (progn (setq tsobj (vla-add *TextStyles* "Arial"))
               (vla-put-FontFile tsobj newFontFile)
        )
    )
    (setq ss (ssget '((0 . "LINE,LWPOLYLINE"))))
    (setq entlst (acet-ss-to-list ss))
    (if (eq (getvar "users1") "0.0")
        (setvar "users1" "12.50")
    )
    (if (null (setq hei_TDim
                       (getreal
                           (acet-str-format "\nEnter Height text dim : < %1 > "
                                            (getvar "users1")
                           )
                       )
              )
        )
        (setq hei_TDim (getvar "users1"))
    )
    (if (numberp hei_TDim)
        (setvar "users1" (rtos hei_TDim))
        (progn (setvar "users1" hei_TDim) (setq hei_TDim (atof hei_TDim)))
    )
    (if (null (setq prec (getint (acet-str-format
                                     "\nEnter number of decimal places: < %1 > "
                                     (itoa (getvar "useri1"))
                                 )
                         )
              )
        )
        (setq prec (getvar "useri1"))
    )
    (setvar "useri1" prec)
    (if entlst
        (progn (foreach ent entlst
                   (setq Epo   (vlax-curve-getEndpoint ent)
                         Spo   (vlax-curve-getStartpoint ent)
                         ang   (angle Spo Epo)
                         Epara (vlax-curve-getEndParam ent)
                         dis   (vlax-curve-getDistAtParam ent Epara)
                   )
                   (setq entname (dxf 0 ent))
                   (setq po1 (vlax-curve-getPointatparam
                                 ent
                                 (vlax-curve-getParamAtdist ent (/ dis 4))
                             )
                         po2 (vlax-curve-getPointatparam
                                 ent
                                 (vlax-curve-getParamAtdist ent (* dis 0.75))
                             )
                   )                             
                   (setq po_dim (ACET-GEOM-MIDPOINT Spo po1))
                   (setq objdim1 (vla-AddDimAligned *Model*
                                                    (vlax-3d-point Spo)
                                                    (vlax-3d-point po1)
                                                    (vlax-3d-point po_dim)
                                 )
                   )
                   (vla-put-TextHeight objdim1 hei_TDim)
                   (vla-put-ArrowheadSize objdim1 (* hei_TDim 0.5))
                   (vla-put-PrimaryUnitsPrecision objdim1 prec)
                   (vla-put-TextStyle objdim1 "Arial")
                   (vla-put-VerticalTextPosition objdim1 acAbove)
                   (setq objdim1A (vla-AddDimAligned *Model*
                                                     (vlax-3d-point Spo)
                                                     (vlax-3d-point po1)
                                                     (vlax-3d-point po_dim)
                                  )
                   )
                   (vla-put-TextOverride objdim1A "A")
                   (vla-put-VerticalTextPosition objdim1A acUnder)
                   (vla-put-TextHeight objdim1A hei_TDim)
                   (vla-put-TextStyle objdim1A "Arial")
                   (if (not objdimstyle_th)
                       (progn (vla-put-ScaleFactor objdim1 1)
                              (vla-put-textGap objdim1 (* hei_TDim 0.7))
                              (vla-put-ExtLine1Suppress objdim1 :vlax-false)
                              (vla-put-ExtLine2Suppress objdim1 :vlax-false)
                              (vla-put-DimLine1Suppress objdim1 :vlax-false)
                              (vla-put-DimLine2Suppress objdim1 :vlax-false)
                              (vla-put-Arrowhead1Type objdim1 acArrowArchTick)
                              (vla-put-Arrowhead2Type objdim1 acArrowArchTick)
                              (vla-put-TextPrefix objdim1 "")
                              (vla-put-TextSuffix objdim1 "")
                              (vla-put-TextInsideAlign objdim1 :vlax-false)
                              (if (not (tblobjname "dimstyler" "kichthuoc"))
                                  (setq objdimstyle_th (vla-add *dimstyles*
                                                                "kichthuoc"
                                                       )
                                  )
                              )
                              (vla-CopyFrom objdimstyle_th objdim1)
                              (if objdimstyle_th
                                  (vla-put-activeDimstyle ActDoc objdimstyle_th)
                                  (vla-put-activeDimstyle
                                      ActDoc
                                      (vla-item *dimstyles* "kichthuoc")
                                  )
                              )
                       )
                   )
                   (setq po_dim (ACET-GEOM-MIDPOINT po1 po2))
                   (setq objdim2 (vla-AddDimAligned *Model*
                                                    (vlax-3d-point po1)
                                                    (vlax-3d-point po2)
                                                    (vlax-3d-point po_dim)
                                 )
                   )
                   (vla-put-PrimaryUnitsPrecision objdim2 prec)
                   (vla-put-TextHeight objdim2 hei_TDim)
                   (setq objdim2B (vla-AddDimAligned *Model*
                                                     (vlax-3d-point po1)
                                                     (vlax-3d-point po2)
                                                     (vlax-3d-point po_dim)
                                  )
                   )
                   (vla-put-TextOverride objdim2B "B")
                   (vla-put-VerticalTextPosition objdim2B acUnder)
                   (vla-put-TextHeight objdim2B hei_TDim)
                   (setq po_dim (ACET-GEOM-MIDPOINT po2 Epo))
                   (setq objdim3 (vla-AddDimAligned *Model*
                                                    (vlax-3d-point po2)
                                                    (vlax-3d-point Epo)
                                                    (vlax-3d-point po_dim)
                                 )
                   )
                   (vla-put-PrimaryUnitsPrecision objdim3 prec)
                   (vla-put-TextHeight objdim3 hei_TDim)
                   (setq objdim3A (vla-AddDimAligned *Model*
                                                     (vlax-3d-point po2)
                                                     (vlax-3d-point Epo)
                                                     (vlax-3d-point po_dim)
                                  )
                   )
                   (vla-put-TextOverride objdim3A "A")
                   (vla-put-VerticalTextPosition objdim3A acUnder)
                   (vla-put-TextHeight objdim3A hei_TDim)
                   (While (= 5 (car (setq gr (grread 't 13 0))))
                       (redraw)
                       (setq p3 (trans (cadr gr) 1 0))
                       (setq
                           h (/ (* (A_triangle Spo p3 po1) 2) (distance Spo po1))
                       )
                       (setq bit (calcz Spo P3 po1))
                       (if (> bit 0)
                           (setq an (+ ang (/ pi 2)))
                           (setq an (- ang (/ pi 2)))
                       )
                       (setq potext1 (polar (acet-geom-midpoint Spo po1) an h))
                       (setq potext2 (polar (acet-geom-midpoint po1 po2) an h))
                       (setq potext3 (polar (acet-geom-midpoint po2 Epo) an h))
                       (vla-put-TextPosition objdim1 (vlax-3d-point potext1))
                       (vla-put-TextPosition objdim1A (vlax-3d-point potext1))
                       (vla-put-TextPosition objdim2 (vlax-3d-point potext2))
                       (vla-put-TextPosition objdim2B (vlax-3d-point potext2))
                       (vla-put-TextPosition objdim3 (vlax-3d-point potext3))
                       (vla-put-TextPosition objdim3A (vlax-3d-point potext3))
                   )
               )
               (acet-sysvar-restore)
               (Setq xinchao (vl-list->string '(72   101  108  108  111  32
                                                101  118  101  114  121  98
                                                111  100  121  46   32   77
                                                121  32   110  97   109  101
                                                32   84   114  97   110  32
                                                84   104  105  101  112
                                               )
                             )
               )
        )
    )
    (command "undo" "en")
    (princ xinchao)
    (princ)
)

Lisp thể hiện những dimension còn "động đậy" cho đến khi người dùng pick điểm phù hợp đặt vị trí để cố định dimension.


<<

Filename: 446967_cdim.lsp
Tác giả: Danh Cong
Bài viết gốc: 446980
Tên lệnh: dem
(Xin lisp) Dim ghi số lượng nhân với khoảng cách

Code cho bạn, lisp này có thể đếm số lượng thép theo:

1 : Theo khoảng cách

2 ; Theo số lượng;

3 : Theo khoảng cách, số lượng  với Dim đã bị sửa số;



(defun c:DEM ( / #DEM-KHOANG-CACH #DEM-SO-LUONG #DEMTHEP-NAME E1 E42 EDXF ENAME ENEW OBJECT)

  (command "undo" "begin")

  (or #DEMTHEP-NAME (setq #DEMTHEP-NAME "KHOANG-CACH-1"))

  (initget...

>>

Code cho bạn, lisp này có thể đếm số lượng thép theo:

1 : Theo khoảng cách

2 ; Theo số lượng;

3 : Theo khoảng cách, số lượng  với Dim đã bị sửa số;



(defun c:DEM ( / #DEM-KHOANG-CACH #DEM-SO-LUONG #DEMTHEP-NAME E1 E42 EDXF ENAME ENEW OBJECT)

  (command "undo" "begin")

  (or #DEMTHEP-NAME (setq #DEMTHEP-NAME "KHOANG-CACH-1"))

  (initget "KHOANG-CACH-1 KHOANG-CACH-2 SO-LUONG-1 SO-LUONG-2 SUA-KHOANG-CACH SUA-SO-LUONG")

  (setq #DEMTHEP-NAME (cond ((getkword (strcat "\nSelect Program: <"#DEMTHEP-NAME">")))(#DEMTHEP-NAME)))

 

  (cond ((or (= #DEMTHEP-NAME "KHOANG-CACH-1") (= #DEMTHEP-NAME "KHOANG-CACH-2") (= #DEMTHEP-NAME "SUA-KHOANG-CACH"))

(or #DEM-KHOANG-CACH (setq #DEM-KHOANG-CACH 150.0))

  (setq #DEM-KHOANG-CACH (cond ((getreal (strcat "\nNhap khoang cach buoc thep: < " (rtos #DEM-KHOANG-CACH 2 0) " >:")))(#DEM-KHOANG-CACH))))

      ((or (= #DEMTHEP-NAME "SO-LUONG-1") (= #DEMTHEP-NAME "SO-LUONG-2") (= #DEMTHEP-NAME "SUA-SO-LUONG"))

(or #DEM-SO-LUONG (setq #DEM-SO-LUONG 10))

  (setq #DEM-SO-LUONG (cond ((getreal (strcat "\nNhap so luong thanh thep: < " (rtos #DEM-SO-LUONG 2 0) " >:")))(#DEM-SO-LUONG))))

      ); End Cond

(setq Object (ssget'((0 . "DIMENSION"))))

(repeat  (sslength Object)

(setq Ename (ssname Object 0)

       Edxf (entget Ename)

       E42 (cdr (assoc 42 Edxf)))

 (cond ((or (= #DEMTHEP-NAME "KHOANG-CACH-1") (= #DEMTHEP-NAME "KHOANG-CACH-2")) (setq E1 (/ E42 #DEM-KHOANG-CACH)))

       ((or (= #DEMTHEP-NAME "SO-LUONG-1")    (= #DEMTHEP-NAME "SO-LUONG-2"))    (setq E1 (/ E42 #DEM-SO-LUONG)))

       ((= #DEMTHEP-NAME "SUA-KHOANG-CACH")   (setq E1 (/ (atof (cdr (assoc 1 Edxf))) #DEM-KHOANG-CACH)))

       ((= #DEMTHEP-NAME "SUA-SO-LUONG")      (setq E1 (/ (atof (cdr (assoc 1 Edxf))) #DEM-SO-LUONG))))

 

  (cond ((= #DEMTHEP-NAME "KHOANG-CACH-1") (setq Enew (subst (cons 1 (strcat (rtos E1 2 0) "X" (rtos #DEM-KHOANG-CACH 2 0) "=<>")) (assoc 1 Edxf) Edxf)))

((= #DEMTHEP-NAME "KHOANG-CACH-2") (setq Enew (subst (cons 1 (strcat (rtos E1 2 0) "X" (rtos #DEM-KHOANG-CACH 2 0))) (assoc 1 Edxf) Edxf)))

((= #DEMTHEP-NAME "SO-LUONG-1")    (setq Enew (subst (cons 1 (strcat (rtos #DEM-SO-LUONG 2 0) "X" (rtos E1 2 1) "=<>")) (assoc 1 Edxf) Edxf)))

((= #DEMTHEP-NAME "SO-LUONG-2")    (setq Enew (subst (cons 1 (strcat (rtos #DEM-SO-LUONG 2 0) "X" (rtos E1 2 0))) (assoc 1 Edxf) Edxf)))

((= #DEMTHEP-NAME "SUA-KHOANG-CACH")    (setq Enew (subst (cons 1 (strcat (rtos E1 2 0) "X" (rtos #DEM-KHOANG-CACH 2 0) "=" (cdr (assoc 1 Edxf)))) (assoc 1 Edxf) Edxf)))

((= #DEMTHEP-NAME "SUA-SO-LUONG")    (setq Enew (subst (cons 1 (strcat (rtos #DEM-SO-LUONG 2 0) "X" (rtos E1 2 1) "=" (cdr (assoc 1 Edxf)))) (assoc 1 Edxf) Edxf))))

  (entmod Enew)

  (if (and (> (abs (- (* (atof (rtos E1 2 0)) #DEM-KHOANG-CACH) E42)) 0.1) (or (= #DEMTHEP-NAME "KHOANG-CACH-1")

       (= #DEMTHEP-NAME "KHOANG-CACH-2")))

    (vla-put-Textcolor (vlax-ename->vla-object Ename) 1)

    (vla-put-Textcolor (vlax-ename->vla-object Ename) 3))

  (ssdel Ename Object)

  ); end repeat

(command "undo" "end")

(princ))


<<

Filename: 446980_dem.lsp
Tác giả: thiep
Bài viết gốc: 446953
Tên lệnh: c2pl
Nhờ tiền bối viết giùm lisp chuyển hình tròn thành đa giác
46 phút trước, hawking312 đã nói:

Như tiêu đề ạ, em có việc...

>>
46 phút trước, hawking312 đã nói:

Như tiêu đề ạ, em có việc muốn chuyển các đường cong hoặc hình tròn thành các đa giác. Em thấy có app tương tự của Autodesk nhưng có tính phí, mong các tiền bối giúp đỡ. 

Link Autodesk:
CIR2VECT – Circle to Vectored polygon

ARCVECT – Arc, PolyArc and Circle Vectorizer

Video ví dụ

https://www.youtube.com/watch?v=JZJTSI2N66E

Lisp này mình mới vừa đăng cách nay gần 1 tháng, chịu khó tìm là có:

;;; lisp convert curve: ARC, CIRCLE, ELLIPSE, SPLINE to Lwpolyline
;;;                  by Trân Thiêp  0918841230                              
(defun DXF (code en) (cdr (assoc code (entget en))))

(defun c:c2pl (/ ss lstpo obj)
    (command "undo" "be")
    (and (not ACET-GEOM-SPLINE-POINT-LIST)
         (findfile "acetutil.arx")
        (arxload (findfile "acetutil.arx") "Failed to Load Express Tools")
    )
    (defun curve->Lstpo (ent num / LL_UR)
        (setq LL_UR (acet-ent-geomextents ent))
        (ACET-GEOM-SPLINE-POINT-LIST ent
                                     (/ (distance (car LL_UR) (cadr LL_UR)) num)
        )
    )
    (acet-error-init '(("cmdecho" 0 "osmode" 0 "PLINEGEN" 1) 1 (acet-ui-status)))
    (acet-ui-status "\nSelect curves to convert it into Lwpolylines" "PROMPT")
    (while (NOT (setq ss (ssget '((0 . "ARC,CIRCLE,ELLIPSE,SPLINE")))))
        (acet-ui-status "\nSelect arn't right, please select curves again" "PROMPT")
    )
    (acet-ui-status)
    (mapcar '(lambda (x)
                 (cond ((wcmatch (acet-dxf 0 (entget x)) "ARC,CIRCLE,ELLIPSE")
                        (acet-Lwpline-make (list (curve->Lstpo x 2020)))
                       )
                       (T (acet-Lwpline-make (list (curve->Lstpo x 3000))))
                 )
                 (setq obj (vlax-ename->vla-object (entlast)))
                 (if (dxf 6 x)(Vla-put-Linetype obj (dxf 6 x)))
                 (if (dxf 48 x)
                     (Vla-put-LinetypeScale obj (dxf 48 x))
                 )
                 (Vla-put-LinetypeGeneration obj :vlax-true)
                 (Vla-put-layer obj (dxf 8 x))
                 (if (setq col (dxf 62 x))
                     (Vla-put-color obj col)
                     (Vla-put-color obj 256)
                 )
                 (entdel x)
             )
            (acet-ss-to-list ss)
    )
    (acet-error-restore)
    (command "undo" "en")
    (princ "\nOk")
)

 


<<

Filename: 446953_c2pl.lsp
Tác giả: khaosat2009
Bài viết gốc: 102517
Tên lệnh: rft
lisp Phun tọa độ các điểm từ file txt vào CAD
Cái này mình mạn phép chỉnh bản quyền của tác giả 1 ty để làm theo yêu cầu của bạn

Có gì pm nhé

;; free lisp from cadviet.com
(defun c:RFT (/...
>>
Cái này mình mạn phép chỉnh bản quyền của tác giả 1 ty để làm theo yêu cầu của bạn

Có gì pm nhé

;; free lisp from cadviet.com
(defun c:RFT (/ code data f h line pt pxy spc txt stt ten)
				;Read File Txt
     ;|  By : Gia Bach, gia_bach @  www.CadViet.com             |;
 (vl-load-com)
 (defun Split (str / i kitu line lst txtPhanbiet)
   (setq i 1
  txtPhanbiet
   (strcat (chr 9) (chr 32) (chr 44))
   )
   (while (< i (strlen str))
     (setq kitu (substr str i 1))
     (if (vl-string-search kitu txtPhanbiet)
(progn
  (if (null Lst)
    (setq Lst (list (substr Str 1 (- i 1))))
    (setq Lst (append Lst (list (read (substr Str 1 (- i 1))))))
  )
  (setq	Str (substr Str (+ i 1))
	i   1
  )
)
(setq i (1+ i))
     )
   )
   (setq Lst (append Lst (list Str)))
 )
 (or *h* (setq *h* 2))
 (initget 6)
 (setq	h (getdist (strcat "\nNhap chieu cao Text <" (rtos *h*) "> :")
  )
 )
 (if h
   (setq *h* h)
   (setq h *h*)
 )
 (if (setq ten (getfiled "Chon File txt" (getvar "dwgprefix") "txt" 8))
   (progn
     (or (tblsearch "layer" "Point")
  (command "-layer" "n" "Point" "")
     )
     (or (tblsearch "layer" "Sothutu")
  (command "-layer" "n" "Sothutu" "c" 3 "Sothutu" "")
     )
     (or (tblsearch "layer" "Caodo")
  (command "-layer" "n" "Caodo" "c" 4 "Caodo" "")
     )
     (or (tblsearch "layer" "Code")
  (command "-layer" "n" "Code" "c" 2 "Code" "")
     )
     (setq spc	(vla-get-ModelSpace
	  (vla-get-ActiveDocument (vlax-get-Acad-Object))
	)
     )
     (setq f (open (findfile ten) "r"))
     (while (setq Line (read-line f))
(if (wcmatch
      Line
      (strcat "*" (chr 9) "*,*" (chr 32) "*,*`" (chr 44) "*")
    )
  (progn
    (setq data (split Line)
	  code (last data)
    )
    (if	(and
	  (= (vl-list-length data) 5)
	  (setq pt (vl-remove code (cdr data)))
	  (not (vl-catch-all-error-p
		 (vl-catch-all-apply 'vlax-3d-point pt)
	       )
	  )
	)
;;;neu du lieu data co 5 bien so
      (progn
	(setq stt (car data)
	      pXY (list (car pt) (cadr pt))
	)
	(vla-put-Layer
	  (vla-addpoint spc (vlax-3d-point pXY))
	  "Point"
	)
	(vla-put-Layer
	  (setq	txt (vla-addtext
		      spc
		      stt
		      (vlax-3d-point (list 0 0 0))
		      h
		    )
	  )
	  "Sothutu"
	)
	(vla-put-Alignment txt 8)
	(vla-put-TextAlignmentPoint txt (vlax-3d-point pXY))
	(vla-put-Layer
	  (setq	txt (vla-addtext
		      spc
		      code
		      (vlax-3d-point (list 0 0 0))
		      h
		    )
	  )
	  "Code"
	)
	(vla-put-Alignment txt 6)
	(vla-put-TextAlignmentPoint
	  txt
	  (vlax-3d-point (polar pXY 0 (* 0.2 h)))
	)
	(vla-put-Layer
	  (vla-addtext spc (caddr pt) (vlax-3d-point pXY) h)
	  "Caodo"
	)
      )
      ;;het progn list data=5
;;;neu du lieu data co 4 bien so (ban co the dung ham COND hoac if de bay loi
      (progn
	(setq pt (vl-remove code (cdr data)))
	(not (vl-catch-all-error-p
	       (vl-catch-all-apply 'vlax-3d-point pt)
	     )
	)
	(setq stt (car data)
	      pXY (list (car pt) (cadr pt))
	)
	(vla-put-Layer
	  (vla-addpoint spc (vlax-3d-point pXY))
	  "Point"
	)
	(vla-put-Layer
	  (setq	txt (vla-addtext
		      spc
		      stt
		      (vlax-3d-point (list 0 0 0))
		      h
		    )
	  )
	  "Sothutu"
	)
	(vla-put-Alignment txt 8)
	(vla-put-TextAlignmentPoint txt (vlax-3d-point pXY))
	(vla-put-Layer
	  (vla-addtext spc (last data) (vlax-3d-point pXY) h)
	  "Caodo"
	)
      )
;;;het progn list=4
    )
  )
)
     )
   )
 )
 (princ)
)

Cám ơn Bạn thật nhiều, Mình có thể nhớ bạn hướng dẫn nội dung của lisp trên được không ? Mình muốn học và hiểu về cách xây dựng đoạn Lisp trên.

Mong được bạn giúp


<<

Filename: 102517_rft.lsp
Tác giả: thiep
Bài viết gốc: 447021
Tên lệnh: tbatt
Nhờ viết Lisp thêm/ bớt tiền tố và hậu tố cho Block attribute

Lisp ở đây, lệnh là TBATT:

Lisp sẽ yêu cầu nhiều câu:

1) Pick 1 block để lisp lấy tên thuộc tính, nếu pick không đúng, không phải là block hay block không có thuộc tính sẽ yêu cầu pick lại.

2) Thêm hay bớt ....

3) Chọn các block có thuộc tính để thay đổi.

4) * Nếu là thêm (t): lisp sẽ có 2 lần xuất hiện hộp thoại: 1 lần hỏi thêm tiền...

>>

Lisp ở đây, lệnh là TBATT:

Lisp sẽ yêu cầu nhiều câu:

1) Pick 1 block để lisp lấy tên thuộc tính, nếu pick không đúng, không phải là block hay block không có thuộc tính sẽ yêu cầu pick lại.

2) Thêm hay bớt ....

3) Chọn các block có thuộc tính để thay đổi.

4) * Nếu là thêm (t): lisp sẽ có 2 lần xuất hiện hộp thoại: 1 lần hỏi thêm tiền tố vào giá trị ATT, 1 lần hỏi thêm hậu tố vào giá trị ATT

    * Nếu là bớt (b): lisp sẽ có 2 lần xuất hiện hộp thoại: 1 lần hỏi: Xoá bao nhiêu chữ ở trước giá trị ATT; 1 lần hỏi: Xoá bao nhiêu chữ ở sau giá trị ATT

 

Yêu cầu người dùng lisp phải copy file doslib vào thư mục support của autoCad: free ở trang https://wiki.mcneel.com/doslib/home

;;; LISP  thêm bot string vào ATT
;;;          by TrânThiêp 05/2020
;;;		09188411230

(Defun loadDL (/ CPUxBit Name fullname bitD_L)
    (setq CPUxBit (if (wcmatch (getenv "PROCESSOR_ARCHITECTURE") "*64")
                      "x64"
                      ""
                  )
    )
    (setq Name (strcat "doslib" (substr (getvar "acadver") 1 2) CPUxBit ".arx"))
    (foreach sup (acet-str-to-list ";" (getvar "acadprefix"))
        (and (vl-string-search "\\support" sup)
             (findfile (setq fullname (strcat sup "\\" Name)))
             (vl-catch-all-error-p (vl-catch-all-apply 'arxload '(fullname)))
             (setq bitD_L T)
        )
    )
    bitD_L
)
(defun sysvar-set (lst_setvar / strN var var_oldname n)
    (setq n 0
          lstvar_thiep nil
          lstValue_thiep nil
    )
    (repeat (/ (length lst_setvar) 2)
        (setq var         (nth n lst_setvar)
              var_oldname (strcat "oldvar_thiep" (itoa n))
        )
        (setq lstvar_thiep (append lstvar_thiep (list var)))
        (set (read var_oldname) (getvar var))
        (setq lstValue_thiep (append lstValue_thiep (list (read var_oldname))))
        (setvar var (nth (+ n 1) lst_setvar))
        (setq n (+ 2 n))
    )
)
(defun sysvar-restore ()
    (mapcar '(lambda (var value) (setvar var (eval value)))
            lstvar_thiep
            lstValue_thiep
    )
)
(vl-load-com)
(defun *error* (msg)
    (or (wcmatch (strcase msg) "*BREAK,*CANCEL*,*EXIT*")
        (princ (strcat "\n** Error: " msg " **"))
    )
    (acet-sysvar-restore)
    (command "undo" "en")
    (princ)
)
;;;===========================================================================
(defun c:tbatt (/ ss entlst entblk tag_lst TTnil bit TT_lst TH_lst tag_lst_new)
    (command "undo" "be")
    (sysvar-set '("cmdecho" 0 "osmode" 0))
    (while
        (OR (NOT (setq entblk
                          (car
                              (entsel
                                  "\nPick 1 block \U+0111\U+1EC3 l\U+1EA5y thu\U+1ED9c tính c\U+1EE7a block"
                              )
                          )
                 )
            )
            (NOT (eq (cdr (assoc  0 (entget entblk))) "INSERT"))
            (if (null (setq tag_lst (acet-insert-attrib-get entblk)))
                (progn (acet-ui-message "BLock này không có thu\U+1ED9c tính"
                                        "Prompt"
                                        4144
                       )
                )
            )
        )  (prompt "\nPick ch\U+01B0a \U+0111úng, vui lòng pick l\U+1EA1i")
    )
    (setq TTnil nil)
    (mapcar '(lambda (x) (setq TTnil (append TTnil (list (list (car x) "")))))
            tag_lst
    )
    (initget "Them Bot")
    (if (eq (getvar "users1") "")
        (setvar "users1" "T")
    )
    (if (= (setq bit
                    (getstring
                        (acet-str-format
                            "\nThêm hay B\U+1EDBt t\U+1EEB vào giá tr\U+1ECB thu\U+1ED9c tính: (hem / ot) <%1> "
                            (getvar "users1")
                        )
                    )
           )
           ""
        )
        (setq bit (getvar "users1"))
    )
    (setvar "users1" bit)
    (acet-ui-status "Select Blockreferences" "Prompt")
    (setq ss (ssget '((0 . "INSERT"))))
    (setq entlst (acet-ss-to-list ss))
    (acet-ui-status)
    (if (loadDL)
        (progn (cond ((= (strcase bit) "T")
                      (setq TT_lst
                               (dos_proplist
                                   "Change ATT value   lisp by Trân Thiêp"
                                   "Thêm ti\U+1EC1n t\U+1ED1 vào các giá tr\U+1ECB thu\U+1ED9c tính (n\U+1EBFu có)"
                                   TTnil
                               )
                      )
                      (setq HT_lst
                               (dos_proplist
                                   "Change ATT value   lisp by Trân Thiêp"
                                   "Thêm h\U+1EADu t\U+1ED1 vào các giá tr\U+1ECB thu\U+1ED9c tính (n\U+1EBFu có)"
                                   TTnil
                               )
                      )
                      (mapcar '(lambda (e)
                                   (setq tag_lst_new nil)
                                   (mapcar '(lambda (x tt ht)
                                                (setq tag_lst_new
                                                         (append
                                                             tag_lst_new
                                                             (list
                                                                 (list (car x)
                                                                       (strcat (cdr tt)
                                                                               (cadr x)
                                                                               (cdr ht)
                                                                       )
                                                                 )
                                                             )
                                                         )
                                                )
                                            )
                                           (acet-insert-attrib-get e)
                                           TT_lst
                                           HT_lst
                                   )
                                   (acet-insert-attrib-set e tag_lst_new nil)
                               )
                              entlst
                      )
                     )
                     ((= (strcase bit) "B")
                      (setq TT_lst
                               (dos_proplist
                                   "Change ATT value   lisp by Trân Thiêp"
                                   "Xoá b\U+1EDBt bao nhiêu ch\U+1EEF \U+1EDF tr\U+01B0\U+1EDBc giá tr\U+1ECB thu\U+1ED9c tính"
                                   TTnil
                               )
                      )
                      (setq HT_lst
                               (dos_proplist
                                   "Change ATT value   lisp by Trân Thiêp"
                                   "Xoá b\U+1EDBt bao nhiêu ch\U+1EEF \U+1EDF sau giá tr\U+1ECB thu\U+1ED9c tính (n\U+1EBFu có)"
                                   TTnil
                               )
                      )
                      (mapcar '(lambda (e)
                                   (setq tag_lst_new nil)
                                   (mapcar '(lambda (x tt ht)
                                                (setq tag_lst_new
                                                         (append
                                                             tag_lst_new
                                                             (list
                                                                 (list
                                                                     (car x)
                                                                     (substr
                                                                         (if (>= (atof
                                                                                     (cdr tt)
                                                                                 )
                                                                                 1
                                                                             )  (setq
                                                                                    str
                                                                                       (substr (cadr x) (1+ (fix (atof (cdr tt)))))
                                                                                )
                                                                                (setq
                                                                                    str
                                                                                       (cadr x)
                                                                                )
                                                                         )
                                                                         1
                                                                         (- (strlen
                                                                                str
                                                                            )
                                                                            (fix
                                                                                (atof
                                                                                    (cdr ht)
                                                                                )
                                                                            )
                                                                         )
                                                                     )
                                                                 )
                                                             )
                                                         )
                                                )
                                            )
                                           (acet-insert-attrib-get e)
                                           TT_lst
                                           HT_lst
                                   )
                                   (acet-insert-attrib-set e tag_lst_new nil)
                               )
                              entlst
                      )
                     )
               )
        ) ;_PROGN
    ) ;_IF
    (sysvar-restore)
    (command "undo" "en")
    (princ "\nOK")    
)

 

 


<<

Filename: 447021_tbatt.lsp

Trang 310/330

310