Sửa một cách nhanh nhất đây. Dư hay thừa gì  trong code thì kệ, kết quả như ý bạn là được.

;;  DimPolySeq.lsp 
;;  To dimension the lengths of all segments of a Polyline on the Inboard or Outboard
;;    side, adding a sequencing number and colon as prefix.  For self-intersecting or open
;;    Polyline without a clear "inside" and "outside," will determine a side -- if not...
>>

Sửa một cách nhanh nhất đây. Dư hay thừa gì  trong code thì kệ, kết quả như ý bạn là được.

;;  DimPolySeq.lsp 
;;  To dimension the lengths of all segments of a Polyline on the Inboard or Outboard
;;    side, adding a sequencing number and colon as prefix.  For self-intersecting or open
;;    Polyline without a clear "inside" and "outside," will determine a side -- if not as
;;    desired, undo and run other command.
;;  Dimensions along arc segments will be angular Dimensions, showing length of arc
;;    as text override, not included angle native to angular Dimensions.  They will not
;;    update if Polyline is stretched, as Dimensions along line segments will.
;;  Uses current Dimension and Units settings; dimension line location distance from
;;    Polyline segment = 1.5 x dimension text height for stacked fractions to clear .
;;  Sequencing number + colon & space are in text override; number is stored in non-
;;    localized variable *DPseq.  Remembers that, and continues sequence on subsequent
;;    usage within same editing session of same drawing, whether using all DPI or all
;;    DPO or a mixture of the two commands.
;;  Accepts LW and 2D "heavy" Polylines, but not 3D Polylines or meshes.
;;  Kent Cooper, 29 August 2016

(vl-load-com)

(defun DP (side / *error* clay cmde styht plsel pl cw inc pt1 pt2 pt3 pt4)

  (defun *error* (errmsg)
    (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
      (princ (strcat "\nError: " errmsg))
    ); if
    (setvar 'clayer clay)
    (setvar 'osmode osm)
    (command-s "_.undo" "_end")
    (setvar 'cmdecho cmde)
    (princ)
  ); defun -- *error*

  (setq clay (getvar 'clayer) osm (getvar 'osmode) cmde (getvar 'cmdecho))
  (setvar 'cmdecho 0)
  (setvar 'osmode 0)
  (if (not *DPseq) (setq *DPseq 1))
  (command
    "_.undo" "_begin"
    "_.layer" "_make" "A-ANNO-DIMS" "_color" 2 "" "" ;; <---EDIT if desired
  ); command
  (setq styht (cdr (assoc 40 (tblsearch "style" (getvar 'dimtxsty))))); height of text style in current dimension style
  (if (= styht 0.0) (setq styht (* (getvar 'dimtxt) (getvar 'dimscale)))); if above is non-fixed-height
  (while
    (not
      (and
        (setq plsel (entsel "\nSelect Polyline: "))
        (wcmatch (cdr (assoc 0 (entget (car plsel)))) "*POLYLINE")
        (= (logand (cdr (assoc 70 (entget (car plsel)))) 88) 0)
          ;; not 3D or mesh 
      ); and
    ); not
    (prompt "\nNothing selected, or not a LW or 2D Polyline.")
  ); while
  (setq pl (vlax-ename->vla-object (car plsel)))
  (vla-offset pl styht); temporary
  (setq cw (< (vla-get-area (vlax-ename->vla-object (entlast))) (vla-get-area pl)))
    ;; clockwise for closed or clearly inside/outside open; may not give
    ;; desired result for open without obvious inside/outside
  (entdel (entlast))
  (repeat (setq inc (fix (vlax-curve-getEndParam pl)))
    (setq
      pt1 (vlax-curve-getPointAtParam pl inc)
      pt2 (vlax-curve-getPointAtParam pl (- inc 0.5)); segment midpoint
      pt3 (vlax-curve-getPointAtParam pl (1- inc))
    ); setq
    (if (equal (angle pt1 pt2) (angle pt2 pt3) 1e-8); line segment
      (command ; then
        "_.dimaligned" pt1 pt3
        "_text" "<>"
      ); 
      (command ; else 
        "_.dimangular" ""
        (inters ; arc center
          (setq pt4 (mapcar '/ (mapcar '+ pt1 pt2) '(2 2 2)))
          (polar pt4 (+ (angle pt1 pt2) (/ pi 2)) 1)
          (setq pt4 (mapcar '/ (mapcar '+ pt2 pt3) '(2 2 2)))
          (polar pt4 (+ (angle pt2 pt3) (/ pi 2)) 1)
          nil
        ); inters
        pt1 pt3
        "_text"
          (strcat
            (itoa *DPseq) ": "
            (rtos (abs (- (vlax-curve-getDistAtParam pl inc) (vlax-curve-getDistAtParam pl (1- inc)))) 2 0)
            "mm"
            ;; 
          ); strcat
      ); command 
    ); if
    (command ; complete Dimension: dimension line location
      (polar
        pt2
        (apply
          (if (or (and cw (= side "in")) (and (not cw) (= side "out"))) '- '+)
          (list
            (angle '(0 0 0) (vlax-curve-getFirstDeriv pl (- inc 0.5)))
            (/ pi 2)
          ); list
        ); apply
        (* styht 1.5)
          ;; 
      ); polar
    ); command
    (setq
      inc (1- inc)
      *DPseq (1+ *DPseq)
    ); setq
  ); repeat
  (setvar 'clayer clay)
  (setvar 'osmode osm)
  (command "_.undo" "_end")
  (setvar 'cmdecho cmde)
  (princ)
); defun -- C:DP

(defun C:DPI () (DP "in")); = Dimension Polyline Inside
(defun C:DPO () (DP "out")); = Dimension Polyline Outside

(prompt "\nType DPI to Dimension a Polyline on the Inside, DPO to do so on the Outside.")

Mình tham gia một cái chơi, bớt đi chút thao tác.

Cách dùng:

Khi gọi lệnh lisp sẽ hỏi "First point" và "Second point".

- Nếu nối 1 đoạn thẳng qua 2 điểm tên sẽ phải cắt qua các Pline.

- Muốn nối phía nào thì đoạn thẳng nói trên cắt qua các pline ở các vị trí gần phía đầu nối hơn đầu kia.

(defun c:tt  (/ cmd doc ent ept inp lst ltp p1 p2 spt ss...
>>

Mình tham gia một cái chơi, bớt đi chút thao tác.

Cách dùng:

Khi gọi lệnh lisp sẽ hỏi "First point" và "Second point".

- Nếu nối 1 đoạn thẳng qua 2 điểm tên sẽ phải cắt qua các Pline.

- Muốn nối phía nào thì đoạn thẳng nói trên cắt qua các pline ở các vị trí gần phía đầu nối hơn đầu kia.

(defun c:tt  (/ cmd doc ent ept inp lst ltp p1 p2 spt ss _int)
  (vl-load-com)
  (setq _int (lambda (ob1 ob2 mod / lst rtn)
               (if (and (vlax-method-applicable-p ob1 'intersectwith)
                        (vlax-method-applicable-p ob2 'intersectwith)
                        (setq lst (vlax-invoke ob1 'intersectwith ob2 mod)))
                 (repeat (/ (length lst) 3)
                   (setq rtn (cons (list (car lst) (cadr lst) (caddr lst)) rtn)
                         lst (cdddr lst))))
               (reverse rtn)))
  (if (and (setq p1 (getpoint "\nFirst point: "))
           (setq p2 (getpoint "\nSecond point: " p1))
           (setq ss (ssget "_F" (list p1 p2) '((0 . "LWPOLYLINE") (8 . "Layer1,Layer2")))))
    (progn (setq cmd (getvar 'CMDECHO))
           (setvar 'CMDECHO 0)
           (vla-startUndoMark (setq doc (vla-get-activedocument (vlax-get-acad-object))))
           (setq ltp (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2))))
           (while (and (setq ent (ssname ss 0)) (ssdel ent ss))
             (setq spt (vlax-curve-getStartPoint ent)
                   ept (vlax-curve-getEndPoint ent)
                   inp (car (_int (vlax-ename->vla-object ltp) (vlax-ename->vla-object ent) acextendnone)))
             (if (< (vlax-curve-getDistAtPoint ent inp) (* 0.5 (vlax-curve-getDistAtPoint ent ept)))
               (setq lst (cons spt lst))
               (setq lst (cons ept lst))))
           (entdel ltp)
           (while (> (length lst) 1)
             (setq ltp (entmakex (list (cons 0 "LINE") (cons 10 (car lst)) (cons 11 (cadr lst))))
                   ss  (ssget "_F" (list p1 p2) '((0 . "LWPOLYLINE") (8 . "Layer1"))))
             (command "_pedit" "m" ss ltp "" "" "join" "0.00" "")
             (setq lst (cddr lst)))
           (vla-EndUndoMark doc)
           (setvar 'CMDECHO cmd)))
  (princ))

@Doan Van Ha Thanks bác!

Lisp sửa lại (Cách dùng như cũ):

(defun c:tt  (/ cmd doc ent ept inp lst ltp lts p1 p2 ped spt sn ss _int _ssg)
  (vl-load-com)
  (setq _int (lambda (ob1 ob2 mod / lst rtn)
               (if (and...
>>

@Doan Van Ha Thanks bác!

Lisp sửa lại (Cách dùng như cũ):

(defun c:tt  (/ cmd doc ent ept inp lst ltp lts p1 p2 ped spt sn ss _int _ssg)
  (vl-load-com)
  (setq _int (lambda (ob1 ob2 mod / lst rtn)
               (if (and (vlax-method-applicable-p ob1 'intersectwith)
                        (vlax-method-applicable-p ob2 'intersectwith)
                        (setq lst (vlax-invoke ob1 'intersectwith ob2 mod)))
                 (repeat (/ (length lst) 3)
                   (setq rtn (cons (list (car lst) (cadr lst) (caddr lst)) rtn)
                         lst (cdddr lst))))
               (reverse rtn))
        _ssg (lambda (lays) (ssget "_F" (list p1 p2) (list (cons 0 "LWPOLYLINE") (cons 8 lays))))
        doc  (vla-get-activedocument (vlax-get-acad-object))
        ped  (getvar 'PEDITACCEPT)
        lts  (getvar 'LTSCALE))
  (if (and (setq p1 (getpoint "\nFirst point: "))
           (setq p2 (getpoint "\nSecond point: " p1))
           (setvar 'LTSCALE 1e-13)
           (not (vla-regen doc acAllViewports))
           (setq ss (_ssg "Layer1,Layer2"))
           (setq sn (_ssg "Layer1"))
           (setvar 'LTSCALE lts)
           (not (vla-regen doc acAllViewports)))
    (progn (setq cmd (getvar 'CMDECHO))
           (setvar 'CMDECHO 0)
           (vla-startUndoMark doc)
           (setq ltp (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2))))
           (while (and (setq ent (ssname ss 0)) (ssdel ent ss))
             (setq spt (vlax-curve-getStartPoint ent)
                   ept (vlax-curve-getEndPoint ent)
                   inp (car (_int (vlax-ename->vla-object ltp) (vlax-ename->vla-object ent) acextendnone)))
             (if (< (vlax-curve-getDistAtPoint ent inp) (* 0.5 (vlax-curve-getDistAtPoint ent ept)))
               (setq lst (cons spt lst))
               (setq lst (cons ept lst))))
           (entdel ltp)
           (setvar 'PEDITACCEPT 1)
           (while (> (length lst) 1)
             (and (> (distance (car lst) (cadr lst)) 0.)
                  (setq ltp (entmakex (list (cons 0 "LINE") (cons 10 (car lst)) (cons 11 (cadr lst)))))
                  (apply 'vl-cmdf (list "_.pedit" "_M" (ssadd ltp sn) "" "_J" "" "")))
             (setq lst (cddr lst)))
           (setvar 'PEDITACCEPT ped)
           (vla-EndUndoMark doc)
           (setvar 'CMDECHO cmd)))
  (princ))

 

Làm dâu trăm họ

Thôi thì theo cái lisp cũ, mình viết...

>>

 

Làm dâu trăm họ

Thôi thì theo cái lisp cũ, mình viết thêm vài kiểu nữa cho chắc :

1. Change cho toàn bộ DimStyle trong bản vẽ :

(defun c:hdima (/ table tH)
(grtext -1 "Free lisp from Cadviet @Ketxu")
(command "undo" "be")
(defun table (s / d r)
(while (setq d (tblnext s (null d)))
(setq r (cons (cdr (assoc 2 d)) r))
)
)
(setq tH (getreal "\n Text Height :"))
(setvar "cmdecho" 0)
(mapcar '(lambda(x)(command "DIMSTYLE" "R" x)(setvar "DIMTXT" tH)(command "DIMSTYLE" "S" x "Y")) (table "DIMSTYLE"))
(command "undo" "en"))

2. Pick đến đâu change đến đó :

(defun c:hdimb (/ lstDstyle tH ent dstyle)
(grtext -1 "Free lisp from Cadviet @Ketxu")
(command "undo" "be")
(setvar "cmdecho" 0)
(setq tH (getreal "\n Text Height :"))
(while (setq ent (car (entsel "\n Pick dim :")))
	(if (setq dstyle (cdr (assoc 3 (entget ent))))
		(if (not (vl-position dstyle lstDstyle))
			(progn
				(setq lstDstyle (cons dstyle lstDstyle))
				(command "DIMSTYLE" "R" dstyle)(setvar "DIMTXT" tH)(command "DIMSTYLE" "S" dstyle "Y")
			)
			(princ "\nAlready Dimension Style Picked")
		)
	)
)
(command "undo" "en")
)

3. Chọn 1 loạt rồi change :

(defun c:hdimc (/ lstDstyle tH i ss ent dstyle)
(grtext -1 "Free lisp from Cadviet @Ketxu")
(command "undo" "be")
(setvar "cmdecho" 0)
(setq tH (getreal "\n Text Height :") i 0 ss (ssget (list (cons 0 "DIMENSION"))))
(while (setq ent (ssname ss i))	
	(if (setq dstyle (cdr (assoc 3 (entget ent))))
		(if (not (vl-position dstyle lstDstyle))
			(progn
				(setq lstDstyle (cons dstyle lstDstyle))
				(command "DIMSTYLE" "R" dstyle)(setvar "DIMTXT" tH)(command "DIMSTYLE" "S" dstyle "Y")
			)			
		)
	)
	(setq i (1+ i))
)
(command "undo" "en")
)

Đó là công việc mà mọi người trên diễn đàn đang cố gắng làm và chia sẻ bạn à

lips hay nhưng mình nhập chiều cao 1 đằng thì chiều cao thực tế của text dim lại kiểu khác bạn ah.

 

<<

 

Làm dâu trăm họ

Thôi thì theo cái lisp cũ, mình viết...

>>

 

Làm dâu trăm họ

Thôi thì theo cái lisp cũ, mình viết thêm vài kiểu nữa cho chắc :

1. Change cho toàn bộ DimStyle trong bản vẽ :

(defun c:hdima (/ table tH)
(grtext -1 "Free lisp from Cadviet @Ketxu")
(command "undo" "be")
(defun table (s / d r)
(while (setq d (tblnext s (null d)))
(setq r (cons (cdr (assoc 2 d)) r))
)
)
(setq tH (getreal "\n Text Height :"))
(setvar "cmdecho" 0)
(mapcar '(lambda(x)(command "DIMSTYLE" "R" x)(setvar "DIMTXT" tH)(command "DIMSTYLE" "S" x "Y")) (table "DIMSTYLE"))
(command "undo" "en"))

2. Pick đến đâu change đến đó :

(defun c:hdimb (/ lstDstyle tH ent dstyle)
(grtext -1 "Free lisp from Cadviet @Ketxu")
(command "undo" "be")
(setvar "cmdecho" 0)
(setq tH (getreal "\n Text Height :"))
(while (setq ent (car (entsel "\n Pick dim :")))
	(if (setq dstyle (cdr (assoc 3 (entget ent))))
		(if (not (vl-position dstyle lstDstyle))
			(progn
				(setq lstDstyle (cons dstyle lstDstyle))
				(command "DIMSTYLE" "R" dstyle)(setvar "DIMTXT" tH)(command "DIMSTYLE" "S" dstyle "Y")
			)
			(princ "\nAlready Dimension Style Picked")
		)
	)
)
(command "undo" "en")
)

3. Chọn 1 loạt rồi change :

(defun c:hdimc (/ lstDstyle tH i ss ent dstyle)
(grtext -1 "Free lisp from Cadviet @Ketxu")
(command "undo" "be")
(setvar "cmdecho" 0)
(setq tH (getreal "\n Text Height :") i 0 ss (ssget (list (cons 0 "DIMENSION"))))
(while (setq ent (ssname ss i))	
	(if (setq dstyle (cdr (assoc 3 (entget ent))))
		(if (not (vl-position dstyle lstDstyle))
			(progn
				(setq lstDstyle (cons dstyle lstDstyle))
				(command "DIMSTYLE" "R" dstyle)(setvar "DIMTXT" tH)(command "DIMSTYLE" "S" dstyle "Y")
			)			
		)
	)
	(setq i (1+ i))
)
(command "undo" "en")
)

Đó là công việc mà mọi người trên diễn đàn đang cố gắng làm và chia sẻ bạn à

lips hay nhưng mình nhập chiều cao 1 đằng thì chiều cao thực tế của text dim lại kiểu khác bạn ah.

 

<<

 

Làm dâu trăm họ

Thôi thì theo cái lisp cũ, mình viết...

>>

 

Làm dâu trăm họ

Thôi thì theo cái lisp cũ, mình viết thêm vài kiểu nữa cho chắc :

1. Change cho toàn bộ DimStyle trong bản vẽ :

(defun c:hdima (/ table tH)
(grtext -1 "Free lisp from Cadviet @Ketxu")
(command "undo" "be")
(defun table (s / d r)
(while (setq d (tblnext s (null d)))
(setq r (cons (cdr (assoc 2 d)) r))
)
)
(setq tH (getreal "\n Text Height :"))
(setvar "cmdecho" 0)
(mapcar '(lambda(x)(command "DIMSTYLE" "R" x)(setvar "DIMTXT" tH)(command "DIMSTYLE" "S" x "Y")) (table "DIMSTYLE"))
(command "undo" "en"))

2. Pick đến đâu change đến đó :

(defun c:hdimb (/ lstDstyle tH ent dstyle)
(grtext -1 "Free lisp from Cadviet @Ketxu")
(command "undo" "be")
(setvar "cmdecho" 0)
(setq tH (getreal "\n Text Height :"))
(while (setq ent (car (entsel "\n Pick dim :")))
	(if (setq dstyle (cdr (assoc 3 (entget ent))))
		(if (not (vl-position dstyle lstDstyle))
			(progn
				(setq lstDstyle (cons dstyle lstDstyle))
				(command "DIMSTYLE" "R" dstyle)(setvar "DIMTXT" tH)(command "DIMSTYLE" "S" dstyle "Y")
			)
			(princ "\nAlready Dimension Style Picked")
		)
	)
)
(command "undo" "en")
)

3. Chọn 1 loạt rồi change :

(defun c:hdimc (/ lstDstyle tH i ss ent dstyle)
(grtext -1 "Free lisp from Cadviet @Ketxu")
(command "undo" "be")
(setvar "cmdecho" 0)
(setq tH (getreal "\n Text Height :") i 0 ss (ssget (list (cons 0 "DIMENSION"))))
(while (setq ent (ssname ss i))	
	(if (setq dstyle (cdr (assoc 3 (entget ent))))
		(if (not (vl-position dstyle lstDstyle))
			(progn
				(setq lstDstyle (cons dstyle lstDstyle))
				(command "DIMSTYLE" "R" dstyle)(setvar "DIMTXT" tH)(command "DIMSTYLE" "S" dstyle "Y")
			)			
		)
	)
	(setq i (1+ i))
)
(command "undo" "en")
)

Đó là công việc mà mọi người trên diễn đàn đang cố gắng làm và chia sẻ bạn à

lips hay nhưng mình nhập chiều cao 1 đằng thì chiều cao thực tế của text dim lại kiểu khác bạn ah.

 

<<

anh viết giúp em một lisp thay thế một block bằng block khác chèn đúng vào vị trí của block cũ. block có thể chọn bằng cách nhập tên hoặc select trên bản vẽ....

>>

anh viết giúp em một lisp thay thế một block bằng block khác chèn đúng vào vị trí của block cũ. block có thể chọn bằng cách nhập tên hoặc select trên bản vẽ. nếu có thể thay thế đc nhiều block một lần thì tốt nhất. em cám ơn anh nhiều!

 

 

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

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

;

(defun c:mab ()
(setq ddd (entsel "\nChon Block mau"))
(while
(or
  (null ddd)
  (/= "INSERT" (cdr (assoc 0 (entget (car ddd)))))
)
(princ "\nDoi tuong khong phai la Block! Chon lai")
(setq ddd (entsel "\nChon Block mau"))
)


;(prompt "\nChon BLOCK mau.")
;   (setq DT (car (entsel)))
  (setq DT (car ddd))
  (setq DTM (entget DT))
  (setq TENKHOI (cdr (assoc 2 DTM)))
  (setq TILEX (cdr (assoc 41 DTM)))
  (setq TILEY (cdr (assoc 42 DTM)))
  ;(setq TILEZ (cdr (assoc 43 DTM)))
  (setq GOCCHEN (cdr (assoc 50 DTM)))
  (setq GOCCHENn (atof (angtos GOCCHEN 0 2)))

(Princ "\nChon BLOCK muon chinh :")
(setq xx (ssget '((0 . "insert"))))
(setq L 0)
(setq M (sslength XX))
(while (< L M)
  (setq DTs (ssname XX L))
  (setq DTMs (entget DTs))
  (setq DIEMCHEN (cdr (assoc 10 DTMs)))
  (command "ERASE" DTs "") 
(luuos)
 (setvar "osmode" 0)
 (command "INSERT" TENKHOI DIEMCHEN TILEX TILEY GOCCHENn)
(traos)
  (setq L (1+ L))
)


(setvar "MODEMACRO" "**CHUC BAN LAM VIEC HIEU QUA** PHAM QUOC DUY - BINH SON - QUANG NGAI")
     (Princ))

;-------------
(defun c:mabt ()

(setq ddd (entsel "\nChon Block mau"))
(while
(or
  (null ddd)
  (/= "INSERT" (cdr (assoc 0 (entget (car ddd)))))
)
(princ "\nDoi tuong khong phai la Block! Chon lai")
(setq ddd (entsel "\nChon Block mau"))
)




;(prompt "\nChon BLOCK mau.")
  ;(setq DT (car (entsel)))
  (setq DT (car ddd))
  (setq DTM (entget DT))
  (setq TENKHOI (cdr (assoc 2 DTM)))

(Princ "\nChon BLOCK muon chinh :")
(setq xx (ssget '((0 . "insert"))))
(setq L 0)
(setq M (sslength XX))
(while (< L M)
  (setq DTs (ssname XX L))
  (setq DTMs (entget DTs))
  (setq DIEMCHEN (cdr (assoc 10 DTMs)))

  (setq TILEX (cdr (assoc 41 DTMs)))
  (setq TILEY (cdr (assoc 42 DTMs)))
  (setq GOCCHEN (cdr (assoc 50 DTMs)))
  (setq GOCCHENn (atof (angtos GOCCHEN 0 2)))

  (command "ERASE" DTs "") 
(luuos)
 (setvar "osmode" 0)
 (command "INSERT" TENKHOI DIEMCHEN TILEX TILEY GOCCHENn)
(traos)
  (setq L (1+ L))
)


(setvar "MODEMACRO" "**CHUC BAN LAM VIEC HIEU QUA** PHAM QUOC DUY - BINH SON - QUANG NGAI")
     (Princ))


;;----------
(defun done ()
 (command ".redraw")
 (command ".undo" "E")
 (if DUY_CMD
   (setvar "CMDECHO" DUY_CMD)
 )
 (if DUY_OLDERROR
   (setq *error* DUY_OLDERROR)
 )
 (princ)
)
;;----------
(defun luuos ()
 (setq
   DUY_OSMODE   (getvar "OSMODE")
   DUY_AUTOSNAP (getvar "AUTOSNAP")
  DUY_LAYERHH (getvar "CLAYER")
  DUY_THANGXEOHH (getvar "ORTHO")
  DUY_filletrad (getvar "FILLETRAD")
 DUY_TEXTSTYLE (getvar "TEXTSTYLE")
  )
)
(defun traos ()
 (if DUY_OSMODE
   (setvar "OSMODE" DUY_OSMODE)
 )
 (if DUY_LAYERHH
   (setvar "CLAYER" DUY_LAYERHH)
 )
 (if DUY_THANGXEOHH
   (setvar "ORTHO" DUY_THANGXEOHH)
 )
 (if DUY_AUTOSNAP
   (setvar "AUTOSNAP" DUY_AUTOSNAP)
 )
(if DUY_filletrad
   (setvar "FILLETRAD" DUY_filletrad)
 )
(if DUY_TEXTSTYLE
   (setvar "TEXTSTYLE" DUY_TEXTSTYLE)
 )


)
;;----------

 

 

Lệnh MAB và MABT bạn coi cái nào đúng ý bạn thì dùng

<<

4 giờ trước, divine kai đã nói:

anh ơi, anh có thể chỉnh lisp...

>>

4 giờ trước, divine kai đã nói:

anh ơi, anh có thể chỉnh lisp này cho ra đối tượng là text như lisp cũ, được không anh vì khi là đối tượng mtext khi em X ra thì nó bị vỡ đối tượng, em muốn X ra để sửa lỗi font

 

Oke rồi nhưng độ giãn của text không chỉnh được như MText 

(defun c:te (/ ss lstl ent ss1 lst lst2 en en2 en3 str pref)
  (vl-load-com)
  (setq ss (acet-ss-to-list (ssget (list (cons 0 "MTEXT")))))
  (setvar 'cmdecho 0)
    (setq lstl (list "layer1" "layer2" "layer3" "layer4" "layer5"))
  (setq i 0)
  (mapcar '(lambda (x)(if (not (tblsearch "layer" x)) (progn (setq i (1+ i)) (command "-LAYER" "M" x "C" (itoa i) "" ""))) ) lstl)
  (foreach ent ss
    (setq lst (list))
    (setq str (cdr (assoc 1 (entget ent)))) 
    (while (vl-string-search "\\P" str)
      (setq stri (substr str 1 (vl-string-search "\\P" str)))
      (setq lst (append lst (list stri)))
      (setq str (substr str (+ (vl-string-search "\\P" str) 3)))
      )
    (if (/= str "") (setq lst (append lst (list str))))
    (if (or (= (length lst) 4)
	    (= (length lst) 5) )(progn
			    (setq pt (cdr (assoc 10 (entget ent))))
			    (setq pref (vl-string-right-trim "1234567890" (car lst)))			    
	(mapcar '(lambda (str lay) (if (and (= str (car lst)) (/= pref "")) (setq str (substr str (1+ (strlen pref)))) )
		   (maketext pt str lay ent )
		   (setq pt (polar pt (* 1.5 pi) (vla-get-linespacingdistance (vlax-ename->vla-object ent) )) ) ) lst lstl)
			    (entdel ent)
			     ) 
      )
    )
  (setvar 'cmdecho 1)
  (princ)
  )
(defun maketext (point noidungtext lay entg )
  (entmakex (list '(0 . "TEXT") '(100 . "AcDbEntity") '(100 . "AcDbText")
              (cons 10 point)
              (assoc 40 (entget entg))
              (cons 1 noidungtext)
		  (cons 11 point)
		  (cons 8 lay)
		  (assoc 7 (entget entg))
		(cons 71 0)
		 (cons 72 1)
		  (cons 73 3)
		  ))
  )

 

<<

Thử Lisp này xem :) :

(defun c:DML (/ doc elist1 laname1)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) 
(vla-StartUndoMark doc) (vl-load-com)
(setq elist1 (entget (car (entsel "\nChon doi tuong can doi mau ByLayer"))))
(setq laname1 (cdr (assoc 8 elist1))) 
(if (ssget "X" (list (cons 8  laname1))) 
(vlax-map-collection (vla-get-ActiveSelectionset doc)
(function (lambda (ob) (vla-put-color ob 256))))	)
(vla-EndUndoMark doc) (princ))...
>>

Thử Lisp này xem :) :

(defun c:DML (/ doc elist1 laname1)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object))) 
(vla-StartUndoMark doc) (vl-load-com)
(setq elist1 (entget (car (entsel "\nChon doi tuong can doi mau ByLayer"))))
(setq laname1 (cdr (assoc 8 elist1))) 
(if (ssget "X" (list (cons 8  laname1))) 
(vlax-map-collection (vla-get-ActiveSelectionset doc)
(function (lambda (ob) (vla-put-color ob 256))))	)
(vla-EndUndoMark doc) (princ)) 

Tuynh:

Mình đưa file lên đây

http://www.cadviet.com/upfiles/2/2d3d.dwg

đường 2d poline có cao độ là 10,...

>>

Tuynh:

Mình đưa file lên đây

http://www.cadviet.com/upfiles/2/2d3d.dwg

đường 2d poline có cao độ là 10, đường 3d poline có cao độ khác nhau tại các điểm point, bạn có lisp nào mà khi pick vào đường

2d poline thì tại các điểm point hiện cao độ cho mình nhập theo ý muốn và đường 2d poline chuyển thành 3d poline.

 

Chào Tuynh, lisp sau đây, yêu cầu Bạn pick các node của polyline sẽ biến 2D polyline thành 3D polyline. Sau đó bạn tiếp tục thay đổi độ cao các node của 3d polyline

;;; Lisp thay doi do cao cac node cua POLYLINE
;;; copyright by Thiep 7/2009
;;; yeu cau: cai dat day du Expresstools 
;;;--------------------------
(defun DXF (code en) (cdr (assoc code (entget en))))
;;;---------------------
(defun SAVE_MODE ()
 (command "UCS" "W" "")
 (setq	OLD_OSMODE    (getvar "OSMODE")
OLD_CECOLOR   (getvar "CECOLOR")
OLD_AUTOSNAP  (getvar "AUTOSNAP")
OLD_ORTHOMODE (getvar "ORTHOMODE")
 )
 (setvar "cmdecho" 0)
 (setvar "plinegen" 1)

)
(defun RESTORE ()
 (setvar "osmode" OLD_OSMODE)
 (setvar "AUTOSNAP" OLD_AUTOSNAP)
 (setvar "ORTHOMODE" OLD_ORTHOMODE)
 (setvar "CECOLOR" OLD_CECOLOR)
 (setvar "cmdecho" 1)
)
;;;--------------------------
;;;----------------------------------------
(defun 3DPoly (Lp *ModelSpace* / PntArr)
 (setq	PntArr (vlax-make-safearray
	 vlax-vbDouble
	 (cons 0 (1- (length Lp)))
       )
 )
 (vlax-safearray-fill PntArr Lp)
 (vla-Add3Dpoly *ModelSpace* PntArr)
)
;;;-----------------------------------
(vl-load-com)
(defun c:3dp (/ ActDoc *Model* wp lwp Obj n pn pcl Pe lstP Elev lt lstN)
 (SAVE_MODE)
 (setvar "osmode" 1)
 (setq	ActDoc	(vla-get-ActiveDocument (vlax-get-acad-object))
*Model*	(vla-get-ModelSpace ActDoc)
 )
 (while (setq pn (getpoint "\nPick a point on Polyine: "))
   (setq lwp (ssname (ssget pn) 0))
   (redraw lwp 3)
   (setq heinode (getreal "\nEnter height of node: ")
  obj	  (vlax-ename->vla-object lwp)
  lstP (ACET-GEOM-VERTEX-LIST lwp)
   )
   (if	(eq (dxf 0 lwp) "LWPOLYLINE")
     (progn
(setq Elev (vla-get-Elevation obj))
(setq lstN nil)
(foreach lt lstP
  (if (and (eq (car lt) (car pn)) (eq (cadr lt) (cadr pn)))
    (setq lt (list (car lt) (cadr lt) heinode))
    (setq lt (list (car lt) (cadr lt) Elev))
  )
  (setq lstN (append lt lstN))
)
(vla-update (3DPoly lstN *Model*))
(vla-delete obj)
     )
     (progn
(setq lstP (ACET-GEOM-VERTEX-LIST lwp))
(setq lstN nil)
(foreach lt lstP
  (if (and (eq (car lt) (car pn)) (eq (cadr lt) (cadr pn)))
    (setq lt (list (car lt) (cadr lt) heinode))
  )
  (setq lstN (append lt lstN))
)
(vla-update (3DPoly lstN *Model*))
(vla-delete obj)
     )
   )
 )
 (RESTORE)
 (princ "\nChuc cac ban vui ve! Thiep")
 (princ)
)

Tuy nhiên, nếu bạn thay đổi 1 polyline có hàng 100 node thì nên dùng cách khác nhanh hơn: Dùng bảng kê tọa độ trong Excel đổi qua đuôi *.csv, sau đó xây dựng 1 3D polyline theo 1 lisp khác.

<<

copy đoạn sau của Biet ve CAD

(vl-load-com)
(defun C:BVC( / e str)
 (foreach e (acet-ss-to-list (ssget '((0 . "text"))))
   (setq str (cdr (assoc 1 (entget e))))
   (if(vl-string-search "T\\" str)
     (progn
       (setq str(vl-string-subst "" "T\\U+1EDD" str)
         str(vl-string-subst "" "s\\U+1ED1" str)
         str(vl-string-subst "" " " str)
         )
       (if(vl-string-search "(t" str)(setq...
>>

copy đoạn sau của Biet ve CAD

(vl-load-com)
(defun C:BVC( / e str)
 (foreach e (acet-ss-to-list (ssget '((0 . "text"))))
   (setq str (cdr (assoc 1 (entget e))))
   (if(vl-string-search "T\\" str)
     (progn
       (setq str(vl-string-subst "" "T\\U+1EDD" str)
         str(vl-string-subst "" "s\\U+1ED1" str)
         str(vl-string-subst "" " " str)
         )
       (if(vl-string-search "(t" str)(setq str (vl-string-subst "" (substr str (+(vl-string-search "(t" str)1)) str)))
       (vla-put-textstring (vlax-ename->vla-object e) str)
       )
     )
   )
  ) 

Đây nhá:

(defun C:HA2 (/ fn fw i lst txt)
  ;Doan Van Ha Cadviet.com
  (princ "\nChon cac Text/Mtext/Dimension can xuat ra file..."
  )
  (setq	lst (acet-ss-to-list (ssget '((0 . "*TEXT,DIMENSION"))))
	fn  (getfiled "Chon file de save" "" "txt" 1)
	fw  (open fn "w")
  )
  (setq i 0)
  ; (setq n (nth 0 lst))
  (foreach n lst
    (cond
      ((= (cdr (assoc 0 (entget n))) "TEXT")
       (setq txt (cdr (assoc 1 (entget n))))
      )
      ((= (cdr...
>>

Đây nhá:

(defun C:HA2 (/ fn fw i lst txt)
  ;Doan Van Ha Cadviet.com
  (princ "\nChon cac Text/Mtext/Dimension can xuat ra file..."
  )
  (setq	lst (acet-ss-to-list (ssget '((0 . "*TEXT,DIMENSION"))))
	fn  (getfiled "Chon file de save" "" "txt" 1)
	fw  (open fn "w")
  )
  (setq i 0)
  ; (setq n (nth 0 lst))
  (foreach n lst
    (cond
      ((= (cdr (assoc 0 (entget n))) "TEXT")
       (setq txt (cdr (assoc 1 (entget n))))
      )
      ((= (cdr (assoc 0 (entget n))) "MTEXT")
       (setq txt (cdr (assoc 1 (entget n))))
      )
      ((= (cdr (assoc 0 (entget n))) "DIMENSION")
       (if (= (cdr (assoc 1 (entget n))) "")
	 (setq txt (rtos (cdr (assoc 42 (entget n)))))
	 (setq txt (cdr (assoc 1 (entget n))))
       )
      )
    )
    (if (/= (rem (setq i (1+ i)) 4) 0)
      (princ (strcat txt ",\t") fw)
      (princ (strcat txt ",\n") fw))
  )
  (close fw)
)

admin - code lisp giờ là gì vậy ạ

19 giờ trước, divine kai đã nói:

em có gửi ở phiá trên đó...

>>

19 giờ trước, divine kai đã nói:

em có gửi ở phiá trên đó anh

Bạn dùng thử lisp này xem, chưa test hết các trường hợp, mới đầu dùng ok 

(vl-load-com)
(defun c:xt (/ ss lstl ent ss1 lst lst2 en en2 en3 str)
(setq ss  (ssget '((0 . "MTEXT"))))
  (command "_-OVERKILL" ss "" "D")
  (setq ss1 (ssadd) ent (entlast))
(setq qa (getvar "QAFLAGS"))
(setvar "QAFLAGS" 1)
(command "._explode" ss "" )
(setvar "QAFLAGS" qa)
  (while (setq ent (entnext ent))
 (setq ss1 (ssadd ent ss1)))
    (setq ss1 (acet-ss-to-list ss1))
    (setq ss1 (vl-sort ss1 '(lambda (x y) (cond	( (= (cadr (cdr (assoc 10 (entget x)))) (cadr (cdr (assoc 10 (entget y)))) )
					    (< (car (cdr (assoc 10 (entget x)))) (car (cdr (assoc 10 (entget y))))))
					     ((> (cadr (cdr (assoc 10 (entget x)))) (cadr (cdr (assoc 10 (entget  y))))))  ))))
    (while (setq en (car ss1))
      (setq ss1 (cdr ss1))
      (setq lst2 (list en))
      (while (and (setq en2 (car ss1))
		  (= (cadr (cdr (assoc 10 (entget en)))) (cadr (cdr (assoc 10 (entget en2)))) ) )
	(setq ss1 (cdr ss1))
	(setq lst2 (append lst2 (list en2)))
	)
      (if (> (length lst2) 1) (progn
	(setq str "")
	(mapcar '(lambda (x) (setq str (strcat str (cdr (assoc 1 (entget x)))))) lst2)
	(setq en3 (car lst2))
	 (mapcar '(lambda (x) (entdel x) ) (cdr lst2))
	(entmod (subst (cons 1 str) (assoc 1 (entget en3)) (entget en3)))
	) )
      )
  (princ)
  )

 

<<

Mấy chuyện lớn sẽ nhờ tới Cao thủ, việc nhỏ nhỏ mình giúp bạn thử xem sao nhé. hê hê !

 

Lệnh zoom dưới đây swr dụng nút giữa chuột, trái phải để...

>>

Mấy chuyện lớn sẽ nhờ tới Cao thủ, việc nhỏ nhỏ mình giúp bạn thử xem sao nhé. hê hê !

 

Lệnh zoom dưới đây swr dụng nút giữa chuột, trái phải để exit

nếu không vừa ý chổ nào bạn cứ nói nhé.

 

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

(defun c:input (/ filename f number sta)
(setq filename (getfiled "Select a File" "" "xls" 1))
 (if filename
  (progn
(setq f (open filename "w"))		
(setq id (load_dialog "C:/input.dcl"))

(setq sta 2)	
(while (> sta 1)	
(new_dialog "input" id)
(set_tile "filename" (strcat "File name:" filename))
(mode_tile "number" 2)
(action_tile "note" "(PROGN
			  (write-line (strcat
			(setq number (get_tile \"number\")) \"\t\"
			(get_tile \"code\") \"\t\"
			  (get_tile \"distance\") \"\t\"
			(get_tile \"note\") \"\t\") f)
			(set_tile \"number\" (itoa (1+ (atoi number))))
			(mode_tile \"code\" 2)
			  )")
(action_tile "zoom" "(done_dialog 2)")  
(setq sta (start_dialog))
	(if (= sta 2) (command "zoom" (getpoint "\nSu dung nut giua chuot de zoom, pan :") nil))	  


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

 ))  

 )

Chào bác npham,

Đọc code của bác mình thấy một vài thắc mắc sau:

1/- Hàm (mode_tile "key" Value) chỉ nhận hai giá trị là 0 và 1 tức là chỉ có tác dụng tắt hay mở cái nút mang key đó mà thôi. Vậy sao ở đây bác dùng (mode_tile "number" 2). Như vậy nó có ý nghĩa gì???

2/- Key bác đặt là "code" , vậy tại sao trong hàm bác dùng (mode_tile \"code\" 2) ??? Nó có ý nghĩa ra sao???

3/- Bác đặt (setq sta (start_dialog))

Vậy làm sao có (if (= sta 2) ........

4/- Bác dùng :

(action_tile "note" "(PROGN

(write-line (strcat

(setq number (get_tile \"number\")) \"\t\"

(get_tile \"code\") \"\t\"

(get_tile \"distance\") \"\t\"

(get_tile \"note\") \"\t\") f)

(set_tile \"number\" (itoa (1+ (atoi number))))

(mode_tile \"code\" 2)

)")

Như vậy nếu cái key "note" không được kich hoạt (nhập số liệu) thì cái dòng dũ liệu đó có được nhập vào Excel hay không??? Vì thực tế có thể sẽ có những dòng dữ liệu không cần phải nhập ghi chú bác ạ...

5/- Theo mình hiểu thì cái (done_dialog) là hàm đóng hộp thoại lại. Vậy (done_dialog 2) phải chăng là vừa đóng hộp thoại vừa gán cho cái biến sta giá trị là 2 phải không bác????

 

Vài câu hỏi làm phiền bác, mong bác chớ giận và giải đáp giùm, thực tình cái dialog này mình chưa rõ lắm, nhất là việc sử dụng nó cho vòng lặp bác ạ.

Chúc bác khỏe và vui.

<<

 

Sài thử Lisp này xem :

 

(defun c:rv( / n vp)
  (vl-load-com)
  (if (= (getvar "Tilemode") 0)
    (progn
     ...
>>

 

Sài thử Lisp này xem :

 

(defun c:rv( / n vp)
  (vl-load-com)
  (if (= (getvar "Tilemode") 0)
    (progn
      (if (/= (getvar "cvport") 1)
	(vla-Put-MSpace (vla-Get-ActiveDocument (vlax-Get-Acad-Object)) :vlax-False))
      (prompt "\nChont viewport can xuay: ")
      (if (and (setq ss (ssget ":S+." '((0 . "VIEWPORT"))))
	       (setq ang (getangle "\nNhap goc xuay: ")))
	(vla-Put-TwistAngle (vlax-EName->vla-Object (ssname ss 0)) ang) ) )      
    (alert "\n Chuyen sang Layout truoc khi chay Lisp!")    )
  (princ)  )

Nó ra thế này bạn ạ:

Select viewport:; error: bad argument type: numberp: nil

<<

Lisp này e down từ diễn đàn,lisp này có tác dụng cắt 1 đoạn thẳng trong 1 đường thẳng và có cho ta lựa chọn thuộc tính của đoạn...

>>

Lisp này e down từ diễn đàn,lisp này có tác dụng cắt 1 đoạn thẳng trong 1 đường thẳng và có cho ta lựa chọn thuộc tính của đoạn thẳng này.Nhưng khi muốn biến đoạn thẳng này thành nét đứt thì có 1 bất tiện e nhờ các bác sửa giúp như sau.

Trong bản vẽ có hệ số LTS là 1,

1.Có 1 đoạn thẳng là nét đứt và có LTS là 50 chẳng hạn.

2.Có 1 đường thẳng.

E dùng lisp này để cắt 1 đoạn thẳng trong đường thẳng 2 này và biến đoạn thẳng này thành đoạn thẳng 1 là nét đứt nhưng hệ số LTS chỉ là 1 theo bản vẽ chứ không theo LTS của đoạn thẳng 1 là 50,Nhờ các bác sửa giùm sao cho đoạn thẳng này thành nét đứt có LTS là 50 theo đúng đoạn thẳng đã chọn.Chân thành cảm ơn.

(defun c:brk(/ cobj ent ov pt1 pt2 tmp vl str); brk -> Break Curve
 (vl-load-com)
 (command "undo" "be")
 (setq vl '("osmode" "orthomode" "cmdecho") ; Sys Var list
ov (mapcar 'getvar vl))          	; Get Old values
 (mapcar 'setvar vl '(545 0 0))
 (if (and (setq Ent (car (entsel "\nChon doi tuong can chia :")))
(wcmatch (cdr (assoc 0 (entget ent))) "*LINE,ARC")
(not (redraw ent 3))
(setq pt1 (getpoint "\nDiem dau :"))
(setq pt2 (getpoint "\nDiem cuoi :"))   )
(progn
     	(setq cObj (vlax-ename->vla-object Ent)
pt1 (vlax-curve-getClosestPointto cObj (trans pt1 1 0))
pt2 (vlax-curve-getClosestPointto cObj (trans pt2 1 0)))
 	(if (> (vlax-curve-getParamAtPoint cObj pt1)
 	(vlax-curve-getParamAtPoint cObj pt2))
(setq tmp pt1 pt1 pt2 pt2 tmp) )    
 	(command "._break" ent "_non" (trans pt2 0 1) "_non" (trans pt2 0 1))
 	(if (equal pt1 (vlax-curve-getStartPoint cObj) 0.001)
(command "change" ent "" "p" "LA" (lcurr) "")
(progn
  (command "._break" ent "_non" (trans pt1 0 1) "_non" (trans pt1 0 1))
  (command "change" (entlast) "" "p" "LA" (lcurr) "")
  )
)
 	(redraw ent 4)
 	(mapcar 'setvar vl ov) ; reset Sys Vars
 	(command "undo" "e")
 	)
(alert "Khong hop le !"))
 (princ))
;
(defun lcurr(/ e)
(setq str (getstring t "\n Nhap ten layer hoac Enter de pick vao doi tuong :"))
(if (= str "")
(progn
(while (null (setq e (entsel "\n pick vao doi tuong :"))))
(setvar "clayer" (cdr(assoc 8 (entget(car e)))))
)
(progn
(while (null (tblsearch "layer" str))
(setq str (getstring t "\n Nhap lai ten layer :"))
)
(setvar "clayer" str)
)
)
)

Hề hề hề,

Thú thực là đọc cái lisp bạn post chẳng hề dễ dàng chút nào.

Sau khi đọc kỹ mình thấy trong lisp đâu có việc chuyển LTS theo đối tượng mẫu đâu mà bạn bảo sửa????

Lisp chỉ có chuyển layer của đối tượng break về layer mẫu mà thôi. Do vậy nếu LT của đối tượng là bylayer thì nó sẽ theo LT của layer đó, còn nếu không phải là bylaer thì nó sẽ chả chuyển gì sốt.

Việc bạn muốn nó chuyển thành LTS của đối tượng mẫu có nhẽ không khó, nhưng bạn lưu ý rằng khi chuyển ltscale thì tất cả các line trên bản vẻ của bạn sẽ đều bì chuyển đó. Điều này có nhẽ bạn sẽ không thích đâu.

Còn nếu bạn vẫn muốn thì đơn giản là bạn dùng lệnh ltscale của Cad là sẽ Ok đâu cần tới lisp làm chi cho nó thêm ..... đợi chờ....

<<

Quick code :

(defun c:fg(/ s sd)
(vl-load-com)
(ssget '((0 . "*TEXT,*DIMENSION")))
(vlax-for o (setq...
>>

Quick code :

(defun c:fg(/ s sd)
(vl-load-com)
(ssget '((0 . "*TEXT,*DIMENSION")))
(vlax-for o (setq s(vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object))))
	(cond 
		(	(wcmatch (vla-get-ObjectName o) "*Text")
			(vla-put-Textstring o (strcat "(" (vla-get-Textstring o) ")"))
		)
		((vla-put-TextOverride o
			(strcat
				"("
					(if (/= (setq sd (vla-get-TextOverride o)) "") sd "<>")
				")"
			)
		))			
	)
)
(and s (vla-delete s))
)

 

 

Cảm ơn bạn ketxu nhiều lắm! Lsp của bạn viết đúng ý mình rồi.

Cảm ơn bạn quansla

Cảm ơn bạn quocmanh04tt

Mỗi người có ưu điểm riêng.

<<

Lệnh là DTN. Việc chọn đúng các block có 2 tag như bản vẽ mẫu là việc của bạn nhé.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Defun duy:block_d_att>ten (dchon tentang / dchon ndd tdd lst lsts lkq tentang)
(while (/= (cdr (assoc 0 (entget (entnext dchon)))) "SEQEND")
(setq ndd (cdr (assoc 1 (entget (entnext dchon)))))
(setq tdd (cdr...
>>

Lệnh là DTN. Việc chọn đúng các block có 2 tag như bản vẽ mẫu là việc của bạn nhé.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Defun duy:block_d_att>ten (dchon tentang / dchon ndd tdd lst lsts lkq tentang)
(while (/= (cdr (assoc 0 (entget (entnext dchon)))) "SEQEND")
(setq ndd (cdr (assoc 1 (entget (entnext dchon)))))
(setq tdd (cdr (assoc 2 (entget (entnext dchon)))))
(cond
((= tentang tdd) (setq kq ndd) )
)
(setq dchon (entnext dchon))
)
kq)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Defun c:dtn (/ b i N listkq)
(command "undo" "be")
(princ "Chon cac block !")
(setq b (ssget (list (cons 0 "INSERT"))))
(setq i 0)
(setq N (sslength b))
(while (< i N)
(setq diemchen (cdr (assoc 10 (entget (ssname b i)))))
 (setq ndtr (duy:block_d_att>ten (ssname b i) "II"))
 (setq nds (duy:block_d_att>ten (ssname b i) "1"))
 (setq ndv (strcat ndtr "," nds))
(entmake (list (cons 0 "TEXT")(cons 10 diemchen)(cons 11 diemchen)(cons 40 5)(cons 50 0)(cons 72 0)(cons 1 ndv)(cons 7 (getvar "TEXTSTYLE"))(cons 8 "layermoi")(cons 62 256)))
(setq i (1+ i))
)
(command "undo" "end")
(Princ)) 

 

Lisp #6 chỉ đúng với trường hợp cụ thể như bản vẽ của bạn gửi thôi. Nếu bạn muốn xuất ngược xuất xuôi số liệu...

>>

 

Lisp #6 chỉ đúng với trường hợp cụ thể như bản vẽ của bạn gửi thôi. Nếu bạn muốn xuất ngược xuất xuôi số liệu thì tốt nhất là dùng Block Attribute như Lisp #3. Lisp #3 có ưu điểm nữa là nếu bạn  vẽ cho lưới 5m, 10m, 100m ... đều được hết, để làm điều đó bạn chỉ cần chỉnh lại vị trí của các Text trong bản vẽ đính kèm mục #3 thôi.

Tiện đây cho bạn cái lisp xuất số liệu Block Attribute từ CAD sang txt. Bạn dùng Lisp #3 và Lisp này là có thể chuyển đổi số liệu từ CAD sang TXT và ngược lại ngon lành rồi.

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

;=====LISP CONVERT ATTRIBUTE TO TEXT==========
;=========KANGKUNG 26/03/2013=================
(defun C:KK()
  (IF (NOT PATH)
    (SETQ PATH (getvar "dwgprefix")))
  (setq taphop(ssget '((0 . "INSERT")))	index 0 tenfileout(getfiled "Output File" PATH "txt" 11))
  (SETQ PATH tenfileout tenfile(open tenfileout "W"))
  (write-line "No.	Easting	Northing	STTO	CCTC	D.TICH	K.LUONG" tenfile)
  (setq i 0)
  (while (< index (sslength taphop))
    (setq enlist (entget (ssname taphop index))i(1+ i) STT(rtos i 2 0)
	  insert_point(cdr(assoc 10 enlist))
	  CHUOI (strcat STT "\t" (rtos (car insert_point) 2 3) "\t" (rtos (cadr insert_point) 2 3))
	  EN2(ENTNEXT(ssname taphop index))
	  ENLIST2(ENTGET EN2))
    (while (/= (cdr(assoc 0 enlist2)) "SEQEND")
      (SETQ VALUE(cdr(assoc 1 enlist2))
	    TAG(cdr(assoc 2 enlist2))
	    CHUOI(STRCAT CHUOI "\t" VALUE)
	    en2(entnext en2)
	    enlist2(entget en2))
      )
    (write-line CHUOI tenfile)
    (setq index (+ index 1))
    )
  (alert (strcat (rtos i 2 0) " objects converted!"))
  (princ)
  (close tenfile)
  (COMMAND "NOTEPAD" tenfileout)
)
(princ "\n                Written By KangKung - 26/03/2013\n")
(princ "\n                  Nhap KK de chay chuong trinh\n")

Vẫn không xuất ra txt được bạn ơi. Bạn xem lại giúp

<<

 

Không muốn dùng Block Attribute thì chơi Lisp này, đúng theo yêu cầu luôn.

>>

 

Không muốn dùng Block Attribute thì chơi Lisp này, đúng theo yêu cầu luôn.

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

;=====LISP UPDATE SO LIEU TU FILE TXT VAO CAD - REV1==========
;================KANGKUNG 25/03/2013==========================
(defun C:KK()
  (command "UNDO" "BE")
  (setq taphop(ssget '((0 . "TEXT"))) os(getvar "OSMODE"))
  (if (not Path) (setq Path(getvar "dwgprefix")))
  (setq file(getfiled "Select File:" Path "txt" 2) Path file index 0 TEXT_LIST (list))
  (while (< index (sslength taphop))
    (setq TEXT (entget (ssname taphop index)))
    (if (/= (read (cdr(assoc 1 TEXT))) (atof (cdr(assoc 1 TEXT))))
      (progn
	(setq String(cdr(assoc 1 TEXT)))
	(if (= (+ (cdr(assoc 72 TEXT)) (cdr(assoc 73 TEXT))) 0)
	  (setq InsertPoint(cdr(assoc 10 TEXT)))
	  (setq InsertPoint(cdr(assoc 11 TEXT))))
	(setq TEXT_LIST (append (list (list String InsertPoint)) TEXT_LIST))))
    (setq index (1+ index)))
  (setq file_in(open file "R") lst_solieu(list))
  (while(setq txt(read-line file_in))
    (if (/= txt nil) (setq lst (read (strcat "(" txt ")"  ))))
    (foreach dt TEXT_LIST
      (if (= (car dt) (vl-princ-to-string(car lst)))
	(progn
	  (setq pt1(cadr dt) pt2(list (- (car pt1) 1.0757) (- (cadr pt1) 1.3762)) pt3(list (+ (car pt1) 1.2744) (- (cadr pt1) 1.3762)) pt4(list (car pt1) (- (cadr pt1) 2.7500)))
	  (entmakex (list '(0 . "TEXT") (cons 8 "Main_DTOV") (cons 62 3) (cons 10 pt1) (cons 40 0.5) (cons 1 (vl-princ-to-string(car lst))) (cons 72 1) (cons 11 pt1) (cons 73 2)))
	  (entmakex (list '(0 . "TEXT") (cons 8 "Main_CDTC") (cons 62 130) (cons 10 pt2) (cons 40 0.5) (cons 1 (rtos (cadr lst) 2 2)) (cons 72 1) (cons 11 pt2) (cons 73 2)))
	  (entmakex (list '(0 . "TEXT") (cons 8 "Main_DTOV") (cons 62 2) (cons 10 pt3) (cons 40 0.5) (cons 1 (rtos (caddr lst) 2 2)) (cons 72 1) (cons 11 pt3) (cons 73 2)))
	  (entmakex (list '(0 . "TEXT") (cons 8 "Main_KLOV") (cons 62 31) (cons 10 pt4) (cons 40 0.5) (cons 1 (rtos (cadddr lst) 2 2)) (cons 72 1) (cons 11 pt4) (cons 73 2)))
	  )
	)
      )
    )
  (COMMAND "ERASE" TAPHOP "")
  (close file_in)
  (command "UNDO" "END")
  )
(princ "\n                Written By KangKung - 25/03/2013\n")
(princ "\n                  Nhap KK de chay chuong trinh\n")

Bạn cho mình xin hởi: nếu nình muốn up thêm 2 cột nửa ở cuối thì phải bổ sung những lệnh ở hàng nào vậy KangKung?

Mong được Bạn chỉ giúp.

<<