Jump to content
InfoFile
Tác giả: duy782006
Bài viết gốc: 409753
Tên lệnh: vtt
Lisp Tạo Text

Viết lisp bạn chạy thử được ko rồi mông má em nó sau:

Yêu cầu trong ban vẽ bạn có sẳn style text tên là ARI và style text này có font là arial (theo ý bạn) hoặc font unicode nào đó.

>>

Viết lisp bạn chạy thử được ko rồi mông má em nó sau:

Yêu cầu trong ban vẽ bạn có sẳn style text tên là ARI và style text này có font là arial (theo ý bạn) hoặc font unicode nào đó.

Lisp lệnh là vtt. sẽ viết ra 1 text có nội dung là MẶT BẰNG TÔN MÁI tại điểm pick. Nếu chạy được thì tính tiếp.

(defun c:vtt ()
(setq d (getpoint "Diem viet text"))
(entmake (list (cons 0 "TEXT")(cons 10 d)(cons 11 d)(cons 40 2)(cons 50 0)(cons 72 0)(cons 1 "M\U+1EB6T B\U+1EB0NG TÔN MÁI")(cons 7 "ARI")(cons 8 (getvar "Clayer"))(cons 62 256))) 
(princ)
)

<<

Filename: 409753_vtt.lsp
Tác giả: Kieu Tan
Bài viết gốc: 409763
Tên lệnh: mb
Lisp Tạo Text

 

Viết lisp bạn chạy thử được ko rồi mông má em nó sau:

Yêu cầu trong ban vẽ bạn có sẳn style text tên là ARI và style text này có font là arial (theo ý...

>>

 

Viết lisp bạn chạy thử được ko rồi mông má em nó sau:

Yêu cầu trong ban vẽ bạn có sẳn style text tên là ARI và style text này có font là arial (theo ý bạn) hoặc font unicode nào đó.

Lisp lệnh là vtt. sẽ viết ra 1 text có nội dung là MẶT BẰNG TÔN MÁI tại điểm pick. Nếu chạy được thì tính tiếp.

(defun c:vtt ()
(setq d (getpoint "Diem viet text"))
(entmake (list (cons 0 "TEXT")(cons 10 d)(cons 11 d)(cons 40 2)(cons 50 0)(cons 72 0)(cons 1 "M\U+1EB6T B\U+1EB0NG TÔN MÁI")(cons 7 "ARI")(cons 8 (getvar "Clayer"))(cons 62 256))) 
(princ)
)

thanks bạn duy782006 !

Nhờ bạn mà mình đã tìm ra được nguyên nhân bị lỗi font và mình cũng đã tạo được lsp này:



(DEFUN C:MB (/ TILE P)
  (IF (= (TBLOBJNAME "STYLE" "ARIAL") NIL)
  	(command ".STYLE" "ARIAL" "ARIAL TUR" "" "" "" "" "" "")
    )
  (SETQ
	tile (getint "\nTi le: ")
	p (getpoint "\nDiem dat text: ")
	)
  (COMMAND "TEXT" "S" "ARIAL" "J" "TL" P (* TILE 2) "0" "%%UM\U+1EB6T B\U+1EB0NG TÔN MÁI"
	   "TEXT" "S" "ARIAL" "J" "TL" (POLAR P (/ PI -2) (* 3.5 TILE )) (* TILE 1.5) "0" "%%UM\U+1EB6T B\U+1EB0NG MÓNG"
	   	   
           )
)
Và mình chưa hiểu các bỏ dấu kiểu này nên nhờ bạn chỉ mình cách bỏ dấu kiểu này với:
M\U+1EB6T B\U+1EB0NG : MẶT BẰNG


<<

Filename: 409763_mb.lsp
Tác giả: Bee
Bài viết gốc: 409823
Tên lệnh: t2
Sửa Lisp Thêm Dung Sai Cho Kích Thước Có Sẵn

Bee cho mình hỏi thêm chút, nếu kích thước cần đo có tỷ lệ 1:1 thì lisp trên của Bee ok. Tuy nhiên mình nhận thấy nếu để tỷ lệ kích thước khác thì khi dùng lisp nó sẽ nhảy về kích thước với tỷ lệ 1:1 . Vậy Bee có thể giúp mình để tình trạng trên ko xảy ra nữa ko
Thanks...

>>

Bee cho mình hỏi thêm chút, nếu kích thước cần đo có tỷ lệ 1:1 thì lisp trên của Bee ok. Tuy nhiên mình nhận thấy nếu để tỷ lệ kích thước khác thì khi dùng lisp nó sẽ nhảy về kích thước với tỷ lệ 1:1 . Vậy Bee có thể giúp mình để tình trạng trên ko xảy ra nữa ko
Thanks :)

Update nhé. 

Chắc là chạy ngon 

^_^

(defun c:T2 (/ ss dimtp dimtm n scl old)
  (setq old (getvar "DIMLFAC"))
  (if (setq ss (ssget '((0 . "DIMENSION"))))
    (progn
      (setq dimtp (getreal "\nChon gia tri dimtp <0.02>: "))
      (if (not dimtp)
	(setq dimtp 0.02)
	)
      (setq dimtm (getreal "\nChon gia tri dimtm <0.02>: "))
      (if (not dimtm)
	(setq dimtm 0.02)
	)
      (setq n 0)
      (repeat (sslength ss)
	(setq scl (vlax-get (vlax-ename->vla-object (ssname ss n)) 'LinearScaleFactor))
	(setvar "DIMLFAC" scl)
	(if (/= (getvar 'dimstyle) (cdr (assoc 3 (entget (ssname ss n)))))
	  (command "dimstyle" "r" (cdr (assoc 3 (entget (ssname ss n)))))
	  )
	(command "dimtol" "on")
	(command "dimtp" dimtp)
	(command "dimtm" dimtm)	
	(command "dim" "update" (ssname ss n) "" "exit")
	(command "dimtol" "off")
	(setq n (1+ n))
	)
      )
    (princ "\nBan da khong chon DIM.")
    )
  (setvar "DIMLFAC" old)
  (princ)
  ) 

<<

Filename: 409823_t2.lsp
Tác giả: Bee
Bài viết gốc: 409862
Tên lệnh: t3
Sửa Lisp Thêm Dung Sai Cho Kích Thước Có Sẵn

Chạy ổn lắm, thanks Bee nhé. Mình hỏi ngược lại chút, nhé :P
Nếu mình đã có các kích thước có dung sai khác nhau rồi và tất cả đang ở tỷ lệ 1:1. Giờ mình muốn chuyển toàn bộ kích thước đó sang tỷ lệ nào đó khác (cái này do mình nhập) mà đống dung sai vẫn còn và ko thay đổi thì sao  ^_^ ...

>>

Chạy ổn lắm, thanks Bee nhé. Mình hỏi ngược lại chút, nhé :P
Nếu mình đã có các kích thước có dung sai khác nhau rồi và tất cả đang ở tỷ lệ 1:1. Giờ mình muốn chuyển toàn bộ kích thước đó sang tỷ lệ nào đó khác (cái này do mình nhập) mà đống dung sai vẫn còn và ko thay đổi thì sao  ^_^  ^_^  ^_^
Cái này có thể làm lisp riêng ko dính vào lisp trên cho mình nhé, thanks Bee

Loanh quanh nhỉ ^_^ Thử cái này nhé

 (defun c:T3 (/ ss dimtp dimtm n scl old)
   (setq old (getvar "DIMLFAC"))
   (if (setq ss (ssget '((0 . "DIMENSION"))))
     (progn
      (setq scl (getreal "\nChon ti le: "))
      (if (not scl)
	(setq scl 1.)
	)
      (setq n 0)
      (repeat (sslength ss)
        (setq dimtm (vlax-get (vlax-ename->vla-object (ssname ss n)) 'ToleranceLowerLimit))
        (setq dimtp (vlax-get (vlax-ename->vla-object (ssname ss n)) 'ToleranceUpperLimit))
        (setvar "DIMLFAC" scl)
        (if (/= (getvar 'dimstyle) (cdr (assoc 3 (entget (ssname ss n)))))
	  (command "dimstyle" "r" (cdr (assoc 3 (entget (ssname ss n)))))
	  )
	(command "dimtol" "on")
	(command "dimtp" dimtp)
	(command "dimtm" dimtm)	
	(command "dim" "update" (ssname ss n) "" "exit")
	(command "dimtol" "off")
	(setq n (1+ n))
	)
      )
    (princ "\nBan da khong chon DIM.")
    )
  (setvar "DIMLFAC" old)
  (princ)
  ) 

<<

Filename: 409862_t3.lsp
Tác giả: Bee
Bài viết gốc: 409868
Tên lệnh: t3
Sửa Lisp Thêm Dung Sai Cho Kích Thước Có Sẵn

Hi Bee

Đây là kết quả sau khi dùng lisp của bạn

https://drive.google.com/file/d/0B-gIuhLk2Nw1bm5TMVVuaGpHblU/view?usp=sharing

Với các kích thước đã có dung sai thì kết quả rất ok. Tuy nhiên với kích thước cuối ko...

>>

Hi Bee

Đây là kết quả sau khi dùng lisp của bạn

https://drive.google.com/file/d/0B-gIuhLk2Nw1bm5TMVVuaGpHblU/view?usp=sharing

Với các kích thước đã có dung sai thì kết quả rất ok. Tuy nhiên với kích thước cuối ko có dung sai thì xảy ra lỗi bị nhảy ra dung sai như trên hình vẽ. Bee xem lại giúp mình xem nhé. Thanks

fix dim ko dung sai. ^_^

 (defun c:T3 (/ ss dimtp dimtm n scl old)
   (setq old (getvar "DIMLFAC"))
   (if (setq ss (ssget '((0 . "DIMENSION"))))
     (progn
      (setq scl (getreal "\nChon ti le: "))
      (if (not scl)
	(setq scl 1.)
	)
      (setq n 0)
      (repeat (sslength ss)
        (setq dimtm (vlax-get (vlax-ename->vla-object (ssname ss n)) 'ToleranceLowerLimit))
        (setq dimtp (vlax-get (vlax-ename->vla-object (ssname ss n)) 'ToleranceUpperLimit))
        (setvar "DIMLFAC" scl)
        (if (and (= dimtm 0.0)
                 (= dimtp 0.0)
                 )
          (progn
            (command "dimtol" "off")
            (command "dim" "update" (ssname ss n) "" "exit")
            )
          (progn
            (if (/= (getvar 'dimstyle) (cdr (assoc 3 (entget (ssname ss n)))))
              (command "dimstyle" "r" (cdr (assoc 3 (entget (ssname ss n)))))
              )
            (command "dimtol" "on")
            (command "dimtp" dimtp)
            (command "dimtm" dimtm)
            (command "dim" "update" (ssname ss n) "" "exit")
            (command "dimtol" "off")
            )
          )
	(setq n (1+ n))
	)
      )
    (princ "\nBan da khong chon DIM.")
    )
  (setvar "DIMLFAC" old)
  (princ)
  ) 
       

<<

Filename: 409868_t3.lsp
Tác giả: ketxu
Bài viết gốc: 409867
Tên lệnh: lbl
Lisp Tạo Trục Đối Xứng Cách Đều 2 Đường Cho Trước
(defun c:LBL (/ foo AT:GetSel _pnts _pline _lwpline _dist e1 e2)
 (vl-load-com)
 (defun foo (e)
  (and (wcmatch (cdr (assoc 0 (entget (car e)))) "LINE,*POLYLINE,SPLINE")
   (not (vlax-curve-isClosed (car e)))))
 (defun AT:GetSel (meth msg fnc / ent)
  (while
   (progn
    (setvar 'ERRNO 0)
    (setq ent (meth (cond (msg) ("\nSelect object: "))))
    (cond
   ((eq (getvar 'ERRNO)...
>>
(defun c:LBL (/ foo AT:GetSel _pnts _pline _lwpline _dist e1 e2)
 (vl-load-com)
 (defun foo (e)
  (and (wcmatch (cdr (assoc 0 (entget (car e)))) "LINE,*POLYLINE,SPLINE")
   (not (vlax-curve-isClosed (car e)))))
 (defun AT:GetSel (meth msg fnc / ent)
  (while
   (progn
    (setvar 'ERRNO 0)
    (setq ent (meth (cond (msg) ("\nSelect object: "))))
    (cond
   ((eq (getvar 'ERRNO) 7) (princ "\nMissed, try again."))
     ((eq (type (car ent)) 'ENAME)
      (if (and fnc (not (fnc ent)))
       (princ "\nInvalid object!"))))))
  ent)
 (defun _pnts (e / p l)
  (if e
   (cond
    ((wcmatch (cdr (assoc 0 (entget e))) "ARC,LINE,SPLINE")
     (list (vlax-curve-getStartPoint e) (vlax-curve-getEndPoint e)))
    ((wcmatch (cdr (assoc 0 (entget e))) "*POLYLINE")
     (repeat (setq p (1+ (fix (vlax-curve-getEndParam e))))
      (setq l (cons (vlax-curve-getPointAtParam e (setq p (1- p))) l)))))))
 (defun _pline (lst)
  (if
   (and
    (> (length lst) 1)
    (entmakex '((0 . "POLYLINE") (10 0. 0. 0.) (70 . 8)))
    (foreach x lst (entmakex (list '(0 . "VERTEX") (cons 10 x) '(70 . 32)))))
   (cdr (assoc 330 (entget (entmakex '((0 . "SEQEND"))))))))
 (defun _lwpline (lst)
  (if (> (length lst) 1)
   (entmakex (append
     (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst)) (cons 70 (* (getvar 'plinegen) 128)))
     (mapcar (function (lambda (p) (list 10 (car p) (cadr p)))) lst)))))
 (defun _dist (a b)
  (distance (list (car a) (cadr a)) (list (car b) (cadr b))))
  (if
   (and
    (setq e1 (_pnts (car (AT:GetSel entsel "\nSelect first open curve: " foo))))
    (setq e2 (_pnts (car (AT:GetSel entsel "\nSelect next open curve: " foo))))
    (not (initget 0 "Lwpolyline Polyline"))
    (setq *LBL:Opt* (cond ((getkword (strcat "\nSpecify line to draw: [Lwpolyline/Polyline] <" (cond (*LBL:Opt*) ((setq *LBL:Opt* "Lwpolyline"))) ">: "))) (*LBL:Opt*))))
   ((if (eq *LBL:Opt* "Lwpolyline") _lwpline _pline)
    (vl-remove nil
     (mapcar (function (lambda(a b) 
   (if (and a b (not (grdraw (trans a 0 1) (trans b 0 1) 1 1)))
    (mapcar (function (lambda (a b) (/ (+ a b) 2.))) a b))))
       e1
      (if (< (_dist (car e1) (car e2)) (_dist (car e1) (last e2))) e2 (reverse e2))))))
 (princ))

<<

Filename: 409867_lbl.lsp
Tác giả: Tue_NV
Bài viết gốc: 409527
Tên lệnh: ttt
Tự Động Ghi Chú Đoạn Thẳng Theo Thứ Tự Tăng Dần

Vẫn không được bác ạ, chọn sai là kết thúc luôn

 

Bạn thử laị code này. Chọn sai cho chọn lại. Chọn kiểu select object. Cho phép chọn 1 lần nhiều đối tượng

(defun attfill (Lobjfind Lrep) (mapcar '(lambda(x y) (vlax-put x 'textstring y)) Lobjfind Lrep...
>>

Vẫn không được bác ạ, chọn sai là kết thúc luôn

 

Bạn thử laị code này. Chọn sai cho chọn lại. Chọn kiểu select object. Cho phép chọn 1 lần nhiều đối tượng

(defun attfill (Lobjfind Lrep) (mapcar '(lambda(x y) (vlax-put x 'textstring y)) Lobjfind Lrep ))
(defun Tue-geom-divpt (p1 p2 k) (polar p1 (angle p1 p2) (* (distance p1 p2) k)))
(defun c:ttt(/ i  tto ename lst-length ss ename lst-re kq ls-kq ttu)
(setq tto (getstring t "\nNhap tien to :")) (setq ttu (getint "\nThu tu :") ttu0 ttu )
  (while (setq ss (ssget '((0 . "*LINE"))))
    (setq i -1)
  (while (setq ename (ssname ss (setq i (1+ i))))
 
       (setq L-length (vlax-curve-getDistAtPoint ename (vlax-curve-getEndPoint ename)))
    (if (null (member L-length lst-length))
        (setq kq (strcat tto (if (< ttu 10) (strcat "0" (itoa ttu)) (itoa ttu)))
              lst-length (append lst-length (list L-length)) ttu (1+ ttu))
        (setq vitri (VL-POSITION L-length lst-length)
              kq (strcat tto (if (< (+ ttu0 vitri) 10) (strcat "0" (itoa (+ ttu0 vitri))) (itoa (+ ttu0 vitri))))
        )
    )  
        (attfill (vlax-invoke (vla-InsertBlock (vla-get-modelspace (vla-get-ActiveDocument (vlax-get-acad-object)))
         (vlax-3d-point (Tue-geom-divpt (vlax-curve-getstartPoint ename) (vlax-curve-getEndPoint ename) 0.5))
        "BlockKH" 1 1 1 0) 'getattributes)
         (list "GOC" (rtos L-length 2 0) kq)
    )
  )
    )
(princ)
)

<<

Filename: 409527_ttt.lsp
Tác giả: Bee
Bài viết gốc: 409962
Tên lệnh: test
Nhờ Viết Lisp Chọn Text

Mong các bác khai đao giúp em ca này với ạ.

- Em muốn chọn các text (gồm cả text chữ và số) có cùng độ cao text, style text giống nhau.

- Bước 1 chọn text mẫu, bước 2 chọn text trong vùng chọn, nghiệm trả về là các text có cùng độ cao text và style text.( Do là em đang sửa 1 bản vẽ có rất nhiều text...

>>

Mong các bác khai đao giúp em ca này với ạ.

- Em muốn chọn các text (gồm cả text chữ và số) có cùng độ cao text, style text giống nhau.

- Bước 1 chọn text mẫu, bước 2 chọn text trong vùng chọn, nghiệm trả về là các text có cùng độ cao text và style text.( Do là em đang sửa 1 bản vẽ có rất nhiều text không đạt chiều cao, khi in ra rất nhỏ, em cũng có thể chọn các text bằng lệnh Fi, nhưng như vậy sẽ thêm 1 số thao tác, do khối lượng công việc khá lớn nên mạo muội nhờ các bác nhón tay giúp đỡ). Em xin chân thành cảm ơn các bác.

Thử lisp này nhé. Thay dòng redraw bằng lệnh cần dùng.^_^

(defun c:test (/ txt )
  (if (not (setq txt (car (entsel "\nChon text mau: "))))
    (princ "\nBan da khong chon text mau!")
    (progn
       (if (not (setq ss	(ssget (list (cons 0 "TEXT")
				     (assoc 40 (entget txt))
				     (assoc 7 (entget txt))
			       )
			)
	       )
	  )
	(princ "\Ban da khong chon text.")
	(mapcar
	  '(lambda (o)
	     (redraw o 3)
	   )
	  (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
	)

      )
    )
  )
  (princ)
)

<<

Filename: 409962_test.lsp
Tác giả: Bee
Bài viết gốc: 409981
Tên lệnh: attdef2text
Xin lisp chuyển text thuộc tính att thành text thường

Xin Khẩn!!

 

Xin lisp chuyển Text Att đã bị explode (chứ không phải dùng lệnh Burst) Thành Text thường

 

Giải thích thêm Text ATT đã đc tạo block, Có 2 trường hợp...

>>

Xin Khẩn!!

 

Xin lisp chuyển Text Att đã bị explode (chứ không phải dùng lệnh Burst) Thành Text thường

 

Giải thích thêm Text ATT đã đc tạo block, Có 2 trường hợp explode:

 

1- Text Att bị Explode bằng lệnh EX thì text này không còn là text thường nữa. VD: ta dùng lisp đánh số thứ tự cho text att này thì số không tăng dần đc

 

2- Text Att bị Explode bằng lệnh Burst thì text thường. VD: ta dùng lisp đánh số thứ tự cho text att này thì số tăng dần đc

 

Xin cảm ơn các anh chị diễn đàn cho xin lisp sớm.

Hỏi ảnh GO trước đi. Heizz. Code này ngon nhé.^_^

(defun c:AttDef2Text ( / ss )
  ;; © Lee Mac  ~  01.06.10
  (vl-load-com)

  (if (setq ss (ssget "_:L" '((0 . "ATTDEF"))))
    (
      (lambda ( i / e o )
        (while (setq e (ssname ss (setq i (1+ i))))
          (if
            (
              (if (and (vlax-property-available-p
                         (setq o (vlax-ename->vla-object e)) 'MTextAttribute)
                       (eq :vlax-true (vla-get-MTextAttribute o)))

                MAttDef2MText AttDef2Text
              )
              (entget e)
            )
            (entdel e)
          )
        )
      )
      -1
    )
  )
  (princ)
)

(defun AttDef2Text ( eLst / dx74 dx2 )
  ;; © Lee Mac  ~  01.06.10

  (setq dx74 (cdr (assoc 74 eLst)) dx2 (cdr (assoc 2 eLst)))

  (entmake
    (append '( (0 . "TEXT") ) (RemovePairs '(0 100 1 2 3 73 74 70 280) eLst)
      (list
        (cons 73 dx74)
        (cons  1  dx2)
      )
    )
  )
)

(defun MAttDef2MText ( eLst )
  ;; © Lee Mac  ~  01.06.10

  (entmake
    (append '( (0 . "MTEXT") (100 . "AcDbEntity") (100 . "AcDbMText") )
      (RemoveFirstPairs '(40 50 41 7 71 72 71 72 73 10 11 11 210)
        (RemovePairs '(-1 102 330 360 5 0 100 101 1 2 3 42 43 51 74 70 280) eLst)
      )
      (list (cons 1 (cdr (assoc 2 eLst))))
    )
  )
)

(defun RemoveFirstPairs ( pairs lst )
  ;; © Lee Mac

  (defun foo ( pair lst )
    (if lst
      (if (eq pair (caar lst))
        (cdr lst)
        (cons (car lst) (foo pair (cdr lst)))
      )
    )
  )

  (foreach pair pairs
    (setq lst (foo pair lst))
  )
  lst
)


(defun RemovePairs ( pairs lst )
  ;; © Lee Mac
  (vl-remove-if
    (function
      (lambda ( pair )
        (vl-position (car pair) pairs)
      )
    )
    lst
  )
)

<<

Filename: 409981_attdef2text.lsp
Tác giả: Bee
Bài viết gốc: 409884
Tên lệnh: t3
Sửa Lisp Thêm Dung Sai Cho Kích Thước Có Sẵn

Thử lisp này xem thế nào. ^_^

(defun c:T3 (/ ss dimtp dimtm n scl old)
   (setq old (getvar...
>>

Thử lisp này xem thế nào. ^_^

(defun c:T3 (/ ss dimtp dimtm n scl old)
   (setq old (getvar "DIMLFAC"))
   (if (setq ss (ssget '((0 . "DIMENSION"))))
     (progn
      (setq scl (getreal "\nChon ti le: "))
      (if (not scl)
	(setq scl 1.)
	)
      (setq n 0)
      (repeat (sslength ss)
        (setq dimtm (vlax-get (vlax-ename->vla-object (ssname ss n)) 'ToleranceLowerLimit))
        (setq dimtp (vlax-get (vlax-ename->vla-object (ssname ss n)) 'ToleranceUpperLimit))
        (setvar "DIMLFAC" scl)
        (if (not (check (ssname ss n)))
          (progn
            (command "dimtol" "off")
            (command "dim" "update" (ssname ss n) "" "exit")
            )
          (progn
            (if (/= (getvar 'dimstyle) (cdr (assoc 3 (entget (ssname ss n)))))
              (command "dimstyle" "r" (cdr (assoc 3 (entget (ssname ss n)))))
              )
            (command "dimtol" "on")
            (command "dimtp" dimtp)
            (command "dimtm" dimtm)
            (command "dim" "update" (ssname ss n) "" "exit")
            (command "dimtol" "off")
            )
          )
	(setq n (1+ n))
	)
      )
    (princ "\nBan da khong chon DIM.")
    )
  (setvar "DIMLFAC" old)
  (princ)
  )
(defun check (ename / ss1 flag)
  (command "_explode" ename "")
  (setq ss1 (ssget "_P"))
  (mapcar '(lambda (o)
	     (if (wcmatch (cdr (assoc 0 (entget (cadr o)))) "MTEXT")
	       (if (wcmatch (cdr (assoc 1 (entget (cadr o)))) "*+*,*-*,*±*")
		 (setq flag T)
		 (setq flag nil)
		 )
	       )
	     )
	  (ssnamex ss1)
	  )
  (command "_undo" "")
  flag
  )

<<

Filename: 409884_t3.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 410108
Tên lệnh: tt
Lisp Nhân Chia Dim!
Có đọc bên Page, giúp bạn 1 cái (4 trong 1):
(defun c:tt (/ tongdim gandim fun tt1 tt2 ttf)
(defun tongdim (msg / ss ttd)
(setq ttd 0)
(princ msg)
(if (setq ss (ssget '((0 . "DIMENSION"))))
(foreach x (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(setq ttd (+ ttd
(cond ((distof (cdr (assoc 1 (entget x)))))
((cdr (assoc 42 (entget x))))))))
(setq ttd nil))
ttd)
(defun gandim (val / ent obj pre)
(and (setq ent (car (entsel (strcat "\nPick Dim de...
>>
Có đọc bên Page, giúp bạn 1 cái (4 trong 1):
(defun c:tt (/ tongdim gandim fun tt1 tt2 ttf)
(defun tongdim (msg / ss ttd)
(setq ttd 0)
(princ msg)
(if (setq ss (ssget '((0 . "DIMENSION"))))
(foreach x (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(setq ttd (+ ttd
(cond ((distof (cdr (assoc 1 (entget x)))))
((cdr (assoc 42 (entget x))))))))
(setq ttd nil))
ttd)
(defun gandim (val / ent obj pre)
(and (setq ent (car (entsel (strcat "\nPick Dim de gan <" (vl-princ-to-string val) ">: "))))
(eq (cdr (assoc 0 (entget ent))) "DIMENSION")
(setq pre (vla-get-PrimaryUnitsPrecision (setq obj (vlax-ename->vla-object ent))))
(vla-put-TextOverride obj (rtos val 2 pre))))
;; *** Main ***
(if (setq tt1 (tongdim "\nChon nhom thu Nhat !"))
(if (setq tt2 (tongdim "\nChon nhom thu Hai !"))
(progn (if (equal tt2 1e-13)
(progn (not (initget "+ - *")) (setq fun (getkword "\nPhep tinh ")))
(progn (not (initget "+ - * :")) (setq fun (getkword "\nPhep tinh "))))
(and (cond ((eq fun "+") (setq ttf (+ tt1 tt2)))
((eq fun "-") (setq ttf (- tt1 tt2)))
((eq fun "*") (setq ttf (* tt1 tt2)))
((eq fun ":") (and (not (zerop tt2)) (setq ttf (/ tt1 tt2)))))
(princ (strcat "\nKet qua: " (vl-princ-to-string ttf)))
(gandim ttf)))
(and (princ (strcat "\nKet qua tong dim chon lan 1: " (vl-princ-to-string tt1)))
(gandim tt1))))
(princ))
<<

Filename: 410108_tt.lsp
Tác giả: ginger
Bài viết gốc: 410092
Tên lệnh: ccc ttt
Lisp Nhân Chia Dim!
P/s : mình đã sửa bài cho bạn, khi copy code lisp thì cho vào tag Code bạn nhé 
@Ketxu
 
 
em copy được lisp cộng trừ dim trên mạng nhờ các bác sửa giúp thành lisp nhân chia dim ạ ! hoặc cho em xin lisp nhân chia dim cũng được ! em cảm ơn 

(defun c:ccc(/ ss n i S...
>>
P/s : mình đã sửa bài cho bạn, khi copy code lisp thì cho vào tag Code bạn nhé 
@Ketxu
 
 
em copy được lisp cộng trừ dim trên mạng nhờ các bác sửa giúp thành lisp nhân chia dim ạ ! hoặc cho em xin lisp nhân chia dim cũng được ! em cảm ơn 

(defun c:ccc(/ ss n i S duyet ent sst nt j St duyett entt Skq)
(prompt "\n Chon cac Dim cong:")
(setq ss (ssget '((0 . "DIMENSION"))))


(setq n (sslength ss) i 0 S 0 duyet 0)


(while (< i n)
(setq ent (entget(ssname ss i)))


(if (= (cdr(assoc 1 ent)) "")
(setq duyet (cdr(assoc 42 ent)))
(setq duyet (atof(cdr(assoc 1 ent))))
)
(setq S (+ S duyet))
(setq i (1+ i))
)




(alert (rtos S 2 0))


(princ)
)
(defun c:ttt(/ ss n i S duyet ent sst nt j St duyett entt Skq)
(prompt "\n Chon cac Dim lam so bi tru :")
(setq ss (ssget '((0 . "DIMENSION"))))


(prompt "\n Chon cac Dim lam so tru :")
(setq sst (ssget '((0 . "DIMENSION"))))


(setq n (sslength ss) i 0 S 0 duyet 0)
(setq nt (sslength sst) j 0 St 0 duyett 0)


(while (< i n)
(setq ent (entget(ssname ss i)))


(if (= (cdr(assoc 1 ent)) "")
(setq duyet (cdr(assoc 42 ent)))
(setq duyet (atof(cdr(assoc 1 ent))))
)
(setq S (+ S duyet))
(setq i (1+ i))
)


(while (< j nt)
(setq entt (entget(ssname sst j)))


(if (= (cdr(assoc 1 entt)) "")
(setq duyett (cdr(assoc 42 entt)))
(setq duyett (atof(cdr(assoc 1 entt))))
)
(setq St (+ St duyett))
(setq j (1+ j))
)


(setq Skq (- S St))


(alert (rtos Skq 2 0))


(princ)
)

<<

Filename: 410092_ccc_ttt.lsp
Tác giả: Bee
Bài viết gốc: 409964
Tên lệnh: test
Nhờ Viết Lisp Chọn Text

Cảm ơn bạn đã trợ giúp, Lisp dùng đúng như yêu cầu tớ đã nêu ở trên, nhưng ý mình muốn khi đã chọn được các text, mình nhấn " Ctrl+1 " để hiện bảng thuộc tính của text, mình có thể hiệu chỉnh các thông số của text trong bảng này, Lisp của bạn viết giúp thì lại chưa làm được việc này, Mong bạn...

>>

Cảm ơn bạn đã trợ giúp, Lisp dùng đúng như yêu cầu tớ đã nêu ở trên, nhưng ý mình muốn khi đã chọn được các text, mình nhấn " Ctrl+1 " để hiện bảng thuộc tính của text, mình có thể hiệu chỉnh các thông số của text trong bảng này, Lisp của bạn viết giúp thì lại chưa làm được việc này, Mong bạn sửa lại giúp mình 1 chút, Cám ơn bạn nhiều

 Thay mapcar thành command nhé ^_^

(defun c:test (/ txt)
  (if (not (setq txt (car (entsel "\nChon text mau: "))))
    (princ "\nBan da khong chon text mau!")
    (progn
      (if (not (setq ss	(ssget (list (cons 0 "TEXT")
				     (assoc 40 (entget txt))
				     (assoc 7 (entget txt))
			       )
			)
	       )
	  )
	(princ "\Ban da khong chon text.")
	(command "_Pselect" ss "")
      )
    )
  )
  (princ)
)

<<

Filename: 409964_test.lsp
Tác giả: Bee
Bài viết gốc: 410277
Tên lệnh: sumdim
Cộng Tất Cả Các Demension Trong Một Layer

Chào mọi người trong diễn đàn! Chả là e đang bốc khối lượng tường xây. Để giải trình với chủ đầu tư thì em phải dim tất cả kích thước ra rồi trừ cho phần lỗ mở của cửa xong nhập vào file tính. Em muốn kiểm tra chiều dài e nhập và chiều dài trong file cad. Có bác nào có autolisp tính tổng tất cả...

>>

Chào mọi người trong diễn đàn! Chả là e đang bốc khối lượng tường xây. Để giải trình với chủ đầu tư thì em phải dim tất cả kích thước ra rồi trừ cho phần lỗ mở của cửa xong nhập vào file tính. Em muốn kiểm tra chiều dài e nhập và chiều dài trong file cad. Có bác nào có autolisp tính tổng tất cả các demension trong cùng một layer ra tổng chiều dài không ạ!

Thử cái này xem nhé ^_^

(defun c:sumdim	(/ ss layer)

  (if (and (setq ss (car (entsel "\nChon 1 dim dien hinh layer: ")))
	   (eq (cdr (assoc 0 (entget ss))) "DIMENSION")
	   );and
    (progn
      (setq ss (ssget "_X"
		      (list (cons 0 "DIMENSION")
			    (setq layer (assoc 8 (entget ss)))
		      )
	       )
      );setq
      (alert
	(strcat	"Total Dim layer <" (cdr layer) ">: "
		(vl-princ-to-string
		  (apply '+
			 (mapcar 'vla-get-measurement
				 (mapcar 'vlax-ename->vla-object
					 (vl-remove-if
					   'listp
					   (mapcar 'cadr (ssnamex ss))
					 )
				 )
			 )
		  )
		)
	)
      )
    );progn then
    (princ "\nBan da khong chon dim.!")
  )
  (princ)
)
(vl-load-com)

 


<<

Filename: 410277_sumdim.lsp
Tác giả: Bee
Bài viết gốc: 409379
Tên lệnh: ge
Help Vấn Đề Group

 

Cách 1: Lôi họ hàng nhà group ra:  Tools--- Toolbars---- Autocad ---- Group. Đủ tiện ích của họ hàng nhà group cho bạn chọn.

Cách 2:

(defun c:AB ()
  (setvar "pickstyle" 0)(princ))
(defun c:AC ()
  (setvar "pickstyle"...
>>

 

Cách 1: Lôi họ hàng nhà group ra:  Tools--- Toolbars---- Autocad ---- Group. Đủ tiện ích của họ hàng nhà group cho bạn chọn.

Cách 2:

(defun c:AB ()
  (setvar "pickstyle" 0)(princ))
(defun c:AC ()
  (setvar "pickstyle" 1)(princ))

 

Cho 2 lệnh thành 1 như thế này tiện hơn ko e :)

(defun c:ge  ()
  (if (= (getvar "PICKSTYLE") 0)
    (setvar "PICKSTYLE" 1)
    (setvar "PICKSTYLE" 0))
  (princ)
  )

<<

Filename: 409379_ge.lsp
Tác giả: Bee
Bài viết gốc: 410293
Tên lệnh: sumdim1
Cộng Tất Cả Các Demension Trong Một Layer

hic, bác sửa lại code cho e với, em công nó ra không đúng 

Đã thêm trường hợp Dim sửa số và đã test.

Còn dim mà thêm các hậu tố tiền tố linh cu tinh thì trong trường hợp  này chắc không dùng. ^_^ Nếu cần dùng thì post chi tiết bản vẽ để mọi người check cho nhé.

>>

hic, bác sửa lại code cho e với, em công nó ra không đúng 

Đã thêm trường hợp Dim sửa số và đã test.

Còn dim mà thêm các hậu tố tiền tố linh cu tinh thì trong trường hợp  này chắc không dùng. ^_^ Nếu cần dùng thì post chi tiết bản vẽ để mọi người check cho nhé.

(defun c:sumdim1  (/ ss layer)
  (vl-load-com)
  (if (and (setq ss (car (entsel "\nChon 1 dim dien hinh layer: ")))
           (eq (cdr (assoc 0 (entget ss))) "DIMENSION")
           ) ;and
    (progn
      (setq ss (ssget "_X"
                      (list (cons 0 "DIMENSION")
                            (setq layer (assoc 8 (entget ss)))
                            )
                      )
            ) ;setq
      (alert
        (strcat "Total Dim layer <"
                (cdr layer)
                ">: "
                (vl-princ-to-string
                  (apply '+
                         (mapcar '(lambda (vla)
                                    (if (= "" (vlax-get vla 'TextOverride))
                                      (vlax-get vla 'Measurement)
                                      (distof (vlax-get vla 'TextOverride))
                                      )
                                    )
                                 (mapcar 'vlax-ename->vla-object
                                         (vl-remove-if
                                           'listp
                                           (mapcar 'cadr (ssnamex ss))
                                           )
                                         )
                                 )
                         )
                  )
                )
        )
      ) ;progn then
    (princ "\nBan da khong chon dim.!")
    )
  (princ)
  )
(princ)

<<

Filename: 410293_sumdim1.lsp
Tác giả: Bee
Bài viết gốc: 410347
Tên lệnh: ha1
Lisp lấy giá trị của dimenson, text và xuất ra file text

mình muốn xuất ra excel nhưng mỗi lần coppy nó chỉ được 1 cột
 nên mình phải coppy nhiều lần. Nhưng mình coppy nhiều lần mà dùng lips bác Hà thì mỗi lần nó lại tạo thêm 1 file nên mình muốn lips đơn giản chỉ ghi vào rồi mình tự paste ra excel

cám ơn bác trả lời mình nha

Xem...

>>

mình muốn xuất ra excel nhưng mỗi lần coppy nó chỉ được 1 cột
 nên mình phải coppy nhiều lần. Nhưng mình coppy nhiều lần mà dùng lips bác Hà thì mỗi lần nó lại tạo thêm 1 file nên mình muốn lips đơn giản chỉ ghi vào rồi mình tự paste ra excel

cám ơn bác trả lời mình nha

Xem phim hợp đồng hôn nhân xong thấy hài hài, code cho bạn nhé.

 

Đã chỉnh sửa chút xíu. CAD thế nào nó copy y nguyên, sang excel phải format cho đúng font nhé. ^_^

(defun C:HA1 (/ lst str txt 2ClipB)

  (vl-load-com)

  (princ "\nChon cac Text/Mtext/Dimension can copy..."
  )

  (setq lst (acet-ss-to-list (ssget '((0 . "*TEXT,DIMENSION")))))

  (setq str "")

  (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))))
       )
      )
    )

    (setq str (strcat str txt "\n"))
  )
  
  (vlax-invoke
    (vlax-get
      (vlax-get	(setq 2ClipB (vlax-create-object "htmlfile"))
		'ParentWindow
      )
      'ClipBoardData
    )
    'SetData
    "Text"
    str
  )
  (vlax-release-object 2ClipB)
)


<<

Filename: 410347_ha1.lsp
Tác giả: gia_bach
Bài viết gốc: 410364
Tên lệnh: sumdimbylayer
Cộng Tất Cả Các Demension Trong Một Layer

Một cách tiếp cận khác: tổng các dim sắp xếp theo Layer.

(defun c:sumDimByLayer  (/ asoc lst lay msg tOver)
  (vl-load-com)
  (if (ssget (list (cons 0 "DIMENSION")  )  )
    (progn		
      (vlax-for e (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-Acad-Object)))
	(setq lay (vla-get-Layer e)
	      len (if (= "" (setq tOver (vla-get-TextOverride e)))(vla-get-Measurement e)(distof tOver)))
	(if (setq asoc (assoc lay lst))
	 ...
>>

Một cách tiếp cận khác: tổng các dim sắp xếp theo Layer.

(defun c:sumDimByLayer  (/ asoc lst lay msg tOver)
  (vl-load-com)
  (if (ssget (list (cons 0 "DIMENSION")  )  )
    (progn		
      (vlax-for e (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-Acad-Object)))
	(setq lay (vla-get-Layer e)
	      len (if (= "" (setq tOver (vla-get-TextOverride e)))(vla-get-Measurement e)(distof tOver)))
	(if (setq asoc (assoc lay lst))
	    (setq lst (subst (cons lay (+ len (cdr asoc))) asoc lst))	    
	    (setq lst (append lst (list (cons lay len))) ))	)
      (setq msg "Total Dim by Layer :\n")
      (alert
	(foreach x lst (setq msg (strcat msg "\n" (car x) " = " (rtos (cdr x) 2 1)) ))  ) )
    (princ "\nBan da khong chon dim.!")    )
  (princ)  )

<<

Filename: 410364_sumdimbylayer.lsp
Tác giả: Bee
Bài viết gốc: 410412
Tên lệnh: test
Lisp điều chỉnh vị trí text ghi kích thước trên đường dim

Vấn đề move text Dim này cũng khá hay, mong mọi người giúp đỡ lisp này nhé.

 

Yêu cầu lisp bên trên cũng khá lằng nhằng, mong muốn của em nó đơn giản hơn chút:

 

- Chạy lisp, lisp yêu cầu chọn dãy dim cần dãn text trùng

+ Người dùng chọn dãy dim

- Lisp nhận diện các text...

>>

Vấn đề move text Dim này cũng khá hay, mong mọi người giúp đỡ lisp này nhé.

 

Yêu cầu lisp bên trên cũng khá lằng nhằng, mong muốn của em nó đơn giản hơn chút:

 

- Chạy lisp, lisp yêu cầu chọn dãy dim cần dãn text trùng

+ Người dùng chọn dãy dim

- Lisp nhận diện các text bị đè lên nhau và move text trùng xuống dưới hàng dim (khoảng cách move bằng 2 lần chiều cao text). Kết thúc lệnh

 

File ví dụ:

http://www.mediafire.com/file/4oczix0pcd0dred/Vidu2.dwg

Thử lisp này, thay lệnh test tùy ý nhé. ^_^

 

https://youtu.be/6NyEJFNnIwM

(defun c:test (/ ss lst _angle)
  (vl-load-com)
  (command "undo" "be")
  (if (setq ss (ssget '((0 . "DIMENSION"))))
    (progn
      (setq lst	(vl-remove-if
		  '(lambda (e) (> (cdr (assoc 42 (entget e))) 900.))
		  (vl-remove-if
		    'listp
		    (mapcar 'cadr (ssnamex ss))
		  )
		)
      )					;setq
      (setq _angle (angle (cdr (assoc 11 (entget (car lst))))
			  (cdr (assoc 11 (entget (cadr lst))))
		   )
      )
      (cond
	((or (= _angle 0)
	     (= _angle pi)
	 )
	 (dim_hor lst)
	)				;#cond1
	((or (= _angle (/ pi 2))
	     (= _angle (* pi 1.5))
	 )
	 (dim_ver lst)
	)				;#cond2
	(_angle
	 (dim_ lst _angle)
	)				;#cond3
      )					;#cond
    )					;progn
    (princ "\nBan da khong chon dim.!")
  )					;if
  (command "undo" "end")
  (princ)
)
(defun dim_hor (l / lst pt)
  (setq	lst (vl-sort l
		     '(lambda (e1 e2)
			(< (car (cdr (assoc 11 (entget e1))))
			   (car (cdr (assoc 11 (entget e2))))

			)
		      )
	    )
  )
  (foreach x lst
    (if	(= (rem (vl-position x lst) 2) 0)
      (progn
	(if (>=	(cadr (cdr (assoc 10 (entget x))))
		(cadr (cdr (assoc 14 (entget x))))
	    )

	  (setq	pt (polar (cdr (assoc 11 (entget x)))
			  (* pi 1.5)
			  (* 2 (txt_height x))
		   )
	  )
	  (setq	pt (polar (cdr (assoc 11 (entget x)))
			  (/ pi 2)
			  (* 2 (txt_height x))
		   )
	  )
	)
	(vlax-put (vlax-ename->vla-object x) 'TextPosition pt)
      )					;progn
    )					;if
  )					;foreach
)					;defun
(defun dim_ver (l / lst pt)
  (setq	lst (vl-sort l
		     '(lambda (e1 e2)
			(< (cadr (cdr (assoc 11 (entget e1))))
			   (cadr (cdr (assoc 11 (entget e2))))

			)
		      )
	    )
  )
  (foreach x lst
    (if	(= (rem (vl-position x lst) 2) 0)
      (progn
	(if (>=	(car (cdr (assoc 10 (entget x))))
		(car (cdr (assoc 14 (entget x))))
	    )

	  (setq	pt (polar (cdr (assoc 11 (entget x)))
			  pi
			  (* 2 (txt_height x))
		   )
	  )
	  (setq	pt (polar (cdr (assoc 11 (entget x)))
			  0.0
			  (* 2 (txt_height x))
		   )
	  )
	)
	(vlax-put (vlax-ename->vla-object x) 'TextPosition pt)
      )					;progn
    )					;if
  )					;foreach
)
(defun dim_ (l ang / lst pt)
  (setq	lst (vl-sort l
		     '(lambda (e1 e2)
			(< (cadr (cdr (assoc 11 (entget e1))))
			   (cadr (cdr (assoc 11 (entget e2))))

			)
		      )
	    )
  )
  (foreach x lst
    (if	(= (rem (vl-position x lst) 2) 0)
      (progn
	(if (>=	(car (cdr (assoc 10 (entget x))))
		(car (cdr (assoc 14 (entget x))))
	    )

	  (setq	pt (polar (cdr (assoc 11 (entget x)))
			  (+ ang (* pi 1.5))
			  (* 2 (txt_height x))
		   )
	  )
	  (setq	pt (polar (cdr (assoc 11 (entget x)))
			  (+ ang (* pi 1.5))
			  (* 2 (txt_height x))
		   )
	  )
	)
	(vlax-put (vlax-ename->vla-object x) 'TextPosition pt)
      )					;progn
    )					;if
  )					;foreach
)
(defun txt_height (ename / BlkEnt EntData height)
  (if
    (and
      (= (cdr (assoc 0 (setq EntData (entget ename))))
	 "DIMENSION"
      )
      (setq BlkEnt (tblobjname "block" (cdr (assoc 2 EntData))))
    )
     (while (setq BlkEnt (entnext BlkEnt))
       (if (= (cdr (assoc 0 (setq EntData (entget BlkEnt)))) "MTEXT")
	 (setq height (cdr (assoc 40 EntData)))
       )
     )
  )
  height
)
(princ)

<<

Filename: 410412_test.lsp
Tác giả: k_victory
Bài viết gốc: 16104
Tên lệnh: test
ACAD đời mới chạy trên máy đời cũ

Dạ thưa anh vì nó cứ bắt điểm lung tung, gây khó khăn trong việc thực hiện replay lệnh.Anh bỏ được thì giúp em đi, cám ơn anh lắm lắm!

Filename: 16104_test.lsp

Trang 214/330

214