Xem cái này xem được không bạn.

ml style bạn cần đổi sang current 

chọn ml cần đổi enter đến kết thúc lệnh

Change mline.lsp

;;
;;...
>>

Xem cái này xem được không bạn.

ml style bạn cần đổi sang current 

chọn ml cần đổi enter đến kết thúc lệnh

Change mline.lsp

;;
;; http://cadxp.com/index.php?/topic/34672-remplacer-multiligne-par-une-autre-multiligne/page__pid__188...
;; Change_MLine par Bonuscad - Version 1.00
;; Remplacer une MLine par une autre qui utilise le style de MLine courant
;;  

;; 
;; VLisp Routine :  Change_MLine
;; Change THE selected MLine to the CURRENT MLine style
;; and you can switch to Closed/Opened MLine ...
;; 
;; Minimum Translation for US/English Forums by Patrice BRAUD
;; 
 
(vl-load-com) 

(defun l-coor2l-pt (lst flag / )
  (if lst
    (cons
      (list
        (car lst)
        (cadr lst)
        (if flag
          (+ (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0) (caddr lst))
          (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0)
        )
      )
      (l-coor2l-pt (if flag (cdddr lst) (cddr lst)) flag)
    )
  )
)

(defun c:Change_MLine ( / js ent ename l_pt cur_lay closed) 

; (princ "\nSélectionner une multiligne.") 
  (princ "\nPlease Select a MLine ") 

  (while (null (setq js (ssget "_+.:E:S" '((0 . "MLINE"))))) 

;   (princ "\nCe n'est pas une multiligne!") 
    (princ "\nThis is not a MLine ! ") 

  )
  (setq
    ent (ssname js 0)
    ename (vlax-ename->vla-object ent)
    l_pt (l-coor2l-pt (vlax-get ename 'Coordinates) T)
    cur_lay (getvar "CLAYER")
  ) 

;;  (initget "Fermée Ouverte _Closed Open")
;;  (if (eq (getkword "\nMultiligne  <Ouverte>: ") "Closed")

    (initget "Closed Open")
    (if (eq (getkword "\nMLine  <Open>: ") "Closed")

    (setq closed T)
  )
  (setvar "clayer" (vlax-get ename 'Layer))
  (command "_.mline")
  (foreach n l_pt (command "_none" (trans n 0 1)))
  (if closed (command "_close") (command ""))
  (entdel ent)
  (setvar "CLAYER" cur_lay)
  (prin1)
)

18 phút trước, zaqzaqzaqzaq đã nói:

sử dụng lisp của...

>>

18 phút trước, zaqzaqzaqzaq đã nói:

sử dụng lisp của a vanngeonhuxua thì làm được rồi nhưng em nhờ a ấy sửa lại 1 chút để sử dụng cho tiện

Bạn thử xem nhé ( mình sửa lại dựa lisp trên của vanngeonhuxua )

(vl-load-com) 

(defun l-coor2l-pt (lst flag / )
  (if lst
    (cons
      (list
        (car lst)
        (cadr lst)
        (if flag
          (+ (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0) (caddr lst))
          (if (vlax-property-available-p ename 'Elevation) (vlax-get ename 'Elevation) 0.0)
        )
      )
      (l-coor2l-pt (if flag (cdddr lst) (cddr lst)) flag)
    )
  )
)

(defun c:Change_MLine ( / js ent ename l_pt cur_lay closed lst ss) 
(princ "\nPlease Select a MLine ") 

  (if (setq ss (ssget '((0 . "MLINE"))))
    (progn
      (setq js 0)
      (repeat (sslength ss)
      
  (setq
    ent (ssname ss js)
    ename (vlax-ename->vla-object ent)
    l_pt (l-coor2l-pt (vlax-get ename 'Coordinates) T)
    cur_lay (getvar "CLAYER")
  ) 
    
  (setvar "clayer" (vlax-get ename 'Layer))
  (command "_.mline" "S" (vla-get-MlineScale ename))
  (foreach n l_pt (command "_none" (trans n 0 1)))
  (command "")
	
	(vla-put-Justification (vlax-ename->vla-object(entlast)) (vla-get-Justification ename))
  (entdel ent)
  
	(setq js (1+ js))
	)
      (setvar "CLAYER" cur_lay)
  ))
  (prin1)
)

 

<<

Thử xem oke không bạn.

(defun c:te...
>>

Thử xem oke không bạn.

(defun c:te (/ ss pt l1 l2 pt2)
  (setq ss (ssget (list (cons 0 "LWPOLYLINE,LINE"))))
  (setq pt (getpoint "\nPick point"))
  (setq l1 (acet-ss-zoom-extents ss))
  (setq l2 (acet-ss-zoom-extents (ssget "_X")))
  (command "Move" ss "" "_NON" (car l1) "_NON" (cadr l2))
  (setq pt2 (polar pt (angle (car l1) (cadr l2)) (distance (car l1) (cadr l2))))
  (acet-ss-zoom-extents ss)
  (command "BOUNDARY" pt2 "" )
  (setq ss (ssadd (entlast) ss))
  (command "Move" ss "" "_NON" (cadr l2) "_NON" (car l1))
  (acet-ss-zoom-extents ss)
  )

2 giờ trước, minhmani đã nói:

đúng rồi bác, mấy đường arc,...

>>

2 giờ trước, minhmani đã nói:

đúng rồi bác, mấy đường arc, line, 2Dpline thì đơn giản; nhưng mà cái đường elip về pline thì nó cứ phải opset 2 lần mới thành được spline rồi mới chuyển về thành pline được ý bác :D

(defun c:te(/ ss)
(setq ss (ssget))
(command "PEDIT" "M" ss "" "Y" "")
  (acet-ss-convert-ellipses-to-plines ss)
  )

 

<<

Vào lúc 30/3/2020 tại 10:32, minhmani đã nói:

Hiện mình đang cần 1...

>>

Vào lúc 30/3/2020 tại 10:32, minhmani đã nói:

Hiện mình đang cần 1 lisp có thể chuyển tất cả các loại nét ( 2Dpline, arc, ellipse...) về thành pline. Mong các cao nhân của diễn đàn giúp đỡ. Xin cảm ơn :D

Năm 2009, Thiep có viết lisp này rồi, đã có trong thư viện lisp của cadviet, nhưng cũng chưa ưng ý lắm.

Lisp sau đây Thiep đã hoàn thiện nó, các curve có đoạn bán kính cong lớn thì node sẽ thưa hơn những đoạn có bán kính cong nhỏ.

TB: Xin hỏi minhmani, bản vẽ của bạn dùng phần mềm gì mà bạn có thể vẽ được mặt cắt địa chất công trình như vậy, và dữ liệu đầu vào như thế nào? Có thể share cho mình được không, để học hỏi thêm. (mail: tranthiep66@gmail.com)

(defun DXF (code en) (cdr (assoc code (entget en))))
(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)
    )
)
(defun c:c2pl (/ ss lstpo obj)
    (command "undo" "be")
    (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))
                 (Vla-put-color obj (dxf 62 x))
                 (entdel x)
             )
            (acet-ss-to-list ss)
    )
    (acet-error-restore)
    (command "undo" "en")
    (princ "\nOk")
)

 

<<

Chào các anh em diễn đàn, em có sưu tầm một lisp của các bác trên diễn đàn mình mà thấy chủ đề cũng rất lâu rồi nên nay em xin mạn phép lập chủ đề mới xin nhờ các anh em giúp đỡ.Vấn đề như sau:

-Chức năng Lisp cũ: chọn các Text là số (số, số nguyên, số thực...)

-Mong muốn chỉnh sửa Lisp: Chọn được cả Mtext,...

Quên mất, còn đây là code:

 

MIA.LSP

(DEFUN DIMIA(/ DCL_ID_MIA)  
 (setq DCL_ID_MIA (load_dialog "MIA.DCL"))
 (if (not(new_dialog "MIA" DCL_ID_MIA))...
>>

Quên mất, còn đây là code:

 

MIA.LSP

(DEFUN DIMIA(/ DCL_ID_MIA)  
 (setq DCL_ID_MIA (load_dialog "MIA.DCL"))
 (if (not(new_dialog "MIA" DCL_ID_MIA)) (exit))
 (SETMIAVALUE)
 (Is_Chk_KH)
 (action_tile "tdX" "(CHECKVALUE_TDX)")
 (action_tile "tdY" "(CHECKVALUE_TDY)")
 (action_tile "caodo" "(CHECKVALUE_CD)")
 (action_tile "Is_KH" "(Is_Chk_KH)")
 (action_tile "info" "(ABOUT)")
 (action_tile "accept" "(GETMIAVALUE) (done_dialog 1)")
 (setq RES_MIA (start_dialog))
 (If (= RES_MIA 1)
(progn
  (DATMIA)
  (DIMIA)
)
 )  
 (unload_dialog DCL_ID_MIA) 
)

(DEFUN C:MIA()
 (MIA_INIT)
 (DIMIA)
)

(DEFUN SETMIAVALUE()
 (set_tile "Is_KH" IsKH)
 (set_tile "kyhieu" Kyhieu)
 (set_tile "caodo" Caodo)
 (set_tile "tdX" TdX)
 (set_tile "tdY" TdY)
 (set_tile "tdX_QC" TdXQC)
 (set_tile "tdY_QC" TdYQC)
)
(DEFUN GETMIAVALUE()
 (setq IsKH (get_tile "Is_KH"))
 (setq Kyhieu (get_tile  "kyhieu"))
 (setq Caodo (get_tile "caodo"))
 (setq TdX (get_tile "tdX"))
 (setq TdY (get_tile "tdY"))
 (setq TdXQC (get_tile "tdX_QC"))
 (setq TdYQC (get_tile "tdY_QC"))
)
(DEFUN MIA_INIT()
 (If (Null IsKH)
(setq IsKH "0")
 )
 (If (Null Kyhieu)
(setq Kyhieu "A")
 )
 (If (Null Caodo)
(setq Caodo "0.00")
 )
 (If (Null TdX)
(setq TdX "0.0")
 )
 (If (Null TdY)
(setq TdY "0.0")
 )
 (If (Null TdXQC)
(setq TdXQC "0.0")
 )
 (If (Null TdYQC)
(setq TdYQC "0.0")
 )
)

(DEFUN ABOUT(/ DCL_ID_ABOUT)
 (setq DCL_ID_ABOUT (load_dialog "MIA.DCL"))
 (if (not(new_dialog "ABOUT" DCL_ID_ABOUT))(exit))  
 (start_list "aboutme")
 (add_list " ")  
 (add_list "  VO KIEN CUONG - Bachelor of IT")
 (add_list "  =====================================================")
 (add_list "  Email : vkcuong_23@yahoo.com")
 (add_list "  Mobile: 0983616182 - 0977352125")
 (add_list "  CAD developer (LISP, DCL, VBA for AutoCad, ObjectARX...)")  
 (add_list "  ")
 (end_list)
 (start_dialog)
 (unload_dialog DCL_ID_ABOUT)
)

(DEFUN DATMIA(/ Pnt)
 (setq Pnt (List (+ (atof tdX) (atof tdXQC)) (+ (atof TdY) (atof tdYQC)) (atof caodo)))
 (If (= IsKH "0")
(Command "-INSERT" "Blk_mia001" Pnt "" "" "" caodo)
(Command "-INSERT" "Blk_mia002" Pnt "" "" "" caodo kyhieu)
 )  
)
(DEFUN CHECKVALUE_TDX()
 (setq temp (get_tile "tdX"))
 (If (Not (IsNumeric temp))
(progn
  (alert "Gia tri nhap vao khong hop le")
  (set_tile "tdX" TdX)
)
 )  
)
(DEFUN CHECKVALUE_TDY()
 (setq temp (get_tile "tdY"))
 (If (Not (IsNumeric temp))
(progn
  (alert "Gia tri nhap vao khong hop le")
  (set_tile "tdY" TdY)
)
 )  
)
(DEFUN CHECKVALUE_CD()
 (setq temp (get_tile "caodo"))
 (If (Not (IsNumeric temp))
(progn
  (alert "Gia tri nhap vao khong hop le")
  (set_tile "caodo" caodo)
)
 )  
)
(DEFUN Is_Chk_KH ()
 (if (= (get_tile "Is_KH") "1")
(mode_tile "kyhieu" 0)
(mode_tile "kyhieu" 1)
 )
)

MIA.DCL

//Chuong trinh ve ki hieu di mia
MIA:dialog{
label="Ve mia - Free Ware";
:boxed_column{
	label="Toa do quy chieu";
	:edit_box{
		label="Toa do X";
		key="tdX_QC";
		edit_width=12;				
		}
	:edit_box{
		label="Toa do Y";
		key="tdY_QC";
		edit_width=12;
		}
	}
:boxed_column{
	label="Diem mia";

	:row	{
		:toggle	{	
			label="Ky hieu";
			key="Is_KH";
			mnemonic="K";
			}
		:edit_box{
			key="kyhieu";
			edit_width=12;				
			}
		}

	:edit_box{
		label="Cao do";
		key="caodo";
		mnemonic="C";
		edit_width=12;
		}
	}
:boxed_column{
	label="Toa do diem mia";
	:edit_box{
		label="Toa do X";
		key="tdX";
		edit_width=12;
		mnemonic="X";
		}
	:edit_box{
		label="Toa do Y";
		key="tdY";
		edit_width=12;
		mnemonic="Y";
		}
	}
:row	{
	:button	{
		label="Import..";
		key="import";
		mnemonic="I";
		is_enabled=false;
		}
	:button	{
		label="Export..";
		key="export";
		mnemonic="E";
		is_enabled=false;
		}
	}
:row	{
	ok_cancel;
	spacer_1;
	spacer_1;
	spacer_1;
	:button	{
		label="Author";			
		key="info";
		mnemonic="A";
		}
	}
}

ABOUT:dialog{
label="About me...";
spacer_1;
:list_box{				
	key="aboutme";
	width=55;
	height=9;
	}
ok_only;
}

 

"Ừ, mình ơi, anh xong rồi, anh vào với mình ngay"

Khổ thế mà sướng thế

 

xin lỗi vndesperados vì đã không nói rõ ràng cụ thể yêu cầu khi nhờ bạn viết hộ chương trình :s_dead: , tiện ích của vndesperados tôi đã tải về và chạy thử rất tốt. Tôi có một vài ý kiến mong desperados giải quyết dùm (trong file dwg upload lên, tôi có ghi các nhận xét này) riêng về phần nhập dữ liệu từ file, tôi cũng xin gửi lên để nhờ bạn hỗ trợ xử lý luôn. Tôi ở Tp.HCM, vndesperados hiện đang công tác tại đâu vậy?

http://www.cadviet.com/upfiles/Mia_tam.dwg

http://www.cadviet.com/upfiles/Data_diemmia.txt

<<

;| LISP  FIELD SUM DIMENSIONS TO A TEXT|;
(defun DXF (code en) (cdr (assoc code (entget en))))
(defun getIDobject (obj)
    (if (vlax-method-applicable-p *util* 'GetObjectIdString)
        (vla-GetObjectIdString *util*...
>>

;| LISP  FIELD SUM DIMENSIONS TO A TEXT|;
(defun DXF (code en) (cdr (assoc code (entget en))))
(defun getIDobject (obj)
    (if (vlax-method-applicable-p *util* 'GetObjectIdString)
        (vla-GetObjectIdString *util* obj :vlax-false)
        (itoa (vla-get-ObjectId obj))
    )
)
(defun c:fdt (/ ApCad    ActDoc   *Model*  *util*       ssdim
                ent_T    Obj_Text tz       po       ent-lst  len      n
                Obj_DIM  str      rowtypes objTab acm prec
               )
    (vl-load-com)
    (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)
    )
    (if (< (substr (getvar "ACADVER") 1 2) "15")
        (progn
            (acet-ui-message
                (strcat
                    "Lisp này ch\U+1EC9 ch\U+1EA1y \U+0111\U+01B0\U+1EE3c t\U+1EEB autoCad 2007 tr\U+1EDF lên."
                    "\nB\U+1EA1n nên nâng c\U+1EA5p autoCad và có menu Express"
                )
                "Warning"
                4144
            )
            (exit)
        )
    )
    (acet-sysvar-set '("cmdecho" 0 "osmode" 0 "dimpost" "."))
    (setq ApCad   (vlax-get-acad-object)
          ActDoc  (vla-get-ActiveDocument ApCad)
          *Model* (vla-get-ModelSpace ActDoc)
          *util*  (vla-get-Utility ActDoc)
    )
    
    (setq acm (vla-GetInterfaceObject
                  ApCad
                  (strcat "AutoCAD.AcCmColor." (substr (getvar 'acadver) 1 2))
              )
    )
    (acet-ui-status "Select DIMENSIONs" "Prompt")
    (setq ssdim (ssget '((0 . "DIMENSION"))))
    (acet-ui-status)
    (while (OR (NOT (setq ent_T
                             (car (entsel "\nPick a Text object for set sum dimensions"))
                    )
               )
               (NOT (eq (DXF 0 ent_T) "TEXT"))
           )
        (prompt "\nPick not right TEXT object, please pick again")
    )
    (setq Obj_Text (vlax-ename->vla-object ent_T))
    (setq tz (dxf 40 ent_T))
    (setq po (getvar "Extmin")
          po (list (- (car po) (* tz 20)) (cadr po) 0.0)
    )
    (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 ssdim
        (progn
            (setq ent-lst (acet-ss-to-list ssdim))
            (setq len (length ent-lst))
            (setq objTab (vla-AddTable *Model*
                                       (vlax-3D-point po)
                                       len
                                       1
                                       (* tz 3.5)
                                       (* tz 8)
                         )
            )
            (vla-put-layer objTab (vla-get-layer Obj_Text))
            
            (vla-setrgb acm 0 0 0)
            (vla-put-truecolor objTab  acm)

            (setq n 0)
            (foreach entD ent-lst
                (setq Obj_DIM (vlax-ename->vla-object entD))
                (if (eq (vla-get-TextOverride Obj_DIM) "")
                    (vla-setText
                        objTab
                        n
                        0
                        (acet-str-format
                            "%<\\AcObjProp Object(%<\\_ObjId %1>%).%3 \\f \"%llu2%pr%2%\">%"
                            (getIDobject Obj_DIM)
                            (itoa prec)
                            "Measurement"
                        )
                    )
                    (vla-setText
                        objTab
                        n
                        0
                        (acet-str-format
                            "%<\\AcObjProp Object(%<\\_ObjId %1>%).%2>%"
                            (getIDobject Obj_DIM)
                            "TextOverride"
                        )
                    )
                )
                (setq n (+ n 1))
            )
            (setq str
                     (acet-str-format
                         "%<\\AcExpr (Table(%<\\_ObjId %1>%).Evaluate(Sum(A1:A%2))) \\f \"%lu2%pr%3\">%"
                         (getIDobject objTab)
                         (itoa len)
                         (itoa prec)
                     )
            )
            (vla-put-TextString Obj_Text str)
        )
    )
    (vla-put-Visible objTab acfalse)
    (ACET-SYSVAR-RESTORE)
    (command "undo" "en")
    (princ "ok")
    (PRINC)
)

Lisp tính tổng các text dimension, tạo field giá trị tổng đưa vào 1 đối tượng TEXT có sẵn. Text dimension có thể bị chỉnh sửa hay không bị chỉnh sửa cũng được cộng. Khi 1 hay nhiều dimension thay đổi thì text tổng cũng thay đổi.

 

Đã test bản vẽ của bạn. Ok nhé ^_^

(defun c:XOM (/ ss ss1 center n i ent lse)
  (c:torient)
  (setq ss (ssget...
>>

 

Đã test bản vẽ của bạn. Ok nhé ^_^

(defun c:XOM (/ ss ss1 center n i ent lse)
  (c:torient)
  (setq ss (ssget "_P"))
  (command "_justifytext" ss "" "MC")
  (setq n 0)
  (repeat (sslength ss)
    (command "_explode" (ssname ss n))
    (setq ss1 (ssget "_P"))
    (setq center nil)
    (setq i 0)
    (while (not center)
      (if (or (eq (cdr (assoc 0 (entget (ssname ss1 i)))) "CIRCLE")
	      (eq (cdr (assoc 0 (entget (ssname ss1 i)))) "ELLIPSE")
	  )
	(setq center (cdr (assoc 10 (entget (ssname ss1 i)))))
      )
      (setq i (1+ i))
    )
    (command "undo" "")
    (setq ent (ssname ss n)
	  ent (entnext ent)
	  lse (entget ent)
    )
    (entmod (subst (cons 11 center) (assoc 11 lse) lse))
    (entupd ent)
    (setq n (1+ n))
  )
  (princ)
)

Cái này thì ok rồi 

Thanks bạn nhiều nhé! 

Bạn có thường sử dụng lệnh torient không? Đôi khi sau khi gõ lệnh torient để sử dụng thì không dùng được(nó bị thoát ra ah, không cho dùng đến bước 2)

Cho nên lsp này kết hợp với lệnh torient mình sợ đôi khi nó cũng bị như trên (mình chỉ nói lên trường hợp mình gặp phải thôi ah)

thaks bạn nhiều lắm !

 

 

Bạn thử Lisp này xem có khá hơn ko :)  chỉ đoán và làm đại chứ ko có bản vẽ để Test :D :

http://4share.vn/f/23161214161b1113/AG.rar

Lsp của bạn chạy tốt nhưng khi quay att block đi 1 góc thì nó bị lệch tâm ah ! 

(cái khó ở đây là sau khi quay att block xong nó phải ở ngay tâm)

<<

Download lisp

Filename: 408470_xom.lsp

Cái này?

(defun C:TD(/ ss lst p1 gr code p2)
 (setq ss (ssget) lst (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))) p1 (getpoint "\nChon diem chuan: "))
 (while (and (setq gr (grread T 4 0) code (car gr) p2 (cadr gr)) (not (= 3 code)) (not (= 25 code)))
  (cond
;----- TH1. Khi rª chuét trªn mµn h×nh.
   ((= 5 code) (mapcar '(lambda(obj) (vla-Move obj (vlax-3d-point p1) (vlax-3d-point p2))) lst) (setq...
>>

Cái này?

(defun C:TD(/ ss lst p1 gr code p2)
 (setq ss (ssget) lst (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))) p1 (getpoint "\nChon diem chuan: "))
 (while (and (setq gr (grread T 4 0) code (car gr) p2 (cadr gr)) (not (= 3 code)) (not (= 25 code)))
  (cond
;----- TH1. Khi rª chuét trªn mµn h×nh.
   ((= 5 code) (mapcar '(lambda(obj) (vla-Move obj (vlax-3d-point p1) (vlax-3d-point p2))) lst) (setq p1 p2))
;----- TH2. Khi pick point hoÆc chuét ph¶i.
   ((or (= 3 code) (= 25 code)) (mapcar '(lambda(obj) (vla-Move obj (vlax-3d-point p1) (vlax-3d-point p2))) lst))))
 (princ))

Lisp đã chỉnh sửa: tạo field của sum dimensions vào đối tượng text có sẵn, không còn tạo "đối tượng trung gian" để cộng trừ nhân chia, chạy thử trên autoCad 2014 thấy OK. Chấp nhận text dim đã chỉnh sửa. Còn sum đối tượng text số, lengLine, area tạo field đưa vào text, hẹn một ngày khác.

Cảm ơn Quocmanh04tt đã gợi ý.

>>

Lisp đã chỉnh sửa: tạo field của sum dimensions vào đối tượng text có sẵn, không còn tạo "đối tượng trung gian" để cộng trừ nhân chia, chạy thử trên autoCad 2014 thấy OK. Chấp nhận text dim đã chỉnh sửa. Còn sum đối tượng text số, lengLine, area tạo field đưa vào text, hẹn một ngày khác.

Cảm ơn Quocmanh04tt đã gợi ý.

;| LISP  FIELD SUM DIMENSIONS TO A TEXT
          by TrânThiêp 04/2020 |;
(defun getIDobject (obj)
    (if (vlax-method-applicable-p *util* 'GetObjectIdString)
        (vla-GetObjectIdString *util* obj :vlax-false)
        (itoa (vla-get-ObjectId obj))
    )
)
(defun c:fdt2 (/ ApCad ActDoc  *util* ssdim ent_T Obj_Text ent-lst len
                 Obj_DIM objDim_lst ID_Dim_lst str prec)
    (vl-load-com)
    (command "undo" "be")
    (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 ApCad  (vlax-get-acad-object)
          ActDoc (vla-get-ActiveDocument ApCad)
          *util* (vla-get-Utility ActDoc)
    )
    (acet-ui-status "Select DIMENSIONs" "Prompt")
    (setq ssdim (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 (vlax-ename->vla-object ent_T))
    (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 ssdim
        (progn
            (setq objDim_lst (mapcar 'vlax-ename->vla-object
                                     (acet-ss-to-list ssdim)
                             )
            )
            (setq ID_Dim_lst (mapcar '(lambda (x) (getIDobject x)) objDim_lst))
            (setq str "%<\\AcExpr (")
            (mapcar '(lambda (ob id)
                         (if (distof (vla-get-TextOverride ob))
                             (Setq str
                                      (strcat
                                          str
                                          (acet-str-format
                                              "%<\\AcObjProp Object(%<\\_ObjId %1>%).%2>%+"
                                              id
                                              "TextOverride"
                                          )
                                      )
                             )
                             (Setq str
                                      (strcat
                                          str
                                          (acet-str-format
                                              "%<\\AcObjProp Object(%<\\_ObjId %1>%).%3 \\f \"%lu2%pr%2\">%+"
                                              id
                                              (itoa prec)
                                              "Measurement"
                                          )
                                      )
                             )
                         )

                     )
                    objDim_lst
                    ID_Dim_lst
            )
            (setq str (acet-str-format "%1) \\f \"%lu2%pr%2\">%"
                                       (vl-string-right-trim "+" str)
                                       (itoa prec)
                      )
            )
            (vla-put-TextString Obj_Text str)
        )
    )
    (ACET-SYSVAR-RESTORE)
    (command "undo" "en")
    (princ "\nOK")
    (PRINC)
)

Của bạn đây! Áp dụng với Polyline. 

(defun C:XDTHPL	(/ LTSPLINE SSPLINE X) ;;;XDTHPL
  (defun *error* (msg)
    (if	Olmode
      (setvar 'osmode Olmode)
    )
    (if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (command "undo" "begin")
  (setq Olmode (getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (setq	Gocchenh
	 (LM:GetXWithDefault
	 ...
>>

Của bạn đây! Áp dụng với Polyline. 

(defun C:XDTHPL	(/ LTSPLINE SSPLINE X) ;;;XDTHPL
  (defun *error* (msg)
    (if	Olmode
      (setvar 'osmode Olmode)
    )
    (if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (command "undo" "begin")
  (setq Olmode (getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (setq	Gocchenh
	 (LM:GetXWithDefault
	   getreal
	   "\nNh\U+1EADp g\U+00F3c ch\U+00EAnh v\U+1EDBi 180 \U+0111\U+1ED9 (1,2,3...10 \U+0111\U+1ED9) \U+0111\U+01B0\U+1EE3c coi l\U+00E0 th\U+1EB3ng h\U+00E0ng:  "
	   '*Gocchenh0*
	   0.0
	 )
  )
  (setq ssPline (ssget '((0 . "*POLYLINE"))))
  (if ssPline
    (progn
      (setq LtsPline (LM:ss->ent ssPline))
      (mapcar '(lambda (x) (XDTHPL x Gocchenh)) LtsPline)
    )
  )
  (setvar "OSMODE" Olmode)
  (command "undo" "end")
  (princ)
)

(defun XDTHPL (pl delta180 / ANG1 ANG2 BUL1 BUL2 BULST CERALST1	CERALST2 ELST ELST1 ELST2 ELST3	I K M N	NBUL OBUL PLOB PLST PLST1 RA REC1 VTT1 VTT2)
  (setq	plst  (acet-geom-vertex-list pl)
	plob  (vlax-ename->vla-object pl)
	elst  (entget pl)
	bulst (list)
	plst1 plst
	elst1 (list)
	elst2 (list)
	elst3 (list)
  )
  (foreach a elst
    (if	(= (car a) 42)
      (setq bulst (append bulst (list (cdr a))))
    )
  )
  (setq	k (vl-position (cons 10 (reverse (cdr (reverse (car plst))))) elst)
	i 0
  )
  (while (< i k)
    (setq elst1	(append elst1 (list (nth i elst)))
	  i	(1+ i)
    )
  )
  (foreach vrt (if (= (cdr (assoc 70 elst)) 1)
		 (reverse (cdr (reverse plst)))
		 plst
	       )
    (setq k (vl-position (cons 10 (reverse (cdr (reverse vrt)))) elst))
    (setq elst2	(append	elst2
			(list
			  (list (nth k elst) (nth (+ k 1) elst) (nth (+ k 2) elst) (nth (+ k 3) elst))
			)
		)
    )
  )
  (setq m (cdr (assoc 90 elst)))
  (foreach vrt plst
    (setq i (vl-position vrt plst))
    (if	(> i 0)
      (progn
	(setq vtt1 (vlax-curve-getFirstDeriv
		     plob
		     (vlax-curve-getParamAtPoint plob (nth (1- i) plst))
		   )
	)
	(setq vtt2 (vlax-curve-getFirstDeriv plob (vlax-curve-getParamAtPoint plob vrt)))
	(setq bul1 (nth (1- i) bulst)
	      bul2 (nth i bulst)
	)
	(setq ang1 (angle '(0 0 0) vtt1)
	      ang2 (angle '(0 0 0) vtt2)
	)
	(if (and (= bul1 0.0)
		 (= bul2 0.0)
		 (or (equal ang1 ang2 (* pi (/ delta180 180.0)))
		     (equal (* 2 pi) (abs (- ang1 ang2)) (* pi (/ delta180 180.0)))
		 )
		 (nth (1+ i) plst)
	    )
	  (setq	plst1 (vl-remove vrt plst1)
		m     (1- m)
	  )
	)

	(if (and (/= bul2 0.0) (/= bul1 0.0))
	  (progn
	    (setq ceralst1 (bulgecenter bul1 (nth (1- i) plst) (nth i plst))
		  ceralst2 (bulgecenter bul2 (nth i plst) (nth (1+ i) plst))
	    )
	    (if	(and (equal (car ceralst1) (car ceralst2) 1e-8)
		     (equal (last Ceralst1) (last ceralst2) 1e-8)
		)
	      (setq plst1 (vl-remove vrt plst1)
		    m	  (1- m)
	      )
	    )
	  )
	)
      )
    )
  )
  (if (= (cdr (assoc 70 elst)) 1)
    (setq plst1 (reverse (cdr (reverse plst1))))
  )
  (foreach vrt plst1
    (foreach rec elst2
      (if (equal (cdar rec) (reverse (cdr (reverse vrt))) 1e-8)
	(setq elst3 (append elst3 (list rec)))
      )
    )
  )
  (foreach rec elst3
    (if	(/= (setq obul (cdr (last rec))) 0.0)
      (progn
	(setq k	   (vl-position rec elst3)
	      n	   (vl-position obul bulst)
	      ra   (car (bulgecenter obul (nth n plst) (nth (1+ n) plst)))
	      nbul (bulge ra (nth k plst1) (nth (1+ k) plst1))
	)
	(if (< obul 0)
	  (setq nbul (- 0 nbul))
	)
	(setq rec1  (subst (cons 42 nbul) (assoc 42 rec) rec)
	      elst3 (subst rec1 rec elst3)
	)
      )
    )
  )
  (foreach rec elst3
    (setq elst1 (append elst1 rec))
  )
  (setq elst (append elst1 (list (cons 210 '(0.0 0.0 1.0)))))
  (setq elst (subst (cons 90 m) (assoc 90 elst) elst))
  (entmod elst)
)
(defun LM:ss->ent (ss / i l)
  (if ss
    (repeat (setq i (sslength ss))
      (setq l (cons (ssname ss (setq i (1- i))) l))
    )
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun BulgeCenter (bulge p1 p2 / delta chord radius center)
  (setq	delta	(* (atan bulge) 4)
	chord	(distance p1 p2)
	radius	(/ chord (sin (/ delta 2)) 2)
	center	(polar p1 (+ (angle p1 p2) (/ (- pi delta) 2)) radius)
	Ceralst	(list center radius)
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun bulge (cen p1 p2 / anp)
  (setq	anp (atan (/ (distance p1 p2) 2 (distance cen (midpt p1 p2))))
	bul (/ (sin (/ anp 2)) (cos (/ anp 2)))
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun midpt (p1 p2)
  (setq pt (mapcar '(lambda (x y) (/ (+ x y) 2)) p1 p2))
)

(defun LM:GetXWithDefault (_function _prompt _symbol _default / _toString)
  ;; © Lee Mac 2010

  (setq	_toString
	 (lambda (x)
	   (cond
	     ((eq getangle _function) (angtos x))
	     ((eq 'REAL (type x)) (rtos x))
	     ((eq 'INT (type x)) (itoa x))
	     (x)
	   )
	 )
  )

  (set _symbol
       (
	(lambda	(input)
	  (if (or (not input) (eq "" input))
	    (eval _symbol)
	    input
	  )
	)
	 (_function (strcat _prompt
			    "<"
			    (_toString (set _symbol
					    (cond ((eval _symbol))
						  (_default)
					    )
				       )
			    )
			    "> : "
		    )
	 )
       )
  )
)

Mở rộng thêm lisp fdt1: tạo field của tổng giá trị dimensions vào đối tượng text có sẵn. Thiệp tạo thêm 4 lisp:

fdt2: tạo field tổng giá trị số của text, mtext số;

fdt3: tạo field tổng giá trị length của các đối tượng có thuộc tính length;

fdt4: tạo field tổng giá trị diện tích của các đối tượng có thuộc tính Area;

fdt5: tạo field tổng giá trị chu vi...

Mở rộng thêm lisp fdt1: tạo field của tổng giá trị dimensions vào đối tượng text có sẵn. Thiệp tạo thêm 4 lisp:

fdt2: tạo field tổng giá trị số của text, mtext số;

fdt3: tạo field tổng giá trị length của các đối tượng có thuộc tính length;

fdt4: tạo field tổng giá trị diện tích của các đối tượng có thuộc tính Area;

fdt5: tạo field tổng giá trị chu vi đường tròn của các đối tượng đường tròn.

(tuy nhiên fdt2 thật sự Thiep không vừa ý lắm vì nó tạo ra tới độ chính xác 6 con số lẻ của số thập phân. ví dụ số tổng 910.1 nó sẽ ra 910.100000, nhờ ae phân tích tại sao nó bị khiếm khuyết này)

Có tới hơn 400 dòng mã của 5 lisp.

;;; 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                    
;;;                                                       
(defun DXF (code en) (cdr (assoc code (entget en))))
;;;===========================================================================1: sum DIMENSIONs =========
(defun c:fdt1 (/  ss ent_T Obj_Text str prec Lobj_dim ID_Dim_lst field_lst)
    (vl-load-com)
    (command "undo" "be")
    (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))
    (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 (vlax-ename->vla-object ent_T))
    (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 ss
        (progn
            (mapcar
                '(lambda (x)
                     (setq Lobj_dim (CONS (vlax-ename->vla-object x) Lobj_dim))
                 )
                (acet-ss-to-list ss)
            )
            (setq ID_Dim_lst (mapcar 'vla-get-objectid Lobj_dim))
            (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)
                                      "Measurement"
                                  )
                              )
                          )
                         Lobj_dim
                         ID_Dim_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 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)
    (vl-load-com)
    (command "undo" "be")
    (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))
    (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))
                      )
            )
            (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)
    (vl-load-com)
    (command "undo" "be")
    (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))
    (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)
    (vl-load-com)
    (command "undo" "be")
    (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))
    (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)
    (vl-load-com)
    (command "undo" "be")
    (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))
    (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)
)

910.1 thì nó ra 910.100000; Nhờ các ae chỉ ra chỗ còn khiếm khuyết này)

Bạn chạy thử LISP này :

(defun c:BlkQty (/ blk_name ent i lst_blk pt row ss tblobj x y)
 (if (setq ss (ssget (list (cons 0 "INSERT"))))
   (progn
     (vl-load-com)
     (setq i -1)
...
>>

Bạn chạy thử LISP này :

(defun c:BlkQty (/ blk_name ent i lst_blk pt row ss tblobj x y)
 (if (setq ss (ssget (list (cons 0 "INSERT"))))
   (progn
     (vl-load-com)
     (setq i -1)
     (while (setq ent (ssname ss (setq i (1+ i))))
(setq blk_name (vla-get-name (vlax-Ename->Vla-Object ent)))
(if (not (assoc blk_name lst_blk))
  (setq lst_blk (cons (cons blk_name 1) lst_blk))
  (setq lst_blk (subst (cons blk_name (1+ (cdr (assoc blk_name lst_blk))))
		       (assoc blk_name lst_blk) lst_blk)))	    )
     (setq lst_blk (vl-sort lst_blk '(lambda (x y) (< (car x) (car y)) ) )
    pt (getpoint "\nDiem dat Bang :")
    TblObj (vla-addtable
	     (vla-get-modelspace (vla-get-ActiveDocument (vlax-get-Acad-Object)))
	     (vlax-3d-point pt) (+ (length lst_blk) 2) 4 375 2000))
     (vla-SetColumnWidth TblObj 0 1000)
     (vla-SetColumnWidth TblObj 1 3000)
     (vla-put-vertcellmargin TblObj 50)
     (mapcar '(lambda (x y)(vla-setTextHeight TblObj x y))
      (list acTitleRow acHeaderRow acDataRow)
      (list 250 250 175))
     (mapcar '(lambda (x)(vla-setAlignment TblObj x 8))
      (list acTitleRow acHeaderRow acDataRow))
     (vla-MergeCells TblObj 0 0 0 2)
     (vla-setText TblObj 0 0 "Bang thong ke")
     (vla-setText TblObj 1 0 "STT")
     (vla-setText TblObj 1 1 "Ten")
     (vla-setText TblObj 1 2 "Don vi")
     (vla-setText TblObj 1 3 "So luong")
     (setq row 2 i 1)
     (foreach pt lst_blk
(vla-setText TblObj row 0 (itoa i))
(vla-setText TblObj row 1 (car pt))
(vla-setText TblObj row 2 "cai")
(vla-setText TblObj row 3 (itoa (cdr pt)))
(setq row (1+ row) i (1+ i))	)	)
     (vlax-release-object TblObj)      )
 (princ))

Cảm ơn gia_bach đã quan tâm.

Nhưng nhờ bạn xem lại giúp mình đã xảy ra lỗi không sử dụng được

 

Command: BlkQty

 

Select objects: Specify opposite corner: 4 found

 

Select objects:

 

Diem dat Bang :; error: Automation Error. Invalid input

<<

Lisp này, như gộp chung cả 2 lệnh Join và Overkill.

Trong lisp có 2 biến fuz1 và fuz2:

Fuz1 là dung sai khoảng cách rời rạc để nối các đối tượng Line, Arc, lwpolyline lại với nhau, trong lisp Thiệp cho = "0.0"

Fuz2 là sai số để so sánh 1 node (p2) nằm ngoài đoạn thẳng (p1-p3) với 1 góc (p2 p1 p3) rất nhỏ nào đó. Trong lisp, Thiệp cho Fuz2=0.003

Trong lệnh Overkill cũng có dung...

Lisp này, như gộp chung cả 2 lệnh Join và Overkill.

Trong lisp có 2 biến fuz1 và fuz2:

Fuz1 là dung sai khoảng cách rời rạc để nối các đối tượng Line, Arc, lwpolyline lại với nhau, trong lisp Thiệp cho = "0.0"

Fuz2 là sai số để so sánh 1 node (p2) nằm ngoài đoạn thẳng (p1-p3) với 1 góc (p2 p1 p3) rất nhỏ nào đó. Trong lisp, Thiệp cho Fuz2=0.003

Trong lệnh Overkill cũng có dung sai, nhưng tôi thử nhiều lần với 1 góc Grad rất nhỏ 1/100.000.000 mà nó cũng không nhận ra. Ví dụ: 1 điểm p2 ở khoảng giữa đoạn thẳng p1-p3 dài 200km nằm chênh với đoạn thẳng p1-p3 này là 1mm, lệnh Overkill không nhận ra để kill nó đi. Lisp Thiệp viết làm được điều này với dung sai fuz2.

(defun DXF (code en) (cdr (assoc code (entget en))))
(defun c:jdk (/       ss1     ent     obj     polst1  polst2  ss1     ss2
              v1      v2      scalar_prod     ent-lst lst_bul bul1    bul2
              n       po1     po2     po3
             )
    (command "undo" "be")
    (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 ss1 (ssget '((0 . "LINE,*POLYLINE,ARC"))))
    (if ss1
        (progn
            (setq Fuz1 "0.0")
            (if (> (sslength ss1) 1)
                (progn
                    (mapcar '(lambda (x) (setq lst (cons (dxf 0 x) lst)))
                            (setq
                                ent-lst (vl-remove-if 'listp
                                                      (mapcar 'cadr (ssnamex ss1))
                                        )
                            )
                    )
                    (setq ss1 (ssadd))
                    (foreach ent ent-lst
                        (if (or (eq (dxf 0 ent) "ARC") (eq (dxf 0 ent) "LINE"))
                            (progn (command "_pedit" ent "" "")
                                   (setq ss1 (ssadd (entlast) ss1))
                            )
                            (setq ss1 (ssadd ent ss1))
                        )
                    )
                    (command "_.pedit" "M" ss1 "" "J" Fuz1 "")
                    (setq ent (entlast))
                )
                (setq ent (ssname ss1 0))
            )
            (setq fuz2 3e-3)
            (setq obj (vlax-ename->vla-object ent))
            (setq lst_bul nil)
            (setq polst1 (acet-geom-vertex-list ent))
            (setq n 0)
            (foreach po polst1
                (if (/= (setq bul (vla-GetBulge obj n)) 0.0)
                    (setq lst_bul (append lst_bul (List (cons (trans po 1 0) (list bul)))))
                )
                (setq n (+ n 1))
            )
            
            (setq polst1 (acet-list-remove-duplicates  polst1  nil))
            (setq polst2 polst1)
            (setq n 0)
            (while (<= n (- (length polst1) 2))
                (setq po1 (trans (nth n polst1) 1 0)
                      po2 (nth (+ n 1) polst1)
                      po3 (nth (+ n 2) polst1)
                )
                (if po2 (setq po2 (trans (nth (+ n 1) polst1) 1 0)))
                (if po3 (setq po3 (trans (nth (+ n 2) polst1) 1 0)))
                (setq bul1 (vla-GetBulge obj (vlax-curve-getParamAtpoint obj po1))
                      bul2 (vla-GetBulge obj (vlax-curve-getParamAtpoint obj po2))
                )
                
                (cond ((and (/= bul1 0.0) (= bul2 0.0) po3) (setq n (+ n 1)))
                      ((and (/= bul2 0.0) po3) (setq n (+ n 2)))
                      ((and (= bul1 0.0) (= bul2 0.0) po3)
                       (setq v1 (mapcar '- po1 po2)
                             v2 (mapcar '- po3 po2)
                       )
                       (setq scalar_prod (- (* (car v1) (cadr v2))
                                            (* (cadr v1) (car v2))
                                         )
                       )
                       (if (equal scalar_prod 0 fuz2) ;_
                           (setq polst2 (vl-remove po2 polst2))
                       )
                       (setq n (+ n 1))
                      )
                      (T (setq n (+ n 1)))
                )
            )
            (acet-lwpline-make (list polst2))
            (entdel ent)
            (setq obj (vlax-ename->vla-object (entlast)))
            (mapcar '(lambda (lst)
                         (vla-setBulge obj
                                       (vlax-curve-getParamAtpoint obj (car lst))
                                       (cadr lst)
                         )
                     )
                    lst_bul
            )
        ) ;_
    ) ;_
    (ACET-SYSVAR-RESTORE)
    (command "undo" "en")
    (princ "\nOK")
    (princ)
)

tên lệnh là JPT. Lệnh sẽ yêu cầu bạn nhập 2 lần. Lần thứ nhất là select tập các đối tượng text cần nối với nhau. Lần thứ 2 là pick vào đối tượng text...

>>

tên lệnh là JPT. Lệnh sẽ yêu cầu bạn nhập 2 lần. Lần thứ nhất là select tập các đối tượng text cần nối với nhau. Lần thứ 2 là pick vào đối tượng text đầu tiên.

(defun c:jpt (/	ssp entbd index	sop tapdiemxet entdt p diemht diemnoi
      tapkq)

 (defun hoanh_newerror	(msg)
   (if	(and (/= msg "Function cancelled")
     (/= msg "quit / exit abort")
)
     (princ (strcat "\n" msg))
   )
   (done)
 )

 (defun init ()
   (setq
     HOANH_CMD	     (getvar "CMDECHO")
     HOANH_OLDERROR *error*
     *error*	     hoanh_newerror

   )
   (setvar "CMDECHO" 0)
   (command ".undo" "BE")
 )

 (defun done ()
   (command ".redraw")
   (command ".undo" "E")
   (if	HOANH_CMD
     (setvar "CMDECHO" HOANH_CMD)
   )
   (if	HOANH_OLDERROR
     (setq *error* HOANH_OLDERROR)
   )
   (princ)
 )

 (defun luuos ()
   (setq
     HOANH_OSMODE   (getvar "OSMODE")
     HOANH_AUTOSNAP (getvar "AUTOSNAP")
   )
 )
 (defun traos ()
   (if	HOANH_OSMODE
     (setvar "OSMODE" HOANH_OSMODE)
   )
   (if	HOANH_AUTOSNAP
     (setvar "AUTOSNAP" HOANH_AUTOSNAP)
   )
 )

 (defun timgannhat (p tapp / pp kq dmin)
   (setq kq nil)
   (foreach pp	tapp
     (if (or (not dmin)
      (> dmin (distance p pp))
  )
(setq dmin (distance p pp)
      kq   pp
)
     )
   )
   kq
 )
 (init)
 (princ "\nLisp noi text - © 2007, CADViet.com")
 (princ "\nHay chon text")
 (setq
   ssp	       (ssget '((0 . "TEXT")))
   entbd      (car (entsel "\nChi dinh text bat dau:"))
   index      0
   sop	       (sslength ssp)
   tapdiemxet nil
 )
 (repeat sop
   (setq entdt	     (ssname ssp index)
  index	     (1+ index)
  p	     (cdr (assoc 10 (entget entdt)))
  tapdiemxet (append tapdiemxet (list p))
   )
 )
 (setq
   diemht     (cdr (assoc 10 (entget entbd)))
   tapdiemxet (vl-remove diemht tapdiemxet)
   tapkq      (list diemht)
   diemnoi    (timgannhat diemht tapdiemxet)
 )
 (while diemnoi
   (setq
     tapdiemxet (vl-remove diemnoi tapdiemxet)
     tapkq	 (append tapkq (list diemnoi))
     diemht	 diemnoi
     diemnoi	 (timgannhat diemht tapdiemxet)
   )
 )
 (luuos)
 (setvar "osmode" 0)
 (command ".3dpoly")
 (foreach p tapkq
   (command p)
 )
 (command "")
 (traos)
 (done)
)
(princ "\nJPT - Free lisp from www.cadviet.com")
(princ)

 

cảm ơn anh Hoành

<<

Mình làm thử đoạn lisp này, áp dụng cho các đối tượng liền nhau ( cách nhau 1 khoảng 0.1) và dùng cho 1 cụm các đối tượng đó

(defun C:jp ( / o)
  
>>

Mình làm thử đoạn lisp này, áp dụng cho các đối tượng liền nhau ( cách nhau 1 khoảng 0.1) và dùng cho 1 cụm các đối tượng đó

(defun C:jp ( / o)
  (setq o (getvar 'PEDITACCEPT))
  (setvar 'PEDITACCEPT 1)
  (vl-cmdf "PEDIT" "M" (ssget) "" "J" 0.1 "")
  (vl-cmdf "-OVERKILL"  (entlast) "" "O" 0.1 "D")
  (setvar 'PEDITACCEPT o)
  )

32 phút trước, thanhduan2407 đã nói:

Viết lisp tạo block động...

>>

32 phút trước, thanhduan2407 đã nói:

Viết lisp tạo block động khó không anh? Em nghĩ code sẽ rất dài. 
Thường thì em tạo block động trên Cad thôi.

 

Hình như không tạo được. Chỉ tạo sẵn rồi copy lại code file dxf chèn vào lisp.

Em viết cái lisp vẽ cầu dài quá làm nản ai muôn học lisp luôn.

Anh viết đơn giản tí.

(defun c:vc(/ p1 p2 p3 p1+ p2+ ang ang1 old d)
  (setq p1 (getpoint "Nhap diem 1:")
	p2 (getpoint "Nhap diem 2:")
	p3 (getpoint "Nhap diem 3:")
	old (getvar 'osmode)
	ang (angle p1 p2)
	d  (* (distance p3 p1) (sin (- (angle p1 p3) ang)))
	p1+ (polar p1 (+ ang (/ pi 2)) d)
	p2+ (polar p2 (+ ang (/ pi 2)) d)
	ang2 (if (< d 0) (/ pi 4) (/ pi -4)))
  (setvar 'osmode 0)
  (command "_pline" (polar p1 (+ ang (* 3 ang2)) 2) p1 p2 (polar p2 (+ ang ang2)2) "")
  (command "_pline" (polar p1+ (- ang (* 3 ang2)) 2) p1+ p2+ (polar p2+ (- ang ang2) 2) "")
  (setvar 'osmode old)
  (princ))

 

<<

22 giờ trước, nhoclangbat đã nói:

- hihi em cũng làm bên trắc...

>>

22 giờ trước, nhoclangbat đã nói:

- hihi em cũng làm bên trắc địa bài toán đó em biết mà ^^, em chỉ lăn tăn vụ cạnh, mò lại sách nghiệm ra rồi

Mình thấy cao đường ngắm và chỉ dưới đều là 4 chử số không có phẩy. Khi trừ ra thì nó cũng là 4 chử số. @nhoclangbat đoán xem có chia cho 100 hay 1000 gì không cho nó ra số có dấu phẩy mới đúng chứ nhỉ!

(defun STR-NUMBER (str / LST LST1 LST2)
(setq lst (vl-string->list str))
(SETQ LST1 (LIST))
(while (setq X (car LST))
(setq LST (CDR LST))
(SETQ LST2 (LIST))
(IF (AND (>= X 48) (<= x 57)) (PROGN (SETQ LST2 (APPEND LST2 (LIST X)))
(WHILE (AND (>= (car LST) 48) (<= (car LST) 57))
(SETQ LST2 (APPEND LST2 (LIST (car LST))))
(SETQ LST (CDR LST))
)
(SETQ LST1 (APPEND LST1 (LIST LST2)))
))
)
(MAPCAR '(LAMBDA (X) (vl-list->string X)) LST1)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Tao file chua noi dung list  
;;;Cu phap su dung (duy:taotxt<list filename listtc) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:taotxt<list (filename listtc / filename tapchon dtc)
(setq ndd (open filename "w"))
(foreach dtc listtc
(write-line dtc ndd)
)
(close ndd)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Tao list chua noi dung file
;;;Cu phap su dung (duy:taolist<f tenfile) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:taolist<f (filename / filename)
(setq lkq nil)
(setq ndd (open filename "r"))
(while 
(/= nil (setq ddd (read-line ndd)))
(setq lkq (append lkq (list ddd)))
)
(close ndd)
lkq)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:ftp ()
(cond
((= toadomay nil) (setq toadomay (list 0 0 0)) )
)

(setq filedo (getfiled "Chon file so lieu" "" "txt" 0))
(setq ndfiledo (duy:taolist<f filedo))

(foreach nddongdo ndfiledo
(setq tachnd (STR-NUMBER nddongdo))
(setq soluong (length tachnd))

(cond
((= soluong 6) (gandiemgoc))
((= soluong 4) (gandiemle))
)

)

(princ)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun gandiemgoc ()
(setq ttd 0)
(setq tm (nth 0 tachnd))
(setq sd (atof(nth 1 tachnd)))
(setq xg (atof(nth 2 tachnd)))
(setq yg (atof(nth 3 tachnd)))
(setq ag (atof(nth 4 tachnd)))
(setq zg (atof (nth 5 tachnd)))
(setq ddm (list xg yg))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun gandiemle ()
(setq ttd (+ ttd 1))
(setq do (nth 0 tachnd))
(setq phut (nth 1 tachnd))
(setq chigiua (atof (nth 2 tachnd)))
(setq chiduoi (atof (nth 3 tachnd)))
(setq gocb (strcat do "d" phut "'" "00" "\""))
(setq gocb (angtof gocb 1))
(setq daib (* (- chigiua chiduoi) 200))
(setq caob (- zg chigiua))
(setq db (polar ddm gocb daib)) 
(setq dbz (list (car db) (cadr db) caob))
(setq tendiem (strcat "tr" tm "d" (rtos ttd 2 0)))
(entmake (list (cons 0 "TEXT")(cons 10 db)(cons 11 db)(cons 40 150)(cons 50 0)(cons 72 0)(cons 1 (rtos caob 2 2))(cons 7 (getvar "TEXTSTYLE"))(cons 8 "layrekhac_text")(cons 62 256))) 
(entmake (list (cons 0 "POINT")(cons 10 dbz)(cons 8 "layrekhac_point")(cons 62 256))) 
(entmake (list (cons 0 "TEXT")(cons 10 db)(cons 11 db)(cons 40 150)(cons 50 0)(cons 72 2)(cons 1 tendiem)(cons 7 (getvar "TEXTSTYLE"))(cons 8 "layrekhac_stt")(cons 62 256))) 
)

Hòm hòm rồi. Không biết đúng sai thế nào. Tên lệnh FTP.

Gỏ lệnh, enter, chọn file số liệu là nó bắn point và text lên cad luôn. đaing để cao text là 150.

<<

2 giờ trước, nguyen son hai đã nói:

không phải lisp này bác...

>>

2 giờ trước, nguyen son hai đã nói:

không phải lisp này bác ơi. cái này là tính diện tích các vùng kín riêng biệt, ý em là trên trắc ngang có rất nhiều điểm, muốn tính diện tích tạo bở 1 vài điểm bất kỳ, ta bấm giống lệnh aa của acad ấy ạ. nhưng sau đó  có mục ghi ra nền chứ không phải xem ở    f2 ạ

Thử lisp này

(defun c:test2()
  (command "area")
  (while (not (zerop (getvar 'cmdactive)))
    (command pause))
  (command "_text" (getpoint "diem dat text") "" "" (rtos (getvar 'area)) "")
  (princ))

 

<<