- page 210

Info

File

Tác giả: Tot77
Bài viết gốc: 406643
Tên lệnh: tes

Vẽ Đường Đồng Mức Từ Text Độ Cao Trong Bản Vẽ

Bạn thử cái này, có điều tôi không hiểu là file text xep theo thứ tự y x z chứ không phải x y z.

(defun c:tes(/ dong toado file)
(defun dxf (id v) (cdr (assoc id (entget v))))
 
(setvar 'dimzin 2)
(prompt "\nChon file text:")
(setq file (open (getfiled "Open file" (getvar "dwgprefix") "txt" 4) "r"))
(if (not txtmau) (setq txtmau (car (entsel "\nChon text mau:"))))
(while (setq dong (read-line file))
(while...
>>

Bạn thử cái này, có điều tôi không hiểu là file text xep theo thứ tự y x z chứ không phải x y z.

(defun c:tes(/ dong toado file)
(defun dxf (id v) (cdr (assoc id (entget v))))
 
(setvar 'dimzin 2)
(prompt "\nChon file text:")
(setq file (open (getfiled "Open file" (getvar "dwgprefix") "txt" 4) "r"))
(if (not txtmau) (setq txtmau (car (entsel "\nChon text mau:"))))
(while (setq dong (read-line file))
(while (vl-string-search "\t" dong) (setq dong (vl-string-subst " " "\t" dong)))
(setq toado (cdr (read (strcat "(" dong ")")))
toado (list (cadr toado) (car toado) (last toado)))
(entmakex (list (cons 0 "TEXT") (cons 10 toado) (cons 11 toado) (cons 62 (dxf 62 txtmau))
(cons 40 (dxf 40 txtmau)) (cons 41 (dxf 41 txtmau)) (cons 7 (dxf 7 txtmau))
(cons 72 (dxf 72 txtmau)) (cons 73 (dxf 73 txtmau))
(cons 50 0) (cons 1 (rtos (last toado) 2 2)) (cons 8 (dxf 8 txtmau)))) 
)
(close file)
)

Download lisp

Filename: 406643_tes.lsp

Tác giả: taipham
Bài viết gốc: 406759
Tên lệnh: vtt

Nhờ Thêm Vòng Lặp Vào Lisp

Em đang tập tành autolisp, không biết thêm vòng lặp while vào chỗ nào để lisp sau khi nhập chiều dài đoạn mút thì chọn liên liếp các line, hoặc chọn liên tiếp các pline, hoặc chọn liên tiếp 2 điểm để vẽ.

Nhờ anh chị trong diễn đàn giúp đỡ. Xin cảm ơn!

(defun C:VTT()
(command "undo" "be")
  (setq cmd (getvar "cmdecho")
	osm (getvar "osmode"))
  (setvar "cmdecho" 0)
  (or (and...
>>

Nhờ anh chị trong diễn đàn giúp đỡ. Xin cảm ơn!

(defun C:VTT()
(command "undo" "be")
  (setq cmd (getvar "cmdecho")
	osm (getvar "osmode"))
  (setvar "cmdecho" 0)
  (or (and mut (or (= (type mut) 'int) (= (type mut) 'real))) (setq mut 30)) 
  (setq mut (cond ((getdist (strcat "\nChieu dai doan mu <" (rtos mut 2 2) ">: "))) (mut)))
  (setq dt (entsel "\nChon duong thang: "))
  (if
    (= dt nil)
	(progn
	(setq p1 (getpoint "\nChon diem dau")
	      p2 (getpoint p1 "\nChon diem cuoi")))
    (if
      (= "LWPOLYLINE" (cdr (assoc 0 (entget (car dt)))))
      (progn
	(setq pt (acet-geom-vertex-list (car dt))
	   p1 (car pt)
	   p2 (last pt)))
      (if
	(= "LINE" (cdr (assoc 0 (entget (car dt)))))
	(progn
        (setq dt (car dt)
	   dt (entget dt)
	   p1 (cdr (assoc 10 dt))
	   p2 (cdr (assoc 11 dt))))
	(princ "\nChon sai"))))
  (setvar "osmode" 0)
  (setq	p3 (polar p1 (+ pi (angle p1 p2)) mut)
	p4 (polar p2 (angle p1 p2) mut))
  (command ".mline" p3 p4 "")
  (setvar "osmode" osm)
  (setvar "cmdecho" cmd)
  (command "undo" "e")
  (princ))

Download lisp

Filename: 406759_vtt.lsp

Tác giả: tien2005
Bài viết gốc: 406761
Tên lệnh: vtt

Nhờ Thêm Vòng Lặp Vào Lisp

Bạn cần phải khử biến sau khi kết thúc lệnh, thêm các kiểm tra để tránh lỗi, rút ngắn câu lệnh, lisp sau chỉ thêm vòng lặp thêm yêu cầu

(defun C:VTT()
(command "undo" "be")
  (setq cmd (getvar "cmdecho")
	osm (getvar "osmode"))
  (setvar "cmdecho" 0)
  (or (and mut (or (= (type mut) 'int) (= (type mut) 'real))) (setq mut 30)) 
  (setq mut (cond ((getdist (strcat "\nChieu dai doan mu <" (rtos mut 2 2)...
>>

Bạn cần phải khử biến sau khi kết thúc lệnh, thêm các kiểm tra để tránh lỗi, rút ngắn câu lệnh, lisp sau chỉ thêm vòng lặp thêm yêu cầu

(defun C:VTT()
(command "undo" "be")
  (setq cmd (getvar "cmdecho")
	osm (getvar "osmode"))
  (setvar "cmdecho" 0)
  (or (and mut (or (= (type mut) 'int) (= (type mut) 'real))) (setq mut 30)) 
  (setq mut (cond ((getdist (strcat "\nChieu dai doan mu <" (rtos mut 2 2) ">: "))) (mut)))
  (while
    (or	(setq dt (entsel "\nChon duong thang: "))
	(and (setq p1 (getpoint "\nChon diem dau"))
	     (setq p2 (getpoint p1 "\nChon diem cuoi"))
	)
    )
  (if dt
;;;    (= dt nil)
;;;	(progn
;;;	(setq p1 (getpoint "\nChon diem dau")
;;;	      p2 (getpoint p1 "\nChon diem cuoi")))
    (if
      (= "LWPOLYLINE" (cdr (assoc 0 (entget (car dt)))))
      (progn
	(setq pt (acet-geom-vertex-list (car dt))
	   p1 (car pt)
	   p2 (last pt)))
      (if
	(= "LINE" (cdr (assoc 0 (entget (car dt)))))
	(progn
        (setq dt (car dt)
	   dt (entget dt)
	   p1 (cdr (assoc 10 dt))
	   p2 (cdr (assoc 11 dt))))
	(princ "\nChon sai")))
    )
  (setvar "osmode" 0)
  (setq	p3 (polar p1 (+ pi (angle p1 p2)) mut)
	p4 (polar p2 (angle p1 p2) mut))
  (command ".mline" p3 p4 "")
  (setvar "osmode" osm)
  );while
  (setvar "cmdecho" cmd)
  (command "undo" "e")
  (princ))

Download lisp

Filename: 406761_vtt.lsp

Tác giả: tien2005
Bài viết gốc: 406772
Tên lệnh: vtt

Nhờ Thêm Vòng Lặp Vào Lisp

(defun C:VTT()
(command "undo" "be")
  (setq cmd (getvar "cmdecho")
	osm (getvar "osmode"))
  (setvar "cmdecho" 0)
  (or (and mut (or (= (type mut) 'int) (= (type mut) 'real))) (setq mut 30)) 
  (setq mut (cond ((getdist (strcat "\nChieu dai doan mu <" (rtos mut 2 2) ">: "))) (mut)))
  (setq chk t)
  (while
    (or	(and chk
	  (setq dt (entsel "\nChon duong thang: "))
	    )
	(and (setq p1 (getpoint "\nChon diem dau"))
	     (setq p2 (getpoint p1...
>>

(defun C:VTT()
(command "undo" "be")
  (setq cmd (getvar "cmdecho")
	osm (getvar "osmode"))
  (setvar "cmdecho" 0)
  (or (and mut (or (= (type mut) 'int) (= (type mut) 'real))) (setq mut 30)) 
  (setq mut (cond ((getdist (strcat "\nChieu dai doan mu <" (rtos mut 2 2) ">: "))) (mut)))
  (setq chk t)
  (while
    (or	(and chk
	  (setq dt (entsel "\nChon duong thang: "))
	    )
	(and (setq p1 (getpoint "\nChon diem dau"))
	     (setq p2 (getpoint p1 "\nChon diem cuoi"))
	     (not (setq chk nil))
	)
    )
  (if dt
;;;    (= dt nil)
;;;	(progn
;;;	(setq p1 (getpoint "\nChon diem dau")
;;;	      p2 (getpoint p1 "\nChon diem cuoi")))
    (if
      (= "LWPOLYLINE" (cdr (assoc 0 (entget (car dt)))))
      (progn
	(setq pt (acet-geom-vertex-list (car dt))
	   p1 (car pt)
	   p2 (last pt)))
      (if
	(= "LINE" (cdr (assoc 0 (entget (car dt)))))
	(progn
        (setq dt (car dt)
	   dt (entget dt)
	   p1 (cdr (assoc 10 dt))
	   p2 (cdr (assoc 11 dt))))
	(princ "\nChon sai")))
    )
  (setvar "osmode" 0)
  (setq	p3 (polar p1 (+ pi (angle p1 p2)) mut)
	p4 (polar p2 (angle p1 p2) mut))
  (command ".mline" p3 p4 "")
  (setvar "osmode" osm)
  );while
  (setvar "cmdecho" cmd)
  (command "undo" "e")
  (princ))

dùng tạm cái này

Download lisp

Filename: 406772_vtt.lsp

Tác giả: phamthanhbinh
Bài viết gốc: 406826
Tên lệnh: vpl

(Nhờ Viết Lisp) Vẽ Polyline Qua Các Điểm Khi Biết Tọa Độ Tương Đối Với Điểm Gốc

bác nói đúng, thừa rồi ạ ^^ Bác Bình giúp em với được không ạ!

Hề hề hề,

Bạn thử cái này coi đúng ý chưa nhé. Lưu ý khi nhập DeltaX và DeltaY có thể nhập số âm thoe đúng giá trị tương đối với điểm gốc.

bác nói đúng, thừa rồi ạ ^^ Bác Bình giúp em với được không ạ!

Hề hề hề,

Bạn thử cái này coi đúng ý chưa nhé. Lưu ý khi nhập DeltaX và DeltaY có thể nhập số âm thoe đúng giá trị tương đối với điểm gốc.

http://www.cadviet.com/upfiles/6/5194_veduongtimthucte.lsp

(Defun c:vpl (/ p0 x0 y0 p1 x y p2)
(setq p0 (getpoint "\n Chon diem tim tuyen")
         x0 (car p0)
         y0 (cadr p0) 
         p1 (list (+ x0 (getreal "\n Nhap ly do diem dau: ")) (+ y0 (getreal "\n Nhap chenh cao diem dau: "))) )
(while (and (setq x (getreal "\n Nhap ly do diem tiep theo: ")) (setq y (getreal "\n Nhap chenh cao diem tiep theo : ")))
        (setq p2 (list (+ x0 x) (+ y0 y)))
        (command "pline" p1 p2 "")
        (setq p1 p2)
)
)

Download lisp

Filename: 406826_vpl.lsp

Tác giả: Kieu Tan
Bài viết gốc: 406359
Tên lệnh: tkt

Không Thống Kê Được Text Và Mtext Có Font Tiếng Việt

Mình có 1 lsp dùng để thống kê TEXT VÀ MTEXT nhưng nó chỉ thống kê được TEXT VÀ MTEXT không có dấu, nếu font có dấu thì sau khi thống kê nó bị lỗi font(font tiếng việt bị lỗi font). Mong mọi người giúp đỡ. Thanks các bạn!

(defun c:tkt  (/ lst msp pt ss str txtsiz-0 txtsiz doc)
  (vl-load-com)
  (if (setq ss (ssget (list (cons 0 "*TEXT"))))
    (progn (foreach e  (mapcar...
>>

(defun c:tkt  (/ lst msp pt ss str txtsiz-0 txtsiz doc)
  (vl-load-com)
  (if (setq ss (ssget (list (cons 0 "*TEXT"))))
    (progn (foreach e  (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
             (setq str      (vla-get-TextString e)
                   txtsiz-0 (vla-get-height e))
             (if (not (assoc str lst))
               (setq lst (cons (cons str 1) lst))
               (setq lst (subst (cons str (1+ (cdr (assoc str lst)))) (assoc str lst) lst))))
           (or (setq txtsiz (getreal (strcat "\nChieu cao Text trong bang thong ke <" (rtos txtsiz-0 2 2) ">: ")))
               (setq txtsiz txtsiz-0))
           (setq lst (vl-sort lst '(lambda (x y) (< (cdr x) (cdr y))))
                 pt  (getpoint "\nDiem dat Bang :")
                 doc (vla-get-ActiveDocument (vlax-get-Acad-Object))
                 msp (if (zerop (vla-get-activespace doc))
                       (if (= (vla-get-mspace doc) :vlax-true)
                         (vla-get-modelspace doc)
                         (vla-get-paperspace doc))
                       (vla-get-modelspace doc)))
           (foreach e  lst
             (vla-addtext msp (cdr e) (vlax-3d-point pt) txtsiz)
             (vla-addtext msp (car e) (vlax-3d-point (polar pt 0 (* 5 txtsiz))) txtsiz)
             (setq pt (polar pt (/ pi -2) (* 1.5 txtsiz)))))
    (alert "Khong chon duoc Text."))
  (princ))

Download lisp

Filename: 406359_tkt.lsp

Tác giả: jangboko
Bài viết gốc: 406752
Tên lệnh: tc td

Nhờ Chỉnh Sửa Lisp Replac Text

;=========================================================================
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=18049
(defun copy-add-text-content (mode / err oer sta res sel mtx dim chc chg
			      hig sor rdw dec temp
			      sou data)
;											
  (defun err(s)
    (if (and (/= s "Function cancelled")(/= s "quit / exit abort"))
      (princ (strcat "\n--->>...
>>

;=========================================================================
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=18049
(defun copy-add-text-content (mode / err oer sta res sel mtx dim chc chg
			      hig sor rdw dec temp
			      sou data)
;											
  (defun err(s)
    (if (and (/= s "Function cancelled")(/= s "quit / exit abort"))
      (princ (strcat "\n--->> Error: " s))
      )
    (res)
    )
;											
  (defun res()
    (if hig (setvar "HighLight" hig))
    (if sor (setvar "Sortents" sor))
    (if pst (setvar "Pickstyle" pst))
    (if rdw (chc 0))
    (command "_.Undo" "_End")
    (setq *error* oer)
    (setvar "Cmdecho" 1)
    (princ)
    )
;											
  (defun sta()
    (setq oer *error*
	  *error* err
	  hig (getvar "HighLight")
	  sor (getvar "Sortents")
	  pst (getvar "Pickstyle")
	  dec (getvar "Dimdec")
	  )
    (setvar "Cmdecho" 0)
    (command "_.Undo" "_Group")
    (setvar "HighLight" 1)
    (setvar "Sortents" 1)
    (setvar "Pickstyle" 0)
    (graphscr)
    )
;											
  (defun sel(/ loop lis typ intro)
    (if (null del-mode)(setq del-mode "0"))
    (if (null mat-mode)(setq mat-mode "0"))
    (setq loop T
	  lis '("TEXT" "MTEXT" "DIMENSION" "ARCALIGNEDTEXT")
	  )
    (if (= mode 0)
      (setq intro "\nSelect copy source text ")
      (setq intro "\nSelect additon source text ")
      )
    (while loop
      (initget "Exit Delete Match MD DM")
      ;(setq del T);;;
      (setq sou (entsel (strcat intro "[Delete source("del-mode")/Match properties("mat-mode")]: ")))
      (cond
	((= sou "Exit")(exit))
	((null sou)(exit))
	((= sou "Delete")
	 (if (= del-mode "0")
	   (setq del-mode "1")
	   (setq del-mode "0")
	   )
	 )
	((= sou "Match")
	  (if (= mat-mode "0")
	   (setq mat-mode "1")
	   (setq mat-mode "0")
	   )
	  )
	((or (= sou "MD")(= sou "DM"))
	  (progn
	    (if (= del-mode "0")
	      (setq del-mode "1")
	      (setq del-mode "0")
	      )
	    (if (= mat-mode "0")
	      (setq mat-mode "1")
	      (setq mat-mode "0")
	      )
	    )
	  )
	((progn
	   (setq data (entget (car sou))
		 typ (cdr (assoc 0 data))
		 )
	   (if (not (member typ lis))
	     (princ "Invalid selection.")
	     (progn
	       (setq temp (assoc 1 data)
		     loop nil
		     )
	       (cond
		 ((= typ "MTEXT")(mtx))
		 ((= typ "DIMENSION")(dim))
		 )
	       )
	     ); if end
	   ))
	); cond end
      )
    (chc 1)
    (setq rdw T)
    )
;											
  (defun mtx(/ con test)
    (setq con (cdr temp)
	  test (substr con 1 1)
	  )
    (if (= test "\\")(setq temp (cons 1 (substr con 5))))
    )
;											
  (defun dim(/ con)
    (setq con (cdr temp))
    (if (or (= con "")(= con "<>"))
      (setq temp (cons 1 (rtos (cdr (assoc 42 data)) 2 dec)))
      )
    )
;											
  (defun chc(mode / col)
    (cond
      ((and (= del-mode "1") (= mat-mode "0"))(setq col "230"))
      ((and (= del-mode "0") (= mat-mode "1"))(setq col "110"))
      ((and (= del-mode "1") (= mat-mode "1"))(setq col "30"))
      ((setq col "140"))
      )
    (if (= mode 0)
      (progn
	(command "_.Chprop" sou "" "_Color" "BYLAYER" "")
	(redraw (car sou) 4)
	)
      (progn
	(command "_.Chprop" sou "" "_Color" col "")
	(redraw (car sou) 3)
	)
      )
    )
;											
  (defun chg(/ ss inc data-)
    (if (= mode 0)
      (princ "\nSelect destiantion texts to change: ")
      (princ "\nSelect destiantion texts to add: ")
      )
    (setq ss (ssget '((-4 . "<OR")
		      (0 . "TEXT")(0 . "MTEXT")(0 . "DIMENSION")(0 . "ARCALIGNEDTEXT")
		      (-4 . "OR>")
		      )))
    (if (null ss)(exit))
    (setq inc 0)
    (repeat (sslength ss)
      (setq data- (entget (ssname ss inc))
	    inc (1+ inc))
      (if (= mode 1)
	(setq temp (cons 1 (strcat (cdr (assoc 1 data-)) "x" (cdr temp))))
	)
      (entmod (subst temp (assoc 1 data-) data-))
      )
    (if (= mat-mode "1")
      (progn
	(if rdw (chc 0))
	(command "_.MatchProp" sou ss "")
	)
      )
    (if (= del-mode "1")
      (progn
	(entdel (car sou))
	(setq rdw nil)
	)
      )
    )
;											
  (sta)
  (sel)
  (chg)
  (res)
  )

(defun c:TC()(copy-add-text-content 0))
(defun c:TD()(copy-add-text-content 1))
(princ)

em sưu tầm trên diễn đàn cái lisp replace text rất hay, làm việc khá hiệu quả với nó. Em muốn nó có thể làm việc được với block att, Bác nào rảnh tay giúp em với. Em xin cám ơn, Chúc các bác luôn mạnh khỏe.

Download lisp

Filename: 406752_tc_td.lsp

Tác giả: phamthanhbinh
Bài viết gốc: 406902
Tên lệnh: tc td

Nhờ Chỉnh Sửa Lisp Replac Text

Cảm ơn bác đã hồi âm, em muốn text đích là attribute. Mong bác ra tay giúp đỡ. Cảm ơn bác và anh em cộng đồng cadviet nhiều.

Hề hề hề,

Bạn dùng thủ cái này coi sao. Mình sửa lại một chút để có thể cả text nguồn và đích đều là các thuộc tính.

>>

Cảm ơn bác đã hồi âm, em muốn text đích là attribute. Mong bác ra tay giúp đỡ. Cảm ơn bác và anh em cộng đồng cadviet nhiều.

Hề hề hề,

Bạn dùng thủ cái này coi sao. Mình sửa lại một chút để có thể cả text nguồn và đích đều là các thuộc tính.

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/165503-nho-chinh-sua-lisp-replac-text/
;=========================================================================
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=18049
(defun copy-add-text-content (mode / err oer sta res sel mtx dim chc chg
     hig sor rdw dec temp a b 
     sou data)
;;;; 
  (defun err(s)
    (if (and (/= s "Function cancelled")(/= s "quit / exit abort"))
      (princ (strcat "\n--->> Error: " s))
      )
    (res)
    )
;;;;; 
  (defun res()
    (if hig (setvar "HighLight" hig))
    (if sor (setvar "Sortents" sor))
    (if pst (setvar "Pickstyle" pst))
    (if rdw (chc 0))
    (command "_.Undo" "_End")
    (setq *error* oer)
    (setvar "Cmdecho" 1)
    (princ)
    )
;;;;; 
  (defun sta()
    (setq oer *error*
 *error* err
 hig (getvar "HighLight")
 sor (getvar "Sortents")
 pst (getvar "Pickstyle")
 dec (getvar "Dimdec")
 )
    (setvar "Cmdecho" 0)
    (command "_.Undo" "_Group")
    (setvar "HighLight" 1)
    (setvar "Sortents" 1)
    (setvar "Pickstyle" 0)
    (graphscr)
    )
;;;;; 
  (defun sel (/ loop lis typ intro)
    (if (null del-mode)(setq del-mode "0"))
    (if (null mat-mode)(setq mat-mode "0"))
    (setq loop T
 lis '("TEXT" "MTEXT" "DIMENSION" "ARCALIGNEDTEXT")
 )
    (if (= mode 0)
      (setq intro "\nSelect copy source text ")
      (setq intro "\nSelect additon source text ")
      )
    (while loop
      (initget "Exit Delete Match MD DM")
      ;(setq del T);;;
      (setq sou (nentsel (strcat intro "[Delete source("del-mode")/Match properties("mat-mode")]: ")))
      (cond
((= sou "Exit")(exit))
((null sou)(exit))
((= sou "Delete")
(if (= del-mode "0")
  (setq del-mode "1")
  (setq del-mode "0")
  )
)
((= sou "Match")
 (if (= mat-mode "0")
  (setq mat-mode "1")
  (setq mat-mode "0")
  )
 )
((or (= sou "MD")(= sou "DM"))
 (progn
   (if (= del-mode "0")
     (setq del-mode "1")
     (setq del-mode "0")
     )
   (if (= mat-mode "0")
     (setq mat-mode "1")
     (setq mat-mode "0")
     )
   )
 )
((progn
  (setq data (entget (car sou))
typ (cdr (assoc 0 data))
)
  (if (not (member typ lis))
    (princ "Invalid selection.")
    (progn
      (setq temp (assoc 1 data)
    loop nil
    )
      (cond
((= typ "MTEXT")(mtx))
((= typ "DIMENSION")(dim))
)
      )
    ); if end
  ))
); cond end
      )
    (chc 1)
    (setq rdw T)
    )
;;;;; 
  (defun mtx(/ con test)
    (setq con (cdr temp)
 test (substr con 1 1)
 )
    (if (= test "\\")(setq temp (cons 1 (substr con 5))))
    )
;;;;; 
  (defun dim(/ con)
    (setq con (cdr temp))
    (if (or (= con "")(= con "<>"))
      (setq temp (cons 1 (rtos (cdr (assoc 42 data)) 2 dec)))
      )
    )
;;;;; 
  (defun chc(mode / col)
    (cond
      ((and (= del-mode "1") (= mat-mode "0"))(setq col "230"))
      ((and (= del-mode "0") (= mat-mode "1"))(setq col "110"))
      ((and (= del-mode "1") (= mat-mode "1"))(setq col "30"))
      ((setq col "140"))
      )
    (if (= mode 0)
      (progn
(command "_.Chprop" sou "" "_Color" "BYLAYER" "")
(redraw (car sou) 4)
)
      (progn
(command "_.Chprop" sou "" "_Color" col "")
(redraw (car sou) 3)
)
      )
    )
;;;;; 
  (defun chg(/ ss inc data-)
    (if (= mode 0)
      (princ "\nSelect destiantion texts to change: ")
      (princ "\nSelect destiantion texts to add: ")
      )
    (setq ss (ssget '((-4 . "<OR")
     (0 . "TEXT")(0 . "MTEXT")(0 . "DIMENSION")(0 . "ARCALIGNEDTEXT")(0 . "INSERT")
     (-4 . "OR>")
     )))
    (if (null ss)(exit))
    (setq inc 0)
    (repeat (sslength ss)
      (setq data- (entget (ssname ss inc))
   inc (1+ inc))
       (setq a (ssname ss (1- inc)))
      (if (= (cdr (assoc 0 data-)) "INSERT")
          (progn
                
                 (alert "\n Doi tuong chon là block.")
                 (setq b (ssadd a))
                 (sssetfirst ss b)
                 (setq data- (entget (car (nentsel "\n  Ban hay pick lai thuoc tinh can thay doi"))))
           )
       )
      (if (= mode 1)
(setq temp (cons 1 (strcat (cdr (assoc 1 data-)) "x" (cdr temp))))
)
      (entmod (subst temp (assoc 1 data-) data-))
      (entupd a)
      )
    (if (= mat-mode "1")
      (progn
(if rdw (chc 0))
(command "_.MatchProp" sou ss "")
)
      )
    (if (= del-mode "1")
      (progn
(entdel (car sou))
(setq rdw nil)
)
      )
    )
;;;;; 
  (sta)
  (sel)
  (chg)
  (res)
  )
 
(defun c:TC()(copy-add-text-content 0))
(defun c:TD()(copy-add-text-content 1))
(princ)

Download lisp

Filename: 406902_tc_td.lsp

Tác giả: phamthanhbinh
Bài viết gốc: 406954
Tên lệnh: dimpo

Nhờ Viết Lisp

Chào các bác !!!

Nhờ các bác viết dùm em cái Lisp: Dim khoảng cách giữa đỉnh liên tiếp trên pline (Pline bao gồm cả cung tròn)

Nội dung và trình tự của Lisp:

Bước 1: Chọn Pline.

Bước 2: Chọn khoảng cách từ dim tới Pline

Bước 3: Dim khoảng cách giữa các đỉnh liên tiếp trên pline...
>>
Chào các bác !!!

Nhờ các bác viết dùm em cái Lisp: Dim khoảng cách giữa đỉnh liên tiếp trên pline (Pline bao gồm cả cung tròn)

Nội dung và trình tự của Lisp:

Bước 1: Chọn Pline.

Bước 2: Chọn khoảng cách từ dim tới Pline

Bước 3: Dim khoảng cách giữa các đỉnh liên tiếp trên pline (Pline bao gồm cả cung tròn). Dim thuộc dimstyle hiện hành và layer hiện hành. Chi tiết các bác xem thêm trong file cad em gửi kèm.

Cảm ơn các bác đã quan tâm

http://www.cadviet.com/upfiles/6/121521_viet_lisp_1.dwg

Hề hề hề,

Bạn dùng thử cái này, viết đã lâu và có sẵn trên diễn đàn mà bạn lười tìm kiếm . Mong bạn lần sau tìm kiếm kỹ trước khi post yêu cầu.

http://www.cadviet.com/upfiles/6/5194_dimarclength.lsp
(defun darl (/ e1 e2 ra an alen)
;;
(command "dimradius" pause "")
(setq e1 (entlast))
(command "dimangular" pause (getpoint "\n Chon diem dat ") )
(setq e2 (entlast))
(setq Ra (cdr (assoc 42 (entget e1))))
(setq an (cdr (assoc 42 (setq el (entget e2)))))
(setq alen (* ra an))
(entmod (subst (cons 1 (rtos alen 2 2)) (assoc 1 el) el))
(command "erase" e1 "")
)
;;;;;;;;;;;;;;;;;;;
(defun c:dimpo (/ e verl els bulst k i p1 p2 )
(vl-load-com)
(setq e (car (entsel "\n Chon duong can do ")))
(setq verl (acet-geom-vertex-list e)
          els (entget e)
          bulst (list)
          k 0  )
(command "undo" "be")
(foreach en els
         (if (= (car en) 42)
             (setq bulst (append bulst (list (list (nth k verl) (cdr en))))  k (1+ k) )
         )         
)
(foreach bul bulst
      (setq i (vl-position bul bulst)
               p1 (nth i verl)
               p2 (nth (1+ i) verl)  )
                  
      (if (and p1 p2)
          (progn
                  (alert (strcat "\n Ban dang do phan doan thu " (rtos (1+ i) 2 0)))
                  (if (= (cadr bul) 0)  
                       (command "dimaligned" p1 p2 (getpoint "\n Chon diem dat "))
                       (darl)
                  )
          )
      )
             
)
(command "undo" "e")
)
<<

Download lisp

Filename: 406954_dimpo.lsp

Tác giả: quocmanh04tt
Bài viết gốc: 403724
Tên lệnh: lee%C2%A0

Nhờ Nâng Cấp Lisp Dải Leader Tại Giao Điểm Của Các Đoạn Thẳng.

Cái này nên làm MLeader luôn để các Leader nó kết thành 1 đối tượng.

Lisp sửa lại của bạn:

(defun c:lee  (/ a b c cmd enl i ssl tmp)
 (setq cmd (getvar 'CMDECHO))
 (setvar 'CMDECHO 0)
 (command "undo" "be")
 (if (and (setq a (getpoint "\nChon diem Cuoi Leader"))
          (setq b (getpoint a "\nChon diem Dau ve Leader")))
  (progn
;;;...
>>

Cái này nên làm MLeader luôn để các Leader nó kết thành 1 đối tượng.

Lisp sửa lại của bạn:

(defun c:lee  (/ a b c cmd enl i ssl tmp)
 (setq cmd (getvar 'CMDECHO))
 (setvar 'CMDECHO 0)
 (command "undo" "be")
 (if (and (setq a (getpoint "\nChon diem Cuoi Leader"))
          (setq b (getpoint a "\nChon diem Dau ve Leader")))
  (progn
;;; (command "Leader" b a "" "" "n")
         (command "LINE" b a "")
         (setq tmp (entlast))
         (setq ssl (ssget "_F" (list a b) '((0 . "*LINE"))))
         (setq i -1)
         (while (setq enl (ssname ssl (setq i (1+ i))))
          (and (Setq c (car (acet-geom-intersectwith enl tmp 0))) (command "leader" c a "" "" "n")))
         (entdel tmp)))
 (command "undo" "end")
 (setvar 'CMDECHO cmd)
 (princ))

Download lisp

Filename: 403724_lee%C2%A0.lsp

Tác giả: taipham
Bài viết gốc: 407003
Tên lệnh: ttt

Nhờ Sửa Lỗi Lisp

Sao em gửi mà không thấy đoạn Code Lisp, em gửi lại:

(defun c:TTT ()
  (command "undo" "be")
  (setq osm (getvar "osmode"))
  (setvar "cmdecho" 0)	
  (setvar "osmode" 0)	
  (while
  (setq p1 (getpoint "1"))
  (setq	p2 (getpoint p1 "2"))

  (if (null (setq L1 (ssget "F" (list p1 p2) (list (cons 8 "L1")))))
      (setq L1 "")
      (setq L1 "v"))

  (if (null (setq L2 (ssget "F" (list p1 p2) (list (cons 8 "L2")))))
    (progn (setq L2 0)...
>>

Sao em gửi mà không thấy đoạn Code Lisp, em gửi lại:

(defun c:TTT ()
  (command "undo" "be")
  (setq osm (getvar "osmode"))
  (setvar "cmdecho" 0)	
  (setvar "osmode" 0)	
  (while
  (setq p1 (getpoint "1"))
  (setq	p2 (getpoint p1 "2"))

  (if (null (setq L1 (ssget "F" (list p1 p2) (list (cons 8 "L1")))))
      (setq L1 "")
      (setq L1 "v"))

  (if (null (setq L2 (ssget "F" (list p1 p2) (list (cons 8 "L2")))))
    (progn (setq L2 0) (setq a1 0))
    (progn (setq L2 (sslength L2)) (setq a1 1)))
  
  (if (null (setq L5 (ssget "F" (list p1 p2) (list (cons 8 "L5")))))
    (setq L5 0)
    (setq L5 (sslength L5)))

  (if (null (setq L3 (ssget "F" (list p1 p2) (list (cons 8 "L3")))))
    (setq L3 0)
    (setq L3 (sslength L3)))
  
  (if (null (setq L4 (ssget "F" (list p1 p2) (list (cons 8 "L4")))))
    (setq L4 "0")
    (setq L4 "n"))

  (setq tmc (strcat L1 (itoa L2) (itoa L5) (itoa a1) (itoa L3) L4))
  (setq att (cdr (car (entget (entnext (car (entsel "")))))))
  (setq TagName (dxf 2 att)
	TagVal (dxf 1 att)
	BlName (dxf 330 att))
     (if (setq NewVal tmc)
	(putAtt BlName TagName NewVal))

  (setq	L1 nil)
  (setq	L2 nil)
  (setq	L5 nil)
  (setq	L3 nil)
  (setq	L4 nil)
  (setq a1 nil)
  (setq p1 nil)
  (setq p2 nil)
  (setvar "osmode" osm)
  (setvar "cmdecho" 1)
  (command "undo" "e")
  (princ)
  ))

;------------------------------------------------------------------------------------------
(defun dxf(id ent) (cdr (assoc id (entget ent))))
;------------------------------------------------------------------------------------------
(defun putAtt (BlName TagName NewVal / AttName EntDxf dk)
(setq AttName (entnext BlName ) dk 1)
  (while (and AttName dk)
    (if (equal (assoc 0 (entget AttName )) '(0 . "SEQEND"))
        (setq AttName nil )
        (if (= (cdr (assoc 2 (entget AttName ))) TagName )
            (progn
              (setq EntDxf (entget AttName ) dk nil)
              (setq EntDxf (subst (cons 1 NewVal ) (assoc 1 (entget AttName )) EntDxf ) )
              (entmod EntDxf )
              (entupd BlName )
              (setq AttName (entnext AttName ))
            )
        (setq AttName (entnext AttName ))
        )
    )
  )
)

Download lisp

Filename: 407003_ttt.lsp

Tác giả: quocmanh04tt
Bài viết gốc: 407013
Tên lệnh: tt

Nhờ Sửa Lỗi Lisp

1. Có lúc trả về "00000" là do mấy đường kia là nét đứt, LTSCALE đủ để hở nên khi ssget "F" qua khoảng hở nó sẽ null.
+ Có thể giải quyết: Hoặc set biến LTSCALE trong lisp thật khủng rồi regen (cuối lisp "trả lại tên cho em"), hoặc nhập từ bàn phím trước lúc chạy lsp.
2. Dựa theo ý của bạn, viết lại theo cách khác gọn hơn.
(defun c:tt (/ a1 ent l1 l2 l3 l4 l5 lay lst p1 p2 ss temp...

Download lisp

Filename: 407013_tt.lsp

Tác giả: Tue_NV
Bài viết gốc: 407117
Tên lệnh: tkt

Nhờ Các Bác Sửa Dùm Lisp Thống Kê Text Phổ Biến Cho Ae Xd

Bạn thử xem:

(defun c:tkt(/ ent h height i len0 lst msp pt row ss str str0 str_len tblobj width0 width1 ee); thong ke text
;;  By : Gia Bach, Copyright? December 2010                    ;;
;;  Contact : gia_bach @  www.CadViet.com                      ;;
  (defun TxtWidth (val msp / txt minp maxp)
 ...
>>

Bạn thử xem:

(defun c:tkt(/ ent h height i len0 lst msp pt row ss str str0 str_len tblobj width0 width1 ee); thong ke text
;;  By : Gia Bach, Copyright? December 2010                    ;;
;;  Contact : gia_bach @  www.CadViet.com                      ;;
  (defun TxtWidth (val msp / txt minp maxp)
    (vla-getBoundingBox (setq txt (vla-AddText msp val (vlax-3d-point '(0 0 0)) 1)) 'minp 'maxp)
    (vla-Erase txt)
    (-(car(vlax-safearray->list maxp))(car(vlax-safearray->list minp)))  )
  ;main
  (if (> (atof (substr (getvar "ACADVER") 1 4)) 16.0)
    (progn
      (vl-load-com)
      (princ "\nChon cac Text de thong ke :")
      (if (setq ss (ssget(list (cons 0 "TEXT"))))
(progn
 (setq i -1 len0 8)
 (while (setq ent (ssname ss (setq i (1+ i))))
   (setq str(cdr(assoc 1 (entget ent ))))
   (if (> (setq str_len (strlen str)) len0)
     (setq str0 str len0 str_len) )
   (if (not (assoc str lst))
     (setq lst (cons (cons str 1) lst))
     (setq lst (subst (cons str (1+ (cdr (assoc str lst))))
      (assoc str lst) lst)))     )
 (setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y))))
msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
 (or *h* (setq *h* 175))
 (initget 6)
 (setq h (getreal (strcat "\nChieu cao chu <" (rtos *h*) "> :")))
 (if h (setq *h* h) (setq h *h*) )
 (setq width0 (* 3 h(TxtWidth "STT" msp))
height (* 2 h))
 (if str0
   (setq width1 (* 1.2 h(TxtWidth (strcase str0) msp)))
   (setq width1 (* 2 h(TxtWidth "Ten Dam" msp))))
 (if (> h 3)
   (setq width0 (* (fix (/ width0 10))10)
 width1 (* (fix (/ width1 10))10)
 height (* (fix (/ height 5))5)))
 (setq pt (getpoint "\nDiem dat Bang :")
TblObj (vla-addtable msp (vlax-3d-point pt) (+ (length lst) 2) 5 height width1))
 (vla-put-regeneratetablesuppressed TblObj :vlax-true)
 (vla-put-vertcellmargin TblObj (* 0.25 h))
 (vla-put-horzcellmargin TblObj (* 0.75 h))
 (vla-SetColumnWidth TblObj 0 width0)
 (vla-SetColumnWidth TblObj 2 (* 2 h(TxtWidth "So luong" msp)))
 (mapcar '(lambda (x)(vla-setTextHeight TblObj x h))
 (list acTitleRow acHeaderRow acDataRow) )
 (mapcar '(lambda (x)(vla-setAlignment TblObj x 8))
 (list acTitleRow acHeaderRow acDataRow))
 (vl-catch-all-error-p (vl-catch-all-apply (function(lambda () (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 dam")
 (vla-setText TblObj 1 2 "Kich thuoc")
 (vla-setText TblObj 1 3 "So luong")
 (vla-setText TblObj 1 4 "chi tiet xem ban ve")
 (setq i 1 row 2 )
 (princ lst)
 (foreach e lst
   (vla-setText TblObj row 0 (itoa i))
   (vla-setText TblObj row 1 (substr (car e) 1
  (- (strlen (car e)) (strlen (vl-string-left-trim "ABCDEFGHIKLMNOPQRSTUVXY+-*/!@#1234567890 " (car e))))
))
   (vla-setText TblObj row 2 (vl-string-trim "()" (vl-string-left-trim "ABCDEFGHIKLMNOPQRSTUVXY+-*/!@#1234567890 " (car e))))
   (vla-setText TblObj row 3 (cdr e))
   (vla-SetCellAlignment TblObj row 1 7)
   (vla-SetCellAlignment TblObj row 2 9)
   (setq row (1+ row) i (1+ i)) )
 (vla-put-regeneratetablesuppressed TblObj :vlax-false)
 (vlax-release-object TblObj)   )
(alert "Khong chon duoc Text.")    )
      (princ)  )
    (alert "\nPhien ban Cad cua ban khong ho tro tao Bang (TABLE)")   )  )

Download lisp

Filename: 407117_tkt.lsp

Tác giả: Tue_NV
Bài viết gốc: 407133
Tên lệnh: tkt

Nhờ Các Bác Sửa Dùm Lisp Thống Kê Text Phổ Biến Cho Ae Xd

Em test nhiều trường hợp rồi, mấy cái D1 không viết hoa, hay viết tiếng việt thì thống kê không đúng, mà cái này cũng không cần sửa vì không cần thiết

Mấy cái text sai mẫu là không TK dc

Căn lề, chỉnh midle center trong talbe hoài mà không đều giữa text và khung

Bác chốt dùm em 2 vđ trên là OK...

Em test nhiều trường hợp rồi, mấy cái D1 không viết hoa, hay viết tiếng việt thì thống kê không đúng, mà cái này cũng không cần sửa vì không cần thiết

Mấy cái text sai mẫu là không TK dc

Căn lề, chỉnh midle center trong talbe hoài mà không đều giữa text và khung

Bác chốt dùm em 2 vđ trên là OK rồi. I swear, by the moon and the star in the sky ^.^

2 vấn đề của bạn đây. Xử lý TH viết hoa, thường

(defun c:tkt(/ ent h height i len0 lst msp pt row ss str str0 str_len tblobj width0 width1 ee); thong ke text
;;  By : Gia Bach, Copyright? December 2010                    ;;
;;  Contact : gia_bach @  www.CadViet.com                      ;;
  (defun TxtWidth (val msp / txt minp maxp)
    (vla-getBoundingBox (setq txt (vla-AddText msp val (vlax-3d-point '(0 0 0)) 1)) 'minp 'maxp)
    (vla-Erase txt)
    (-(car(vlax-safearray->list maxp))(car(vlax-safearray->list minp)))  )
  ;main
  (if (> (atof (substr (getvar "ACADVER") 1 4)) 16.0)
    (progn
      (vl-load-com)
      (princ "\nChon cac Text de thong ke :")
      (if (setq ss (ssget(list (cons 0 "TEXT"))))
(progn
 (setq i -1 len0 8)
 (while (setq ent (ssname ss (setq i (1+ i))))
   (setq str(cdr(assoc 1 (entget ent ))))
   (if (> (setq str_len (strlen str)) len0)
     (setq str0 str len0 str_len) )
   (if (not (assoc str lst))
     (setq lst (cons (cons str 1) lst))
     (setq lst (subst (cons str (1+ (cdr (assoc str lst))))
      (assoc str lst) lst)))     )
 (setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y))))
msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
 (or *h* (setq *h* 175))
 (initget 6)
 (setq h (getreal (strcat "\nChieu cao chu <" (rtos *h*) "> :")))
 (if h (setq *h* h) (setq h *h*) )
 (setq width0 (* 3 h(TxtWidth "STT" msp))
height (* 2 h))
 (if str0
   (setq width1 (* 1.2 h(TxtWidth (strcase str0) msp)))
   (setq width1 (* 2 h(TxtWidth "Ten Dam" msp))))
 (if (> h 3)
   (setq width0 (* (fix (/ width0 10))10)
 width1 (* (fix (/ width1 10))10)
 height (* (fix (/ height 5))5)))
 (setq pt (getpoint "\nDiem dat Bang :")
TblObj (vla-addtable msp (vlax-3d-point pt) (+ (length lst) 2) 5 height width1))
 (vla-put-regeneratetablesuppressed TblObj :vlax-true)
 (vla-put-vertcellmargin TblObj (* 0.25 h))
 (vla-put-horzcellmargin TblObj (* 0.75 h))
 (vla-SetColumnWidth TblObj 0 width0)
 (vla-SetColumnWidth TblObj 2 (* 2 h(TxtWidth "So luong" msp)))
 (mapcar '(lambda (x)(vla-setTextHeight TblObj x h))
 (list acTitleRow acHeaderRow acDataRow) )
 (mapcar '(lambda (x)(vla-setAlignment TblObj x acMiddleCenter))
 (list acTitleRow acHeaderRow acDataRow))
 (vl-catch-all-error-p (vl-catch-all-apply (function(lambda () (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 dam")
 (vla-setText TblObj 1 2 "Kich thuoc")
 (vla-setText TblObj 1 3 "So luong")
 (vla-setText TblObj 1 4 "chi tiet xem ban ve")
 (setq i 1 row 2)
 (princ lst)
 (foreach e lst
   (vla-setText TblObj row 0 (if (< i 10) (strcat "0" (itoa i)) (itoa i)))
   (vla-setText TblObj row 1 (substr (car e) 1
  (- (strlen (car e)) (strlen (vl-string-left-trim "ABCDEFGHIKLMNOPQRSTUVXY+-*/!@#1234567890 " (strcase (car e)))))
))
   (vla-setText TblObj row 2 (vl-string-trim "()" (vl-string-left-trim "ABCDEFGHIKLMNOPQRSTUVXY+-*/!@#1234567890 " (strcase (car e)))))
   (vla-setText TblObj row 3 (cdr e))
   (setq row (1+ row) i (1+ i) ) )
 (vla-put-regeneratetablesuppressed TblObj :vlax-false)
 (vlax-release-object TblObj)   )
(alert "Khong chon duoc Text.")    )
      (princ)  )
    (alert "\nPhien ban Cad cua ban khong ho tro tao Bang (TABLE)")   )  )

Download lisp

Filename: 407133_tkt.lsp

Tác giả: KangKung
Bài viết gốc: 407155
Tên lệnh: clo

Lisp tạo viewport từ khung chọn bên model.

Của bạn đây.

Hướng dẫn:

1. Lệnh CLO

2. Chọn máy in, khổ giấy, style...

3. Đặt tên Layout, tỉ lệ

4. Chọn các khung hình chữ nhật (Polyline) bên Model để tạo Viewport bên Layout. Khi quét chọn thì Lisp sẽ tự động căn các khung theo thứ tự từ trái sang phải.

5. Chọn...

Của bạn đây.

Hướng dẫn:

1. Lệnh CLO

2. Chọn máy in, khổ giấy, style...

3. Đặt tên Layout, tỉ lệ

4. Chọn các khung hình chữ nhật (Polyline) bên Model để tạo Viewport bên Layout. Khi quét chọn thì Lisp sẽ tự động căn các khung theo thứ tự từ trái sang phải.

5. Chọn Block hoặc file xref. Nếu không cần thì khỏi chọn.

6. Bấm OK, Lisp sẽ tạo mỗi bản vẽ trên một Layout.

;LISP TAO LAYOUT HANG LOAT BANG CACH CHON KHUNG VIEW BEN MODEL
(vl-load-com)
(defun Make_dcl	(/ ret)
  (if (= Printer nil) (setq Printer 0))
  (if (= Size nil) (setq Size 0))
  (if (= Style nil) (setq Style 0))
  (if (= Block nil) (setq Block 0))
  (if (= TenLayout nil) (setq TenLayout "Layout"))
  (if (= Tyle nil) (setq Tyle "1000"))
  (setq fl (vl-filename-mktemp "CLO" nil ".dcl"))
  (setq ret (open fl "w"))
  (write-line
    (strcat
      "CLO : dialog { label = \"Create Layout\";
      : column {
      : boxed_column {label = \"Page Setup\";
      : popup_list { key=\"Printer\"; label= \"Printer\";  value = \"" (itoa Printer) "\"; edit_width = 40;}
      : popup_list { key=\"PaperSize\"; label= \"Paper Size   \"; value = \"" (itoa Size) "\"; edit_width = 40;}
      : popup_list { key=\"Style\"; label= \"Style            \"; value = \"" (itoa Style) "\";edit_width = 40;}
      : edit_box {   key = \"LO_name\"; label = \"Layout Name  \"; value = \"" TenLayout "\";edit_width = 20;}
      : edit_box {   key = \"Tyle\"; label = \"Drawing Scale\"; value = \"" Tyle "\";edit_width = 20;}}
      : button { key = \"Chonkhung\"; label = \"Select Frame \"; }
      : boxed_column {
      label = \"\";
      :row {
      : button { key = \"TaoBlock\"; label = \"Create Title Block\"; is_default = false; width=30; fixed_width=true;}
      : popup_list {key=\"Block\"; label= \"Block\"; width=30; fixed_width=true; value = \"" (itoa Block) "\";}}
      : row {
      : button {key = \"Select_Xref\"; label = \"Xref Title Block\"; is_default = false; width=30; fixed_width=true;}
      : button {key = \"Remove\"; label = \"Remove Title Block\"; is_default = false; width=30; fixed_width=true;}}
      : list_box {label =\"\"; key = \"Xref_File\"; height = 3; value = \"0\";}
      }
      : boxed_row {
      : button { key = \"accept\"; label = \" OK \"; width=30; fixed_width=true; is_default = true;}
      : button { key = \"cancel\"; label = \"Cancel\"; is_default = false; is_cancel = true; width=30; fixed_width=true;}}}} "
    )
    ret
  )
  (setq ret (close ret))
)
(defun *error* (msg) (vl-file-delete fl))
(defun Chon ()
  (vl-file-delete fl)
  (setq taphop(ssget '((0 . "POLYLINE,LWPOLYLINE"))))
  (Make_dcl)
  (setq ddiag 3)
)
(defun TaoBlock (/ taphop pt)
  (vl-file-delete fl)
  (alert "Chon doi tuong de tao Block khung ten")
  (if (/= (setq taphop(ssget)) nil)
    (progn
      (setq pt(getpoint "\n Chon Base point cua Block: "))
      (setq ten(lisped "Nhap ten cua Block"))
      (while (/= (tblsearch "Block" ten) nil)
	(setq ten(lisped "Trung ten Block da co. Nhap ten khac cho Block")))
      (command "BLOCK" ten pt taphop "")
      (setq dsblock(cons "" (tablelist "Block")))
      ))
  (Make_dcl)
  (setq ddiag 3)
)
(defun Update ()
  (vla-put-ConfigName (ActLay) (nth (atoi (get_tile "Printer")) dsmayin))
  (setq dsPaper (PaperList))
  (start_list "PaperSize" 3)
  (mapcar 'add_list dsPaper)
  (end_list)
)
(defun Chon_Xref ()
  (if (not Path) (setq Path(getvar "dwgprefix")))
  (setq File(getfiled "Chon File khung ten" Path "dwg" 2))
  (if (/= File nil) (setq Path File dsFile (list File)))
  (start_list "Xref_File" 3)
  (mapcar 'add_list dsFile)
  (end_list)
  )
(defun Remove_Xref ()
  (setq File "" dsFile (list File))
  (start_list "Xref_File" 3)
  (mapcar 'add_list dsFile)
  (end_list)
  )
(defun ActLay () (vla-get-ActiveLayout(vla-get-activedocument(vlax-get-acad-object))))
(defun PlotDeviceNamesList ()
  (vla-RefreshPlotDeviceInfo (ActLay))
  (vlax-safearray->list(vlax-variant-value(vla-GetPlotDeviceNames (ActLay)))))
(defun PaperList (/ PLObj PSL)
  (setq PLObj (vla-GetCanonicalMediaNames (ActLay)))
  (foreach i (vlax-safearray->list (vlax-variant-value PLObj))
    (setq PSL (append PSL (list (vla-GetLocaleMediaName (ActLay) i))))))
(defun PlotStyleTableNamesList ()
  (vla-RefreshPlotDeviceInfo (ActLay))
  (vlax-safearray->list(vlax-variant-value(vla-GetPlotStyleTableNames(ActLay)))))
(defun tablelist (s / d r)
  (while (setq d (tblnext s (null d)))
    (setq r (cons (cdr (assoc 2 d)) r))))
(defun DeleteLayouts (/ layouts layout i)
  (vl-load-com)
  (setq	layouts	(vla-get-Layouts(vla-get-activedocument (vlax-get-acad-object))))
  (if (> (vla-get-count layouts) 2)
    (vlax-for layout layouts
      (if (= (vla-get-ModelType layout) :vlax-false)
	(if (< (vla-get-count (vla-get-block layout)) 2)
	  (vla-delete layout))))))
(setq dsmayin (PlotDeviceNamesList))
(setq dsStyle (PlotStyleTableNamesList))
(setq dsblock(cons "" (tablelist "Block")))
(defun hopthoai	()
  (setq dcl_id (load_dialog fl))
  (if (not (new_dialog "CLO" dcl_id)) (exit))
  (start_list "Printer" 3)
  (mapcar 'add_list dsmayin)
  (end_list)
  (Update)
  (action_tile "Printer" "(Update)")
  (action_tile "Chonkhung" "(setq ddiag 5)(saveVars)(done_dialog)")
  (action_tile "TaoBlock" "(setq ddiag 9)(saveVars)(done_dialog)")
  (start_list "Style" 3)
  (mapcar 'add_list dsStyle)
  (end_list)
  (start_list "Block" 3)
  (mapcar 'add_list dsBlock)
  (end_list)
  (start_list "Xref_File" 3)
  (mapcar 'add_list dsFile)
  (end_list)
  (action_tile "Select_Xref" "(Chon_Xref)")
  (action_tile "Xref_File" "(Chon_Xref)")
  (action_tile "Remove" "(Remove_Xref)")
  
  (action_tile "cancel" "(setq ddiag 1)(done_dialog)")
  (action_tile "accept" "(setq ddiag 2)(setq tieptuc 1)(saveVars)(done_dialog)" )
  (start_dialog)
  (unload_dialog dcl_id)
)
(defun saveVars	()
  (setq Printer (atoi (get_tile "Printer")))
  (setq Size (atoi (get_tile "PaperSize")))
  (setq Style (atoi (get_tile "Style")))
  (setq Tyle (get_tile "Tyle"))
  (setq Block (atoi (get_tile "Block")))
  
  (setq Printer1 (nth Printer dsmayin))
  (setq Size1 (nth Size (PaperList)))
  (setq Style1 (nth Style dsStyle))
  (setq TenLayout (get_tile "LO_name"))
  
  (setq Tyle1 (/ (atof (get_tile "Tyle")) 1000))
  (setq Block1 (nth Block dsBlock))
)
(defun C:CLO (/ os)
  (setvar "CMDECHO" 0)
  (command "UNDO" "BE")
  (setq os(getvar "OSMODE"))
  (setvar "OSMODE" 0)
  (setvar "TILEMODE" 1)
  (setq dsblock(cons "" (tablelist "Block")))
  (if (= File nil) (setq dsFile (list "")))
  (setq tieptuc 0)
  (Make_dcl)
  (setq ddiag 3)
  (while (= ddiag 3)
    (hopthoai)
    (if	(= ddiag 5) (Chon))
    (if	(= ddiag 9) (TaoBlock))
  )
  (vl-file-delete fl)
  (if (= tieptuc 1)
    (progn
      (Sapxepkhung)
      (Make_Layout)
      (DeleteLayouts)
      )
    )
  (setvar "OSMODE" os)
  (command "UNDO" "END")
  (princ)
  )
(defun Sapxepkhung(/ index khung S1 S2 D1 D2)
  (setq index 0)
  (setq lst_Khung(list))
  (setq S1 0 S2 0)
  (while (< index (sslength taphop))
    (setq khung (ssname taphop index))
    (setq lst_Khung(append lst_Khung (list(list khung S1 S2))))
    (setq index (1+ index))
    )
  (setq lst_Khung(vl-sort lst_Khung '(lambda (e1 e2) (< (cadr(assoc 10 (entget(car e1)))) (cadr(assoc 10 (entget(car e2))))))))
  )
(defun Make_Layout (/ disp index khung lst pt0 pt1 pt2 pt3 P1 P2)
  (setq disp(getenv "CreateViewports"))
  (setenv "CreateViewports" "0")
  (setq index 1)
  (foreach khung1 lst_Khung
    (setq khung (car khung1))
    (setq lst (acet-geom-vertex-list khung))
    (setq lst (vl-sort lst '(lambda(e1 e2) (if (/= (car e1) (car e2)) (< (car e1) (car e2)) (< (cadr e1) (cadr e2))))))
    (setq pt0 (nth 0 lst) pt3 (nth 3 lst))
    (if	(> (cadr (nth 1 lst)) (cadr (nth 2 lst)))
      (setq pt1	(nth 1 lst) pt2	(nth 2 lst))
      (setq pt1	(nth 2 lst) pt2	(nth 1 lst)))
    (command "LAYOUT" "N" (strcat TenLayout (itoa (+ 0 index))))
    (command "LAYOUT" "S" (strcat TenLayout (itoa (+ 0 index))))
    (command "ERASE" "ALL" "")
    (if (/= File nil) (command "xref" "A" file (list 0 0) "" "" ""))
    (if (/= Block1 "") (command "INSERT" Block1 (list 0 0) "" "" ""))
    (command "ZOOM" "E")
    (if	(> (distance pt2 pt0) (distance pt1 pt0))
      (command "RECTANG"  (list 0 0) (list (/ (distance pt2 pt0) tyle1) (/ (distance pt1 pt0) tyle1)))
      (command "RECTANG"  (list 0 0) (list (/ (distance pt1 pt0) tyle1) (/ (distance pt2 pt0) tyle1)))
      )
    (command "MVIEW" "O" (entlast))
    (command "MSPACE")
    (if	(> (distance pt2 pt0) (distance pt1 pt0))
      (command "DVIEW" khung "" "TW" (- 90 (* (/ (angle pt0 pt1) pi) 180)) "")
      (command "DVIEW" khung "" "TW" (- 0 (* (/ (angle pt0 pt1) pi) 180)) ""))
    (command "ZOOM" "W" pt0 pt3)
    (command "PSPACE")
    (command "ZOOM" "E")
    (Setq P1 (Getvar "EXTMIN") P2 (Getvar "EXTMAX"))
    (command "PLOT" "Y" "" printer1 size1 "M" "L" "N" "W" P1 P2 "1" "C" "Y" Style1 "Y" "N" "N" "N" "N" "Y" "N")
    (command "MODEL")
    (setq index (+ index 1))
  )
  (setenv "CreateViewports" disp)
  (princ)
)
(princ "\n           Type CLO to run program\n")

Download lisp

Filename: 407155_clo.lsp

Tác giả: quocmanh04tt
Bài viết gốc: 407174
Tên lệnh: tt

Nhờ Các Bác Sửa Dùm Lisp Thống Kê Text Phổ Biến Cho Ae Xd

Bạn thử lisp này xem (AttBlock): http://www.cadviet.com/upfiles/6/141736_tkckattblk.lsp
(defun c:tt (/ stt-sl-int acdoc blname ent i itl ktd lst mspace pt ss str tck tenbve)
(defun stt-sl-int (num)
(if (> num 9)
(setq str (itoa num))
(setq str (strcat (chr 48) (itoa num))))
str)
;; *** MAIN ***
(vl-load-com)
(or #sohienbanve# (setq #sohienbanve# 1))
(if (and (setq...

Download lisp

Filename: 407174_tt.lsp

Tác giả: KangKung
Bài viết gốc: 407180
Tên lệnh: cvp

Lisp tạo viewport từ khung chọn bên model.

Lisp theo yêu cầu của bạn conghoa đây

;==========LISP CHIA MOI VIEWPORT THANH 1 LAYOUT================
(defun C:CVP( / ACTDOC CLAYOUT LST_VIEWPORT)
  (vl-load-com)
  (setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
  (if (= (getvar "TILEMODE") 0)
    (progn
      (if (/= (getvar "cvport") 1) (command "PSPACE"))
      (command "UNDO" "BE")
      (if (setq lst_Viewport (#SS->List (ssget '((0 . "VIEWPORT")))))
	(foreach viewport...
>>

Lisp theo yêu cầu của bạn conghoa đây

;==========LISP CHIA MOI VIEWPORT THANH 1 LAYOUT================
(defun C:CVP( / ACTDOC CLAYOUT LST_VIEWPORT)
  (vl-load-com)
  (setq ActDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
  (if (= (getvar "TILEMODE") 0)
    (progn
      (if (/= (getvar "cvport") 1) (command "PSPACE"))
      (command "UNDO" "BE")
      (if (setq lst_Viewport (#SS->List (ssget '((0 . "VIEWPORT")))))
	(foreach viewport lst_Viewport
	  (command "layout" "N" (strcat "KH-" (itoa (1+ (vl-position viewport lst_Viewport)))))
	  (command "layout" "Set" (strcat "KH-" (itoa (1+ (vl-position viewport lst_Viewport)))))
	  (setq cLayout (vla-get-ActiveLayout ActDoc))
	  (vlax-invoke ActDoc 'CopyObjects (list (vlax-ename->vla-object viewport)) (vla-get-Block cLayout) nil)
	  (command "MOVE" "All" "" (Getvar "EXTMIN") (list 0 0))
	  (command "ZOOM" "E")
	  )
	)
      )
    )
  (princ)
  )
(Defun #SS->List (ss / i lst)
 (repeat (setq i (sslength ss))
  (setq lst (cons (ssname ss (setq i (1- i))) lst))))

Download lisp

Filename: 407180_cvp.lsp

Tác giả: quocmanh04tt
Bài viết gốc: 407184
Tên lệnh: tt

Lisp tạo viewport từ khung chọn bên model.

@Quocmanh04tt mình có xem phần lớn các lisp bạn post và cái mà bạn bảo hình như đó lại là tách nhiều bản vẽ trong layout ra làm thành các file riêng thì phải.

Cái mình post bên trên là trong 1 layout có nhiều viewport, lisp sẽ tách các viewport đó (đã thiết lập việc freeze layer) ra thành các layout riêng vẫn giữ...
>>

Download lisp

Filename: 407184_tt.lsp

Tác giả: hainguyen2014
Bài viết gốc: 407170
Tên lệnh: test

Lisp Phân Tách Diện Tích

Mình không rành Lisp lắm. Mình sưu tầm được 1 đoạn code lisp trên internet. Bạn có thể tham khảo thêm nhé!

(defun c:test (/ ang area dis el p1 p2 p3 ss1 ss2 vevo)
(setq ss1 (entsel "\nSelect first polyline"))
(setq p1 (cadr ss1))
(setq ss2 (entsel "\nSelect second polyline"))
(setq p2 (cadr ss2))
(setq ang (angle p1 p2))
(setq dis (distance p1 p2))
(setq p3 (polar p1 ang (/ dis 2.0)))
(command "_boundary" p3...

Download lisp

Filename: 407170_test.lsp

Tác giả: conghoa
Bài viết gốc: 407240
Tên lệnh: ttcm

Gán Giá Trị Của Dimension Cho Nhiều Text Có Sẵn

@Colombus Bạn thử dùng lisp này xem. Nó như một dạng Matchprop text, Bạn có thể chọn copy text từ Dim, text, att, MText đến 1 text có sẵn mà bạn muốn.


Chạy lisp rồi bạn chọn Pair-wise nhé.

;;;Realization {Smirnoff}
;;; TTCM - Text to Text copy whith Matchprop. Copy text from DIMENSION, TEXT, 
;;;MTEXT, ATTRIB, ATTDEF, ACAD_TABLE to one
(defun c:ttcm (/ actDoc vlaObj...
>>

@Colombus Bạn thử dùng lisp này xem. Nó như một dạng Matchprop text, Bạn có thể chọn copy text từ Dim, text, att, MText đến 1 text có sẵn mà bạn muốn.


Chạy lisp rồi bạn chọn Pair-wise nhé.

;;;Realization {Smirnoff}
;;; TTCM - Text to Text copy whith Matchprop. Copy text from DIMENSION, TEXT, 
;;;MTEXT, ATTRIB, ATTDEF, ACAD_TABLE to one
(defun c:ttcm (/ actDoc vlaObj sObj sText curObj oldForm
        oType oldMode conFlag errFlag *error* prop)
  (vl-load-com)
      (setq actDoc(vla-get-ActiveDocument
        (vlax-get-acad-object)))
      (vla-StartUndoMark actDoc)
  (defun TTC_Paste(pasteStr / nslLst vlaObj hitPt
                   hitRes Row Column)
    (setq errFlag nil)
    (if
     (setq nslLst(nentsel "\nPaste text >"))
      (progn
  (cond
    (
     (and
       (= 4(length nslLst))
       (= "DIMENSION"(cdr(assoc 0(entget(car(last nslLst))))))
       ); end and
     (setq vlaObj
      (vlax-ename->vla-object
        (cdr(assoc -1(entget(car(last nslLst)))))))
     (if
       (vl-catch-all-error-p
         (vl-catch-all-apply
     'vla-put-TextOverride(list vlaObj pasteStr)))
         (progn
         (princ "\n Can't paste. Object may be on locked layer. ")
         (setq errFlag T)
         ); end progn
       ); end if
     ); end condition #1
    (
     (and
       (= 4(length nslLst))
       (= "ACAD_TABLE"(cdr(assoc 0(entget(car(last nslLst))))))
       ); end and
     (setq vlaObj
      (vlax-ename->vla-object
        (cdr(assoc -1(entget(car(last nslLst))))))
     hitPt(vlax-3D-Point(trans(cadr nslLst)1 0))
     hitRes(vla-HitTest vlaObj hitPt
        (vlax-3D-Point '(0.0 0.0 1.0)) 'Row 'Column)
           ); end setq
     (if(= :vlax-true hitRes)
     (progn
         (if
     (vl-catch-all-error-p
       (vl-catch-all-apply
         'vla-SetText(list vlaObj Row Column pasteStr)))
     (progn
       (princ "\n Can't paste. Object may be on locked layer. ")
       (setq errFlag T)
       ); end progn
     ); end if
         ); end progn
       ); end if
     ); end condition # 2
    (
     (and
       (= 4(length nslLst))
       (= "INSERT"(cdr(assoc 0(entget(car(last nslLst))))))
       ); end and
     (princ "\nCan't paste to block's DText or MText. Select Attribute ")
     (setq errFlag T)
     ); end condition #3
    (
     (and
       (= 2(length nslLst))
         (member(cdr(assoc 0(entget(car nslLst))))
           '("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))
       ); end and
     (setq vlaObj
      (vlax-ename->vla-object(car nslLst)))
        (if
     (vl-catch-all-error-p
       (vl-catch-all-apply
         'vla-put-TextString(list vlaObj pasteStr)))
    (progn
       (princ "\nError. Can't pase text. ")
      (setq errFlag T)
      ); end progn
     ); end if
     ); end condition #4
    (T
     (princ "\nCan't paste. Invalid object. ")
     (setq errFlag T)
     ); end condition #5
    ); end cond
    (if (and (null errFlag)
             (= (type vlaObj) 'VLA-OBJECT))
    (mapcar '(lambda (x y) (vlax-put-property vlaObj x y))
        '(Linetype LineWeight Color Layer)
        prop
        )
      )
             T
      ); end progn
            nil
           ); end if
    ); end of TTC_Paste
    (defun TTC_MText_Clear(Mtext / Text Str)
    (setq Text "")
    (while(/= Mtext "")
      (cond
  ((wcmatch
     (strcase
       (setq Str
        (substr Mtext 1 2)))
                     "\\[\\{}`~]")
   (setq Mtext(substr Mtext 3)
         Text(strcat Text Str)
   ); end setq
  ); end condition #1
  ((wcmatch(substr Mtext 1 1) "[{}]")
    (setq Mtext
     (substr Mtext 2))
  ); end condition #2
  (
   (and
   (wcmatch
     (strcase
       (substr Mtext 1 2)) "\\P")
   (/=(substr Mtext 3 1) " ")
    ); end and
         (setq Mtext (substr Mtext 3)
               Text (strcat Text " ")
         ); end setq
   ); end condition #3
  ((wcmatch
     (strcase
       (substr Mtext 1 2)) "\\[LOP]")
    (setq Mtext(substr Mtext 3))
  ); end condition #4
  ((wcmatch
     (strcase
       (substr Mtext 1 2)) "\\[ACFHQTW]")
    (setq Mtext
     (substr Mtext
       (+ 2
          (vl-string-search ";" Mtext))))
  ); end condition #5
  ((wcmatch
     (strcase (substr Mtext 1 2)) "\\S")
    (setq Str(substr Mtext 3 (- (vl-string-search ";" Mtext) 2))
          Text(strcat Text (vl-string-translate "#^\\" " " Str))
          Mtext(substr Mtext (+ 4 (strlen Str)))
   ); end setq
   (print Str)
  ); end condition #6
  (T
   (setq Text(strcat Text(substr Mtext 1 1))
         Mtext (substr Mtext 2)
   )
  ); end condition #7
      ); end cond
    ); end while
  Text
); end of TTC_MText_Clear
  (defun TTC_Copy (/ sObj sText tType actDoc)
   (if
    (and
     (setq sObj(car(nentsel "\nCopy text... ")))
     (member(setq tType(cdr(assoc 0(entget sObj))))
      '("TEXT" "MTEXT" "ATTRIB" "ATTDEF"))
     ); end and
    (progn
      (setq actDoc(vla-get-ActiveDocument
        (vlax-get-Acad-object))
      sText(vla-get-TextString
       (vlax-ename->vla-object sObj))
      ); end setq
      (if(= tType "MTEXT")
  (setq sText(TTC_MText_Clear sText))
  ); end if
      ); end progn
    ); end if
  (setq prop (mapcar '(lambda (x)
             (vlax-get-property (vlax-ename->vla-object sObj)  x))
      '(Linetype LineWeight Color Layer)
          )
        )
    sText
    ); end of TTC_Copy
  (defun CCT_Str_Echo(paseStr / comStr)
    (if(< 20(strlen paseStr))
      (setq comStr
       (strcat
         (substr paseStr 1 17)"..."))
      (setq comStr paseStr)
      ); end if
    (princ
      (strcat "\nText = \"" comStr "\""))
    (princ)
    ); end of CCT_Str_Echo
    (defun *error*(msg)
    (vla-EndUndoMark
      (vla-get-ActiveDocument
        (vlax-get-acad-object)))
    (princ "\nQuit TTCM")
    (princ)
    ); end of *error*
    (if(not ttc:Mode)(setq ttc:Mode "Multiple"))
    (initget "Multiple Pair-wise")
    (setq oldMode ttc:Mode
    ttc:Mode
     (getkword
       (strcat "\nSpecify mode [Multiple/Pair-wise] <" ttc:Mode ">: "))
    conFlag T
    paseStr ""
     ); end setq
    (if(null ttc:Mode)(setq ttc:Mode oldMode))
    (if(= ttc:Mode "Multiple")
      (progn
  (if(and(setq paseStr(TTC_Copy))conFlag)
    (progn
    (CCT_Str_Echo paseStr)
    (while(setq conFlag(TTC_Paste paseStr))T
      ); end while
    ); end progn
    ); end if
  ); end progn
      (progn
  (while
    (and conFlag paseStr)
    (setq paseStr(TTC_Copy))
    (if(and paseStr conFlag)
      (progn
    (CCT_Str_Echo paseStr)
    (setq errFlag T)
    (while errFlag
    (setq conFlag(TTC_Paste paseStr))
         );end while
       ); end progn
      ); end if
    ); end while
  ); end progn
      ); end if
   (vla-EndUndoMark actDoc)
   (princ "\nQuit TTCM")
  (princ)
  ); end c:ttc
(princ "\n\t TTCM - Text to Text copy with matchprop.")
(princ "\nCopy text from DIMENSION, TEXT, MTEXT, ATTRIB, ATTDEF, ACAD_TABLE to one")

Download lisp

Filename: 407240_ttcm.lsp

Trang 210/330