Jump to content
InfoFile
Tác giả: ketxu
Bài viết gốc: 391495
Tên lệnh: t2elev
Chuyen Text Cao Độ Về Cao Độ Thực Trong Z Của Cad

Mình là một trong những người vote trừ cho bạn. Thời điểm này bạn đã -11 điểm r ^^ Lý do vì sao thì bạn tự đọc lại các bài viết của chính mình sẽ hiểu. Lần đầu và cũng là lần cuối mong bạn nghĩ đến cảm giác người đọc / người muốn giúp bạn

Còn đây là quick code viết nhanh giúp bạn, hi vọng bạn xài được

(defun c:t2elev  (/ s...
>>

Mình là một trong những người vote trừ cho bạn. Thời điểm này bạn đã -11 điểm r ^^ Lý do vì sao thì bạn tự đọc lại các bài viết của chính mình sẽ hiểu. Lần đầu và cũng là lần cuối mong bạn nghĩ đến cảm giác người đọc / người muốn giúp bạn

Còn đây là quick code viết nhanh giúp bạn, hi vọng bạn xài được

(defun c:t2elev  (/ s p)
(vl-load-com)
(ssget '((0 . "TEXT")))
(vlax-for e (setq s (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-acad-object))))
	(vla-put-InsertionPoint
		e
		(vlax-3D-point
			(list (car (setq p (vlax-get e 'InsertionPoint)))(cadr p) (distof (vl-string-translate "," "." (vla-get-textstring e))))
		)
	)
)
(if s (vla-delete s))
)

<<

Filename: 391495_t2elev.lsp
Tác giả: ketxu
Bài viết gốc: 391526
Tên lệnh: udt
( Yêu C?u ) Nh? S?a Lisp Udt

Lisp trong link của bạn gửi :

(defun c:udt (/ ss tong ham tmp tt hstl oldim toe frome cur dt)
(prompt "\n Kich thuoc cua chuong trinh tinh theo don vi mm ")
(if (not hstlo) (setq hstlo 0.001))
(setq hstl (getreal (strcat "\n Nhap ti le chuyen doi don vi <" (rtos hstlo 2 3) "> :")))
(if (not hstl) (setq hstl hstlo) (setq hstlo hstl))
(if (not tpo) (setq tpo 2))
(setq tp (getint (strcat "\n Nhap So chu so thap phan <" (itoa tpo) ">...
>>

Lisp trong link của bạn gửi :

(defun c:udt (/ ss tong ham tmp tt hstl oldim toe frome cur dt)
(prompt "\n Kich thuoc cua chuong trinh tinh theo don vi mm ")
(if (not hstlo) (setq hstlo 0.001))
(setq hstl (getreal (strcat "\n Nhap ti le chuyen doi don vi <" (rtos hstlo 2 3) "> :")))
(if (not hstl) (setq hstl hstlo) (setq hstlo hstl))
(if (not tpo) (setq tpo 2))
(setq tp (getint (strcat "\n Nhap So chu so thap phan <" (itoa tpo) "> :")))
(if (not tp) (setq tp tpo) (setq tpo tp))
(setq oldim (getvar "Dimzin"))
(setvar "Dimzin" 0)
(prompt "\n Chon doi tuong de tinh dien tich hay Enter de tinh dien tich theo Pick diem ")
(setq
ss (ssget '((-4 . "<OR")(0 . "LWPOLYLINE")(0 . "REGION")(0 . "CIRCLE")(0 . "ARC")(-4 . "OR>")))
tong 0.0
ham (lambda (x) (command ".area" "o" x) (setq tong (+ tong (getvar "area"))))
tmp (mapcar 'ham (ss2ent ss))
)

(if (not ss)
(progn
(setq tong 0.0 ss (ssadd))
(while (setq p (getpoint "\n Pick vao vung tinh dien tich :"))
(setq frome (entlast))
(command ".boundary" p "")
(setq toe (entlast))

(setq cur frome)
(while (not (eq cur toe))
(setq
cur (entnext cur)
ss (ssadd cur ss))
(command "area" "S" "O" ss "" "")
(setq dt (getvar "area"))
(setq tong (+ tong dt))
)
(command "area" "A" "O" "L" "" "")
(setq dt (getvar "area"))
(setq tong (+ tong (* dt 2)))
(sssetfirst ss ss)
)
(command "erase" ss "")
))
(if (not (setq pt (getpoint "\n Chon diem dat text")))
(progn
(setq tt (entget (car (entsel "\nChon text ket qua: ")))
tong (vl-string-right-trim "." (vl-string-right-trim "0" (rtos tong)))
)
(entmod (subst (cons 1 (rtos (* (atof tong) hstl hstl) 2 tp)) (assoc 1 tt) tt))
)
(progn
(setq ht (getreal "\n Nhap chieu cao text"))
(command "text" pt ht 0 (rtos (* (atof tong) hstl hstl) 2 tp) "")
)
)

(setvar "Dimzin" oldim)


(princ)
)
;
(defun ss2ent(ss / sodt index lstent)
(setq
sodt (if ss (sslength ss) 0)
index 0
)
(repeat sodt
(setq ent (ssname ss index)
index (1+ index)
lstent (cons ent lstent)
)
)
(reverse lstent)
)
(princ "\nUpdate Area - free lisp from cadviet.com")
(princ "\nUse UDT command to start!")
(vl-load-com)

<<

Filename: 391526_udt.lsp
Tác giả: Ar_Chanwoo
Bài viết gốc: 15056
Tên lệnh: con
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)
Ai có thế sử dụng Lisp thuvien này thì giúp mình với ! Cứ mỗi lần mở ra Cad lại bị đơ!
http://www.cadviet.com/upfiles/New_Folder_2.rar

Filename: 15056_con.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 392250
Tên lệnh: ha
buy glucophage,

Filename: 392250_ha.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 392509
Tên lệnh: tt%C2%A0
Nhờ Viết Lisp Tạo Table Nhanh Cho Text Có Sẵn

Đây là lisp table được kẻ bằng line:

http://www.cadviet.com/upfiles/5/141736_text2table.lsp

(defun c:tt  (/ Make_line TxtWidth ent first-row hei i ins last-col lst-p1 lst-p2 max-wid old-sty p1 p2 poi-txt ss sty txt widt-txt make_text)
 (defun Make_line  (p1 p2)
  (entmakex (list (cons 0 "LINE") (cons 10 p1)...
>>

Đây là lisp table được kẻ bằng line:

http://www.cadviet.com/upfiles/5/141736_text2table.lsp

(defun c:tt  (/ Make_line TxtWidth ent first-row hei i ins last-col lst-p1 lst-p2 max-wid old-sty p1 p2 poi-txt ss sty txt widt-txt make_text)
 (defun Make_line  (p1 p2)
  (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "00-TIEU DE"))))
 (defun TxtWidth  (val h / txt minp maxp msp)
  (setq msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
  (setq txt (vla-addtext msp val (vlax-3d-point '(0 0 0)) h))
  (vla-getboundingbox txt 'minp 'maxp)
  (vla-erase txt)
  (- (car (vlax-safearray->list maxp)) (car (vlax-safearray->list minp))))
 ;; Main
 (if (setq ss (ssget '((0 . "*TEXT"))))
  (progn (setq old-sty (getvar "TEXTSTYLE"))
         (repeat (setq i (sslength ss))
          (setq ent (entget (ssname ss (setq i (1- i))))
                txt (cdr (assoc 1 ent))
                hei (cdr (assoc 40 ent))
                sty (cdr (assoc 7 ent))
                ins (cdr (assoc 10 ent)))
          (setq poi-txt (vl-sort (cons (cons ins txt) poi-txt)
                                 '(lambda (x y)
                                   (cond ((equal (cadr (car x)) (cadr (car y))) (< (car (car x)) (car (car y))))
                                         ((< (cadr (car x)) (cadr (car y)))))))))
         (foreach x  poi-txt
          (if (equal (car (car x)) (car (car (last poi-txt))) (* hei 2))
           (setq last-col (cons x last-col))))
         (setvar "TEXTSTYLE" sty)
         (foreach x last-col (setq widt-txt (cons (TxtWidth (cdr x) hei) widt-txt)))
         (setq max-wid (apply 'max widt-txt))
         (foreach x  poi-txt
          (if (equal (cadr (car x)) (cadr (car (last poi-txt))) hei)
           (setq first-row (cons (car x) first-row)
                 first-row (vl-sort first-row '(lambda (x y) (< (car x) (car y)))))))
         (setq first-row (cons (polar (last first-row) (* pi 0) (+ max-wid (* hei 2))) first-row))
         ;; Dat bang vi tri moi
         (defun make_text  (/ lst-make p-org poi poi-x poi-new first-new)
          (if (setq poi (getpoint "\nDiem chen bang: "))
           (progn (repeat (setq i (sslength ss))
                   (setq lst-make (cons (vl-remove-if '(lambda (x) (member (car x) '(-1 5 330 410))) (entget (ssname ss (setq i (1- i)))))
                                        lst-make)))
                  (setq p-org (car (vl-sort first-row '(lambda (x y) (< (car x) (car y))))))
                  (foreach x  lst-make
                   (setq poi-x (polar (cdr (assoc 10 x)) (angle p-org poi) (distance p-org poi)))
                   (setq x (subst (cons 10 poi-x) (assoc 10 x) x))
                   (entmakex x))
                  (foreach x  first-row
                   (setq poi-new   (polar x (angle p-org poi) (distance p-org poi))
                         first-new (cons poi-new first-new)))
                  (setq first-row first-new))))
         (make_text)
         ;; Ke bang
         (foreach x  first-row
          (setq p1 (polar (polar x (* pi 1.0) hei) (* pi 0.5) (* 1.5 hei)))
          (setq p2 (polar p1 (* pi 1.5) (* 2 hei (length last-col))))
          (setq lst-p1 (cons p1 lst-p1)
                lst-p2 (cons p2 lst-p2))
          (Make_line p1 p2))
         (setq lst-p1 (vl-sort lst-p1 '(lambda (x y) (< (car x) (car y)))))
         (setq i 0)
         (repeat (+ (length last-col) 1)
          (setq p1 (polar (car lst-p1) (* pi 1.5) (* hei 2 i))
                p2 (polar (last lst-p1) (* pi 1.5) (* hei 2 i)))
          (Make_line p1 p2)
          (setq i (1+ i)))
         (setvar "TEXTSTYLE" old-sty)))
 (princ))

1. Dòng đầu tiên phải đầy đủ text (không được bỏ trống như ở cột 1, ô phía dưới) và các text ở hàng này phải thẳng hàng (tức là điểm chèn phải cùng nằm trên đường nằm ngang).

2. Nếu không nhập điểm chèn bảng thì sẽ kẻ bảng đóng khung tại chỗ.

3. Table của cad thì có lẽ không cần như điểm 1, nhưng lisp sẽ dài dòng hơn.


<<

Filename: 392509_tt%C2%A0.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 392685
Tên lệnh: tt%C2%A0
Nhờ Viết Lisp Tạo Table Nhanh Cho Text Có Sẵn

Thì ra nhiều loại bảng, mỗi bảng có khoảng cách giữa các hàng lại khác nhau.

Lisp sửa lại này sẽ tự động dãn hàng theo Text có sẵn:

(defun c:tt  (/ Make_line TxtWidth list-deldups ||| ent first-row hei i ins last-col lst-p1 lst-p2 max-wid old-sty p1 p2 poi-txt ss sty txt widt-txt make_text dis)
 (defun Make_line  (p1 p2)
  (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11...
>>

Thì ra nhiều loại bảng, mỗi bảng có khoảng cách giữa các hàng lại khác nhau.

Lisp sửa lại này sẽ tự động dãn hàng theo Text có sẵn:

(defun c:tt  (/ Make_line TxtWidth list-deldups ||| ent first-row hei i ins last-col lst-p1 lst-p2 max-wid old-sty p1 p2 poi-txt ss sty txt widt-txt make_text dis)
 (defun Make_line  (p1 p2)
  (entmakex (list (cons 0 "LINE") (cons 10 p1) (cons 11 p2) (cons 8 "00-TIEU DE"))))
 (defun TxtWidth  (val h / txt minp maxp msp)
  (setq msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
  (setq txt (vla-addtext msp val (vlax-3d-point '(0 0 0)) h))
  (vla-getboundingbox txt 'minp 'maxp)
  (vla-erase txt)
  (- (car (vlax-safearray->list maxp)) (car (vlax-safearray->list minp))))
 (defun list-deldups  (lst)
    (if lst
      (cons (car lst) (list-deldups (vl-remove (car lst) (cdr lst))))))
 ;; Main
 (if (setq ss (ssget '((0 . "*TEXT"))))
  (progn (setq old-sty (getvar "TEXTSTYLE"))
         (repeat (setq i (sslength ss))
          (setq ent (entget (ssname ss (setq i (1- i))))
                txt (cdr (assoc 1 ent))
                hei (cdr (assoc 40 ent))
                sty (cdr (assoc 7 ent))
                ins (cdr (assoc 10 ent)))
          (setq poi-txt (list-deldups (cons (cons ins txt) poi-txt))
                poi-txt (vl-sort poi-txt
                                 '(lambda (x y)
                                   (cond ((equal (cadr (car x)) (cadr (car y))) (< (car (car x)) (car (car y))))
                                         ((< (cadr (car x)) (cadr (car y)))))))))
         (foreach x  poi-txt
          (if (equal (car (car x)) (car (car (last poi-txt))) (* hei 2))
           (setq last-col (cons x last-col))))
         (setvar "TEXTSTYLE" sty)
         (foreach x last-col (setq widt-txt (cons (TxtWidth (cdr x) hei) widt-txt)))
         (setq max-wid (apply 'max widt-txt))
         (foreach x  poi-txt
          (if (equal (cadr (car x)) (cadr (car (last poi-txt))) hei)
           (setq first-row (cons (car x) first-row)
                 first-row (vl-sort first-row '(lambda (x y) (< (car x) (car y)))))))
         (setq first-row (cons (polar (last first-row) (* pi 0) (+ max-wid (* hei 2))) first-row))
         ;; Dat bang vi tri moi
         (defun make_text  (/ lst-make p-org poi poi-x poi-j poi-new first-new)
          (if (setq poi (getpoint "\nDiem chen bang: "))
           (progn (repeat (setq i (sslength ss))
                   (setq lst-make (cons (vl-remove-if '(lambda (x) (member (car x) '(-1 5 330 410))) (entget (ssname ss (setq i (1- i)))))
                                        lst-make)))
                  (setq p-org (car (vl-sort first-row '(lambda (x y) (< (car x) (car y))))))
                  (foreach x  lst-make
                   (setq poi-x (polar (cdr (assoc 10 x)) (angle p-org poi) (distance p-org poi))
                         poi-j (polar (cdr (assoc 11 x)) (angle p-org poi) (distance p-org poi)))
                   (setq x (subst (cons 10 poi-x) (assoc 10 x) x))
                   (setq x (subst (cons 11 poi-j) (assoc 11 x) x))
                   (entmakex x))
                  (foreach x  first-row
                   (setq poi-new   (polar x (angle p-org poi) (distance p-org poi))
                         first-new (cons poi-new first-new)))
                  (setq first-row first-new))))
         (make_text)
         ;; Ke bang
         (setq dis (/ (distance (car (car last-col)) (car (last last-col))) (1- (length last-col))))
         (foreach x  first-row
          (setq p1 (polar (polar x (* pi 1.0) hei) (* pi 0.5) (* 0.75 dis))) ;hei 1.5
          (setq p2 (polar p1 (* pi 1.5) (* dis (length last-col)))) ;2 hei
          (setq lst-p1 (cons p1 lst-p1)
                lst-p2 (cons p2 lst-p2))
          (Make_line p1 p2))
         (setq lst-p1 (vl-sort lst-p1 '(lambda (x y) (< (car x) (car y)))))
         (setq i 0)
         (repeat (+ (length last-col) 1)
          (setq p1 (polar (car lst-p1) (* pi 1.5) (* dis i)) ;2 hei
                p2 (polar (last lst-p1) (* pi 1.5) (* dis i))) ;2 hei
          (Make_line p1 p2)
          (setq i (1+ i)))
         (setvar "TEXTSTYLE" old-sty)))
 (princ))​

 

+ Số cột phụ thuộc vào hàng đầu tiên.

+ Các hàng phải có khoảng cách đều.

Mình đang nghiên cứu viết cho AutocadTable, sẽ khắc phục được các vấn đề trên.


<<

Filename: 392685_tt%C2%A0.lsp
Tác giả: tien2005
Bài viết gốc: 392853
Tên lệnh: ktr
Lisp Vẽ Đường Line Tự Động Có Thêm Số Thứ Tự

đây nè bạn, line và text theo dúng layer của bản vẽ mẫu, textstyle  theo hiện hữu

(defun c:ktr (/ p1 p2 stx)
  (or num (setq num 1))
  (setq
    num	(cond ((getint
		 (strcat "\nSo thu tu bat dau <" (rtos num 2 0) ">: ")
	       )
	      )
	      (num)
	)
  )
  (while (and (setq p1 (getpoint "\nDiem dau: ")
		    p2 (getpoint "\nDiem cuoi: " p1)
	      )
	      (setq stx	(ssget "f" (list p1 p2) (list (cons 0 "text,mtext"))))
	 )
...
>>

đây nè bạn, line và text theo dúng layer của bản vẽ mẫu, textstyle  theo hiện hữu

(defun c:ktr (/ p1 p2 stx)
  (or num (setq num 1))
  (setq
    num	(cond ((getint
		 (strcat "\nSo thu tu bat dau <" (rtos num 2 0) ">: ")
	       )
	      )
	      (num)
	)
  )
  (while (and (setq p1 (getpoint "\nDiem dau: ")
		    p2 (getpoint "\nDiem cuoi: " p1)
	      )
	      (setq stx	(ssget "f" (list p1 p2) (list (cons 0 "text,mtext"))))
	 )
    (entmakex (list '(0 . "LINE")
		    (cons 8 "NET KIEM")
		    (cons 10 P1)
		    (cons 11 P2)
	      )
    )
    (entmakex (list '(0 . "TEXT")
		    (cons 8 "TCHU")
		    (cons 10 p1)
		    (cons 40 (* (cdr(assoc 40 (entget(ssname stx 0)))) 0.5))
		    (cons 1 (rtos num 2 0))
	      )
    )
    (setq num (1+ num))
  )

  (princ)
)

<<

Filename: 392853_ktr.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 392904
Tên lệnh: tt%C2%A0
[yêu cầu] Lisp chia đoạn thẳng!

Bạn tham khảo:

(defun c:tt  (/ els ent ety lst sodem soptu taphop)
 (if (setq taphop (ssget '((0 . "*LINE,ARC"))))
  (progn (setq soptu (sslength taphop)
               sodem    0)
         (repeat soptu
          (setq ent (ssname taphop...
>>

Bạn tham khảo:

(defun c:tt  (/ els ent ety lst sodem soptu taphop)
 (if (setq taphop (ssget '((0 . "*LINE,ARC"))))
  (progn (setq soptu (sslength taphop)
               sodem    0)
         (repeat soptu
          (setq ent (ssname taphop sodem)
                lst (assoc 0 (entget ent))
                ety (cdr lst))
          (cond ((eq ety "LWPOLYLINE") (princ (strcat "\nEm la:" ety)) (Thuc_hien_gi_do))
                ((eq ety "POLYLINE") (princ (strcat "\nEm la:" ety)) (Thuc_hien_gi_do))
                ((eq ety "LINE") (princ (strcat "\nEm la:" ety)) (Thuc_hien_gi_do))
                ((eq ety "ARC") (princ (strcat "\nEm la:" ety)) (Thuc_hien_gi_do)))
          (setq sodem (1+ sodem)))))
 (princ))
(defun Thuc_hien_gi_do () (princ ". Anh muon lam gi em?"))

+ Trong lsp của KangKung bạn có thể thay dòng này: (setq vlaobj (vlax-ename->vla-object obj)) bằng cụm này:

(if (wcmatch (cdr (assoc 0 (entget obj))) "ARC,LINE")
   (progn (command "_.PEDIT" obj "Y" "")
          (setq obj    (entlast)
                vlaobj (vlax-ename->vla-object obj)))
   (setq vlaobj (vlax-ename->vla-object obj)))

+ Sử dụng theo hướng này thì ARC sau khi chia nó không cong nữa mà thành Pline gấp khúc.


<<

Filename: 392904_tt%C2%A0.lsp
Tác giả: mrphuocvie
Bài viết gốc: 393206
Tên lệnh: getstyle
I have my own business http://www.optimsys.com/get-valtrex-night-morning.pptx tangible valtrex valacyclovir 500 mg harga axis card Onuoha, 29, was charged in U.S. District Court in Los Angeles with making threats affecting interstate commerce and st

http://www.neolithuania.lt/?best-generic-clonidine-working.pptx flames clonidine hydrochloride defined medical care prevented Virginia Gibson, a lawyer at the law firm Hogan Lovells,said the Bank of America verdict was a "big deal because itshows the scope of a tool the government has not used frequentlysince its inception."

Filename: 393206_getstyle.lsp
Tác giả: pphung183
Bài viết gốc: 393218
Tên lệnh: ele
Hiệu Chỉnh Đường Dùng Lệnh Le

Nguyện vọng 1 đây :) :

(defun c:Ele (/ getXdata SaVa dxf2va SetXdata doc ms p1 p2 s l l1 lst p3 p4 
pg lm type pt te pts obj lx)
(defun getXdata (obj / typ val)   
(vla-getxdata obj "" 'typ 'val) (if (and typ val) (apply 'mapcar (cons 'cons (list 
(vlax-safearray->list typ) (mapcar 'vlax-variant-value (vlax-safearray->list val)))))) )
(defun SaVa (mode lst)
(vlax-make-variant (vlax-safearray-fill (vlax-make-safearray mode
(cons 0 (1- (length...
>>

Nguyện vọng 1 đây :) :

(defun c:Ele (/ getXdata SaVa dxf2va SetXdata doc ms p1 p2 s l l1 lst p3 p4 
pg lm type pt te pts obj lx)
(defun getXdata (obj / typ val)   
(vla-getxdata obj "" 'typ 'val) (if (and typ val) (apply 'mapcar (cons 'cons (list 
(vlax-safearray->list typ) (mapcar 'vlax-variant-value (vlax-safearray->list val)))))) )
(defun SaVa (mode lst)
(vlax-make-variant (vlax-safearray-fill (vlax-make-safearray mode
(cons 0 (1- (length lst)))) lst)) )
(defun dxf2va (lst *typ *val / d)
(set *typ (SaVa vlax-vbInteger (mapcar 'car lst))) 
(set *val (SaVa vlax-vbVariant (mapcar '(lambda (x) (if (listp (setq d (cdr x))) 
(vlax-3D-point d) (vlax-make-variant d))) lst))) )
(defun SetXdata (obj lst) (dxf2va lst 'typ 'val) (vla-SetXData obj typ val) )
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)) ms (vla-get-ModelSpace doc))
(princ "\nChon cac Leaders...") (if (and (ssget '((0 . "LEADER"))) (setq p1 (getpoint 
"\nPick chon diem chuan cho cac diem goc cua Leaders...") p2 (polar p1 (* pi 0.5) 1)) ) 
(progn (vlax-for le (setq s (vla-get-ActiveSelectionSet doc)) (setq l (vlax-get le 'Coordinates) 
l1 (reverse (cdddr (reverse l)))) (repeat (/ (length l) 3) (setq lst (cons (list (car l) (cadr l) 
(caddr l)) lst)) (setq l (cdddr l))) (setq p3 (car lst) p4 (polar p3 pi 1) 
pg (inters p1 p2 p3 p4 nil)) (setq lm (append l1 pg))
(setq type (vla-get-type le) pt (vlax-3d-point pg) te (vla-AddMText ms pt 1 "")
pts (SaVa 5 lm)) (setq obj (vla-AddLeader ms pts te type)) (vla-Erase te) 
(if (setq lx (getXdata le)) (SetXdata obj lx) ) (vla-put-Coordinate obj 2 pt)
(vla-put-StyleName obj (vla-get-StyleName le)) (vla-put-layer obj (vla-get-layer le)) 
(vla-put-arrowheadsize obj (vla-get-arrowheadsize le)) (vla-put-DimensionLineColor obj 
(vla-get-DimensionLineColor le)) (vla-Erase le)) (vla-delete s) )) (princ))


<<

Filename: 393218_ele.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 393227
Tên lệnh: ss%C2%A0
List Tất Cả Layer, Teststyle, Dimstyle Trong Bản Vẽ Hiện Hành

Gửi bạn lsp đã sửa:

;;; GETSTYLE - SETSTYLE
(defun C:SS  (/ dcl_id ddiag dim dsts fname lay lst lyrs sty table_dst table_lyr table_tst tsts)
 (setvar "cmdecho" 0)
 ;;Get list of all Layer-Textstyle-Dimstyle
 (vlax-for lyr  (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
  (setq table_lyr (cons (vla-get-name lyr) table_lyr)))
 (vlax-for tst  (vla-get-textstyles (vla-get-activedocument...
>>

Gửi bạn lsp đã sửa:

;;; GETSTYLE - SETSTYLE
(defun C:SS  (/ dcl_id ddiag dim dsts fname lay lst lyrs sty table_dst table_lyr table_tst tsts)
 (setvar "cmdecho" 0)
 ;;Get list of all Layer-Textstyle-Dimstyle
 (vlax-for lyr  (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
  (setq table_lyr (cons (vla-get-name lyr) table_lyr)))
 (vlax-for tst  (vla-get-textstyles (vla-get-activedocument (vlax-get-acad-object)))
  (setq table_tst (cons (vla-get-name tst) table_tst)))
 (vlax-for dst  (vla-get-dimstyles (vla-get-activedocument (vlax-get-acad-object)))
  (setq table_dst (cons (vla-get-name dst) table_dst)))
 ;; Get-current style
 (setq lst (mapcar 'getvar '("CLAYER" "TEXTSTYLE" "DIMSTYLE"))
       lay (itoa (vl-position (car lst) table_lyr))
       sty (itoa (vl-position (cadr lst) table_tst))
       dim (itoa (vl-position (caddr lst) table_dst)))
 ;; Create Dialog
 (create_dialog)
 ;; Load dialog
 (if (not (new_dialog "getstyle" (setq dcl_id (load_dialog fname))))
  (exit))
 ;;Layer
 (set_tile "sel_lyr" lay)
 (start_list "sel_lyr")
 (mapcar 'add_list table_lyr)
 (end_list)
 ;;Textstyles
 (set_tile "sel_tst" sty)
 (start_list "sel_tst")
 (mapcar 'add_list table_tst)
 (end_list)
 ;;Dimstyles
 (set_tile "sel_dst" dim)
 (start_list "sel_dst")
 (mapcar 'add_list table_dst)
 (end_list)
 ;;Action
 (action_tile "accept" "(setq ddiag 2)(Assign_value)(done_dialog)")
 (action_tile "cancel" "(setq ddiag 1)(done_dialog)")
 (start_dialog)
 (unload_dialog dcl_id)
 (if (= ddiag 1)
  (princ "\n Cancelled!"))
 (if (= ddiag 2)
  (progn (alert (strcat "\nYou Selected Layer: " lyrs ", Textstyle: " tsts ", Dimstyle: " dsts))))
 ;; Delete DCL
 (vl-file-delete fname)
 (princ))
;;;----------------
(defun Assign_value  ()
 (setq lyrs (nth (atoi (get_tile "sel_lyr")) table_lyr)
       tsts (nth (atoi (get_tile "sel_tst")) table_tst)
       dsts (nth (atoi (get_tile "sel_dst")) table_dst))
 (mapcar 'setvar '("CLAYER" "TEXTSTYLE") (list lyrs tsts))
 (vla-put-activeDimstyle (vla-get-ActiveDocument (vlax-get-acad-object))
                         (vla-item (vla-get-Dimstyles (vla-get-ActiveDocument (vlax-get-acad-object))) dsts)))
;;;----------------
(defun create_dialog  (/ lst-dia fn)
 (setq lst-dia (list "getstyle: dialog {" "label = \"Select Layer, Textstyle, Dimstyle\";"
                     ": column { "
                      ": popup_list {"
                       "key = \"sel_lyr\";
     label = \"Select layer\";
     }"
                      ": popup_list {" "key = \"sel_tst\";
     label = \"Select textstyle\";
     }"
                      ": popup_list {" "key = \"sel_dst\";
     label = \"Select dimstyle\";
     }" "}" "ok_cancel ;}"))
 (setq fname (vl-filename-mktemp "getstyle.dcl")
       fn    (open fname "w"))
 (foreach x lst-dia (write-line x fn))
 (close fn))

1. Như trên.

2. Lỗi trong file của bạn: ở hàm Assign_value -> (get_tile key), key ở đây nằm phải trong "", xem lsp đã sửa.

3. DCL nằm trong file .lsp:

+ Nguyên tắc chung:

- dùng lsp tạo ra 1 file DCL nằm đâu đó trong máy mà Cad tự tìm đến được và load khi cần.

- dùng xong thì lsp xóa DCL đi.

+ Tham khảo: http://www.afralisp.net/dialog-control-language/tutorials/dcl-without-the-dcl-file-part-2.php


<<

Filename: 393227_ss%C2%A0.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 393292
Tên lệnh: ha
Tìm Tung ?? C?a ?i?m Trên ???ng Polyline Khi Bi?t Hoành ?? C?a Nó

?ây b?n!

(defun C:HA( / ent1 ent2 x y lst)
 (vl-load-com)
 (if
  (and
   (setq ent1 (car (entsel "Chon Polyline: ")))
   (setq x (getreal "\nNhap hoanh do X: "))
   (setq ent2 (entmakex (list '(0 . "XLINE") '(100 . "AcDbEntity") '(100 . "AcDbXline") (list 10 x 0 0) '(11 0.0 1.0 0.0))))
   (setq y (cadar (setq lst (#Inter:2Ent ent1 ent2 acExtendNone))))
   (= 1 (length...
>>

?ây b?n!

(defun C:HA( / ent1 ent2 x y lst)
 (vl-load-com)
 (if
  (and
   (setq ent1 (car (entsel "Chon Polyline: ")))
   (setq x (getreal "\nNhap hoanh do X: "))
   (setq ent2 (entmakex (list '(0 . "XLINE") '(100 . "AcDbEntity") '(100 . "AcDbXline") (list 10 x 0 0) '(11 0.0 1.0 0.0))))
   (setq y (cadar (setq lst (#Inter:2Ent ent1 ent2 acExtendNone))))
   (= 1 (length lst))
   (entdel ent2))
  y))
(defun #Inter:2Ent(ent1 ent2 flag / l r)
 (setq l (vlax-invoke (vlax-ename->vla-object ent1) 'intersectwith (vlax-ename->vla-object ent2) flag))
 (repeat (/ (length l) 3)
  (setq r (cons (list (car l) (cadr l) (caddr l)) r) l (cdddr l)))
 (reverse r))

<<

Filename: 393292_ha.lsp
Tác giả: lemanhhung0302
Bài viết gốc: 393404
Tên lệnh: ar
Cách Sử Dụng Array Mới Trong Autocad Với Lisp

Kể từ phiên bản AutoCAD 2012, hãng AutoDESK đã giới thiệu loại Array với rất nhiều cải tiến.
 
Tuy nhiên, dường như sự phức tạp trong việc lệnh Array cũng tỉ lệ thuận với tính năng của Array mới này.
 
Trong clip dưới đây, người viết muốn giới thiệu với bạn:

  • Lệnh ARRAYCLASSIC (hay ARRAY trong các phiên bản cũ)
  • Lệnh...
    >>

Kể từ phiên bản AutoCAD 2012, hãng AutoDESK đã giới thiệu loại Array với rất nhiều cải tiến.
 
Tuy nhiên, dường như sự phức tạp trong việc lệnh Array cũng tỉ lệ thuận với tính năng của Array mới này.
 
Trong clip dưới đây, người viết muốn giới thiệu với bạn:

  • Lệnh ARRAYCLASSIC (hay ARRAY trong các phiên bản cũ)
  • Lệnh ARRAY trong phiên bản mới 2012 2013 2014 2015 2016 2017...
  • Đặc biệt, lệnh AR được viết lại cho dễ sử dụng hơn. Bạn không cần quan tâm nhiều đến các thông số Columns, Rows, ... . Chỉ cần chọn đối tượng, xác định khoảng cách, là bạn đã có một Array vô cùng tiện lợi.

https://www.youtube.com/watch?v=rAzp-VpP690
 

(defun c:ar ( / ss p1 p2 therows thecols drows dcols)
	(vl-load-com)
	(setq ss (ssget "_:L"))
	(setq p1 (getpoint " Specify first point: "))
	(setq p2 (getpoint p1 " Specify second point: "))
	(if (and p1 p2)
		(progn
			(if (= (car p1) (car p2))
				(setq therows 2 thecols 1 drows (- (cadr p2) (cadr p1)) dcols (- (cadr p2) (cadr p1)))
				(if (= (cadr p1) (cadr p2))
					(setq therows 1 thecols 2 drows (- (car p2) (car p1)) dcols (- (car p2) (car p1)))
					(setq therows 2 thecols 2 drows (- (cadr p2) (cadr p1)) dcols (- (car p2) (car p1)))
				)
			)
			(vla-sendcommand
				(vla-get-activedocument (vlax-get-acad-object))
				(strcat "array\rp\r\rR\rROW\r" (itoa therows) "\n" (rtos drows 2 10) "\n\nCOL\r" (itoa thecols) "\r" (rtos dcols 2 10) "\r\r")
			)
		)
	)
	(princ "\nwww.tankhanh.com.vn")
	(princ)
)

 
 
http://www.cadviet.com/upfiles/5/9989_ar.lsp


<<

Filename: 393404_ar.lsp
Tác giả: duy782006
Bài viết gốc: 393546
Tên lệnh: hpd
Kiểm Tra Giúp Em File Lisp Hatch Nhanh Em Viết,

Cái thằng pick điểm chọn 1 vùng khép kín bằng lisp rất rách việc.

Mình viết đoạn này trong trường hợp điểm chọn có vùng khép kín ngon lành rồi bạn tìm thêm mà hoàn thiện nhé.

;;;--------------------------------------------------------------------------
(defun duy:hatchpicdiem (tenhatch tilehatch gochatch layerhatch / tenhatch tilehatch gochatch layerhatch)  
  (command "bhatch" "p" tenhatch...
>>

Cái thằng pick điểm chọn 1 vùng khép kín bằng lisp rất rách việc.

Mình viết đoạn này trong trường hợp điểm chọn có vùng khép kín ngon lành rồi bạn tìm thêm mà hoàn thiện nhé.

;;;--------------------------------------------------------------------------
(defun duy:hatchpicdiem (tenhatch tilehatch gochatch layerhatch / tenhatch tilehatch gochatch layerhatch)  
  (command "bhatch" "p" tenhatch tilehatch gochatch (getpoint "Chon diem") "") 
  (command "change" "last" "" "p" "la" layerhatch "")
(princ)
)
;;;--------------------------------------------------------------------------
(defun c:hpd ()
(duy:hatchpicdiem "ANSI31" "1000" "0" "khuat-9")
(princ)
)

<<

Filename: 393546_hpd.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 393638
Tên lệnh: edl%C2%A0
Nhờ Viết Lisp Thay Đổi Chiều Dài Đường Mũi Tên

Không biết thế này có đúng ý chủ thớt không??? (Dịch mãi mới ra ý của đề)

(defun c:EDL  (/ ang ept ent lpt lst lsn obj poi sel spt lst-coor)
 (vl-load-com)
 (or *delta* (setq *delta* 0))
 (setq *delta* (cond ((getdist (strcat "\nNhap so gia <" (rtos *delta*) ">: ")))
                    ...
>>

Không biết thế này có đúng ý chủ thớt không??? (Dịch mãi mới ra ý của đề)

(defun c:EDL  (/ ang ept ent lpt lst lsn obj poi sel spt lst-coor)
 (vl-load-com)
 (or *delta* (setq *delta* 0))
 (setq *delta* (cond ((getdist (strcat "\nNhap so gia <" (rtos *delta*) ">: ")))
                     (*delta*)))
 (while (setq sel (entsel))
  (if (eq (cdr (assoc 0 (entget (car sel)))) "LEADER")
   (progn (setq ent (car sel)
                poi (cadr sel)
                obj (vlax-ename->vla-object ent)
                lst (vl-remove-if-not '(lambda (x) (member (car x) '(10))) (entget ent))
                spt (cdr (car lst))
                ept (cdr (last lst))
                ang (angle spt ept)
                lsn (vl-remove (last (cdr lst)) (cdr lst)))
          (foreach x lsn (setq lpt (cons (cdr x) lpt)))
          (if (> (distance poi spt) (distance poi ept))
           (setq ang (angle (cdr (nth (- (length lst) 2) lst)) ept)
                 ept (polar ept ang *delta*))
           (setq ang (angle spt (cdr (nth 1 lst)))
                 spt (polar spt (+ ang pi) *delta*)))
          (if lsn
           (setq lst-coor (list spt (apply 'append (reverse lpt)) ept))
           (setq lst-coor (list spt ept)))
          (vlax-put obj 'Coordinates (apply 'append lst-coor)))
   (princ "\nDoi tuong da chon khong phai Leader...!"))
  (setq lpt nil))
 (princ))

<<

Filename: 393638_edl%C2%A0.lsp
Tác giả: vodoifx
Bài viết gốc: 393692
Tên lệnh: ds1
Xem Giúp Em Lisp Đánh Số Trang Bản Vẽ Sai Chỗ Nào Với Ạ.
(defun C:DS1()
(setq lay (getvar "clayer"))
(command "layer" "new" "9.Thai" "c" "9" "9.Thai" "")
(command "layer" "S" "9.Thai" "")
(command "style" "Thuong.Thai" ".VnArial Narrow" "" "" "" "" "" "")
;(setq Truoc (getstring "\nNhap vao nhung ki tu dung Truoc so trang: "))
;(if (or (= Truoc nil) (= Truoc "")) (setq Truoc ""))
(setq n (getint "\nTong So Trang <10>: ")) ;Tong So Trang
(if (or (= n nil) (= n "")) (setq n 10))
(setq BD (getint "\nSo thu tu...
>>
(defun C:DS1()
(setq lay (getvar "clayer"))
(command "layer" "new" "9.Thai" "c" "9" "9.Thai" "")
(command "layer" "S" "9.Thai" "")
(command "style" "Thuong.Thai" ".VnArial Narrow" "" "" "" "" "" "")
;(setq Truoc (getstring "\nNhap vao nhung ki tu dung Truoc so trang: "))
;(if (or (= Truoc nil) (= Truoc "")) (setq Truoc ""))
(setq n (getint "\nTong So Trang <10>: ")) ;Tong So Trang
(if (or (= n nil) (= n "")) (setq n 10))
(setq BD (getint "\nSo thu tu cua Trang Bat dau <1>: ")) ;So thu tu cua Trang Bat dau
(if (or (= BD nil) (= BD "")) (setq BD 1))
(setq Sau (getstring "\nNhap vao nhung ki tu dung Sau so trang: ")) ;Nhap vao nhung ki tu dung Sau so trang
(if (or (= Sau nil) (= Sau "")) (setq Sau ""))
(setq BN 1)
(Setq kc (getdist "\nNhap khoang cach giua cac trang <78.4>: ") )
(if (or (= kc nil) (= kc "")) (setq kc 78.4))
(Setq CaoChu (getdist "\nNhap chieu cao chu <0.4>: ") )
(if (or (= CaoChu nil) (= CaoChu "")) (setq CaoChu 0.4))
(setq G1 (Getpoint "\nChon Diem Bat dau Danh so Trang: "))
(setq oslast (getvar "OSMODE")) ; Lay thiet lap Osnap hien tai
(command "osnap" "") ;(command "osnap" "non")
;(Prompt "\nCad se tu dong chon Layer va Text Style hien thoi <Current>!!!")
(setq x (Car G1))
(setq y (Cadr G1))
(setq i 0)
(setq phuong (getstring " Phuong ngang X , Phuong doc Y <Y>: "))
( if ( = "x" phuong)
(progn
(repeat n
(setq ThuTu (itoa BD))
(setq Diem (list x y))
(setq NoiDung (strcat ThuTu Sau))
;(setq NoiDung (strcat Truoc ThuTu Sau))
(command "text" "s" "" "J" "M" Diem CaoChu "0" NoiDung "")
(setq y (- y kc))
(setq BD (+ BD BN))
)))
( if (( = phuong "y" ) or ( = phuong nil))
(progn
(repeat n
(setq ThuTu (itoa BD))
(setq Diem (list x y))
(setq NoiDung (strcat ThuTu Sau))
;(setq NoiDung (strcat Truoc ThuTu Sau))
(command "text" "s" "" "J" "M" Diem CaoChu "0" NoiDung "")
(setq x (+ x kc))
(setq BD (+ BD BN))
)))
(command "setvar" "OSMODE" oslast) ; Tra ve Thiet lap Osnap Ban dau ;(command "osnap" "endpoint")
(command "setvar" "clayer" lay)
(princ)
);

Đến If là nó báo lỗi. em tìm mãi ứ ra. ai giúp em với ạ

 

(setq phuong (getstring " Phuong ngang X , Phuong doc Y <Y>: "))
( if ( = "x" phuong)


<<

Filename: 393692_ds1.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 393716
Tên lệnh: edl%C2%A0
Nh? Vi?t Lisp Thay ??i Chi?u Dài ???ng M?i Tên

S?a l?i theo Y/c ?ây:

(defun c:EDL  (/ ang ept ent lpt lst lsn obj poi sel spt lst-coor i ss)
 (vl-load-com)
 (if (setq ss (ssget '((0 . "LEADER"))))
  (progn (or poi (setq poi "E"))
         (initget "E S")
         (setq poi (getstring (strcat "\nDiem thay doi  <" poi ">: ")))
         (if (eq...
>>

S?a l?i theo Y/c ?ây:

(defun c:EDL  (/ ang ept ent lpt lst lsn obj poi sel spt lst-coor i ss)
 (vl-load-com)
 (if (setq ss (ssget '((0 . "LEADER"))))
  (progn (or poi (setq poi "E"))
         (initget "E S")
         (setq poi (getstring (strcat "\nDiem thay doi  <" poi ">: ")))
         (if (eq poi "")
          (setq poi "E"))
         (or *delta* (setq *delta* 0))
         (setq *delta* (cond ((getdist (strcat "\nNhap so gia <" (rtos *delta*) ">: ")))
                             (*delta*)))
         (repeat (setq i (sslength ss))
          (setq ent (ssname ss (setq i (1- i)))
                obj (vlax-ename->vla-object ent)
                lst (vl-remove-if-not '(lambda (x) (member (car x) '(10))) (entget ent))
                spt (cdr (car lst))
                ept (cdr (last lst))
                lsn (vl-remove (last (cdr lst)) (cdr lst)))
          (foreach x lsn (setq lpt (cons (cdr x) lpt)))
          (if (eq poi "E")
           (setq ang (angle (cdr (nth (- (length lst) 2) lst)) ept)
                 ept (polar ept ang *delta*))
           (setq ang (angle spt (cdr (nth 1 lst)))
                 spt (polar spt (+ ang pi) *delta*)))
          (if lsn
           (setq lst-coor (list spt (apply 'append (reverse lpt)) ept))
           (setq lst-coor (list spt ept)))
          (vlax-put obj 'Coordinates (apply 'append lst-coor))
          (setq lpt nil))))
 (princ))

<<

Filename: 393716_edl%C2%A0.lsp
Tác giả: pphung183
Bài viết gốc: 393705
Tên lệnh: ele
Hiệu Chỉnh Đường Dùng Lệnh Le

Lisp nay chỉ theo 1 chiều đuoc thôi, nêu Le theo chiều khác hay các huong khac nhau thì không đươc.Bạn có thể viết cho phuong bất kỳ của Le được không

Code trên tôi viết tổng quát cho việc tạo và xóa objects Le. Có thể một lúc nào đó bạn tự viết cho mình trường hợp 2 và 3 nếu bạn có danh...

>>

Lisp nay chỉ theo 1 chiều đuoc thôi, nêu Le theo chiều khác hay các huong khac nhau thì không đươc.Bạn có thể viết cho phuong bất kỳ của Le được không

Code trên tôi viết tổng quát cho việc tạo và xóa objects Le. Có thể một lúc nào đó bạn tự viết cho mình trường hợp 2 và 3 nếu bạn có danh sách các points :D .

Trường hơp 1 có thể rút gọn lại cho Le theo chiều khác hay các huong khac nhau :) :

(defun c:Ele (/ doc p1 s l l1 lst p3 p4 a p2 pg lm)
(setq doc (vla-get-ActiveDocument (vlax-get-acad-object)))
(princ "\nChon cac Leaders...") (if (and (ssget '((0 . "LEADER"))) (setq p1 (getpoint 
"\nPick chon diem chuan cho cac diem goc cua Leaders...")) ) 
(progn (vlax-for le (setq s (vla-get-ActiveSelectionSet doc)) (setq l (vlax-get le 'Coordinates) 
l1 (reverse (cdddr (reverse l)))) (repeat (/ (length l) 3) (setq lst (cons (list (car l) (cadr l) 
(caddr l)) lst)) (setq l (cdddr l))) (setq p3 (car lst) p4 (cadr lst) a (angle p4 p3)
p2 (polar p1 (+ a (* pi 0.5)) 1) pg (inters p1 p2 p3 p4 nil)) (setq lm (append l1 pg))
(vlax-put le 'Coordinates lm) ) (vla-delete s) )) (princ))


<<

Filename: 393705_ele.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 393738
Tên lệnh: tt%C2%A0
Hiệu Chỉnh Đường Dùng Lệnh Le

Yêu cầu 2: (Chọn 1 leader nhập khoảng cách offset, số lượng, phía để tạo các leader mới theo kiểu offset)

(defun c:tt  (/ LWPoly ang clr ele ent i lma lpl lsp nle npl obi obj ole dis opl pt1 pt2 sll)
 (defun LWPoly  (lst)
  (entmakex (append (list (cons 0...
>>

Yêu cầu 2: (Chọn 1 leader nhập khoảng cách offset, số lượng, phía để tạo các leader mới theo kiểu offset)

(defun c:tt  (/ LWPoly ang clr ele ent i lma lpl lsp nle npl obi obj ole dis opl pt1 pt2 sll)
 (defun LWPoly  (lst)
  (entmakex (append (list (cons 0 "LWPOLYLINE")
                          (cons 100 "AcDbEntity")
                          (cons 100 "AcDbPolyline")
                          (cons 90 (length lst))
                          (cons 70 0))
                    (mapcar (function (lambda (p) p)) lst))))
 (princ "\nSelect a Leader...!")
 (if (setq ele (ssget "_+.:E:S" '((0 . "LEADER"))))
  (progn (setq ent (ssname ele 0)
               ole (vlax-ename->vla-object ent)
               clr (vla-get-DimensionLineColor ole)
               lsp (vl-remove-if-not '(lambda (x) (member (car x) '(10))) (entget ent))
               lma (vl-remove-if '(lambda (x) (member (car x) '(-1 5 10))) (entget ent)))
         (setq opl (LWPoly lsp)
               obj (vlax-ename->vla-object opl))
         (vla-put-color obj clr)
         (if (and (setq dis (getdist "\nOffset distance: "))
                  (setq sll (getint "\nNumber of Leader:"))
                  (setq pt1 (getpoint "\nSelect side to offset to: ")))
          (progn (setq pt2 (vlax-curve-getclosestpointto obj pt1 t)
                       ang (angle pt1 pt2))
                 (if (< pi ang (* pi 2))
                  (setq dis (- dis)))
                 (setq i 0)
                 (repeat sll
                  (setq obi (vla-offset obj (* dis (setq i (1+ i))))
                        npl (entlast)
                        lpl (vl-remove-if-not '(lambda (x) (member (car x) '(10))) (entget npl)))
                  (setq nle (vlax-ename->vla-object (entmakex (append lma lpl))))
                  (vla-put-arrowheadsize nle (vla-get-arrowheadsize ole))
                  (vla-put-DimensionLineColor nle clr)
                  (entdel npl))
                 (vla-erase obj)))))
 (princ))

<<

Filename: 393738_tt%C2%A0.lsp
Tác giả: whatcholingon
Bài viết gốc: 393662
Tên lệnh: dsc
[Yêu Cầu] Nhờ Viết Lisp Copy Tăng Số Cải Tiến

Trường hợp 1: Bạn có thể sử dụng lsp này (không biết bản quyền của bà con cô dì chú bác nào cả)

;;;=====Increasing copy=====
(defun c:dsc (/ ang x y ent tg tg1tg2 num_r num_c num_inc dis_r dis_c num top idnum
dx dy bottom inc tgnum attr attr_ent t_base b_base locat value
deci stnum loca1 loca2 tt count inctg inctg1 bpoint mx my nx ny bx by)
(setq idnum 0)
(while (/= idnum 1)
(setq ent (entsel "\nHay lua chon so ma ban muon copy...
>>

Trường hợp 1: Bạn có thể sử dụng lsp này (không biết bản quyền của bà con cô dì chú bác nào cả)

;;;=====Increasing copy=====
(defun c:dsc (/ ang x y ent tg tg1tg2 num_r num_c num_inc dis_r dis_c num top idnum
dx dy bottom inc tgnum attr attr_ent t_base b_base locat value
deci stnum loca1 loca2 tt count inctg inctg1 bpoint mx my nx ny bx by)
(setq idnum 0)
(while (/= idnum 1)
(setq ent (entsel "\nHay lua chon so ma ban muon copy : "))
(if ent
(progn
(setq e (car ent))
(setq tg (entget e))
(if (= (cdr (assoc 0 tg)) "TEXT") (setq idnum 1))
)
(princ)
)
)

(setq num_inc (getreal "\nHay nhap he so tang giam <1> : "))
(if (= num_inc nil) (setq num_inc 1))

(setq bpoint (getpoint "\nChon diem goc de copy : "))
(setq x (car bpoint))
(setq y (car(cdr bpoint)))

(if (and (= (cdr (assoc 72 tg)) 0) (= (cdr (assoc 73 tg)) 0))
(progn
(setq bx (car (cdr (assoc 10 tg))))
(setq by (car (cdr (cdr (assoc 10 tg)))))
)
(progn
(setq bx (car (cdr (assoc 11 tg))))
(setq by (car (cdr (cdr (assoc 11 tg)))))
)
)

(setq attr (cdr tg)) ;attr chua cac thuoc tinh cua Entity nguon
(setq tg (cdr (assoc 1 tg)))
(setq inc 0)
(setq tg1 "")
(setq t_base "")
(setq b_base "")
(setq idnum 0)
(setq top 0)
(setq bottom 0)
(setq stnum "")
(setq deci 0)
(repeat (strlen tg)
(if (or (and (> (ascii (setq tgnum (substr tg (- (strlen tg) inc) 1))) 47)
(< (ascii (setq tgnum (substr tg (- (strlen tg) inc) 1))) 58))
(= (ascii (setq tgnum (substr tg (- (strlen tg) inc) 1))) 32)
(= (ascii (setq tgnum (substr tg (- (strlen tg) inc) 1))) 46))
(progn
(if (= (ascii (setq tgnum (substr tg (- (strlen tg) inc) 1))) 46) (setq deci inc))
(if (= inc 0)
(progn
(setq idnum 1)
(if (= (ascii (setq tgnum (substr tg (- (strlen tg) inc) 1))) 46)
(setq b_base (strcat "." b_base)))
)
)
(if (= bottom 1) (progn (setq bottom 0) (setq idnum 1) (setq top 1)))
(if (and (= idnum 0) (= top 1)) (setq t_base (strcat tgnum t_base)))
(if (= idnum 1)
(progn
(if (and (= tgnum "0") (> inc 0)) (setq stnum (strcat stnum "0")) (setq stnum ""))
(setq tg1 (strcat tgnum tg1))
)
)
)
(if (= inc 0)
(progn
(setq b_base (strcat tgnum b_base))
(setq bottom 1)
)
(if (= bottom 1)
(setq b_base (strcat tgnum b_base))
(progn
(setq top 1)
(setq t_base (strcat tgnum t_base))
(if (= idnum 1) (setq idnum 0))
)
)
)
)
(setq inc (+ inc 1))
)

(if (= tg1 "") (exit))
(setq num (atof tg1))
(setq count 1)

(while (setq bpoint (getpoint "\nChon diem copy tiep theo : "))
(setq num (+ num num_inc))
(if (>= (strlen b_base) 3)
(cond
( (or (= "A" (strcase (substr b_base 2 1))
)
(= "B" (strcase (substr b_base 2 1))
)
)
(setq b_base (strcat (substr b_base 1 1) (chr (1+ (ascii (substr b_base 2 1))) ) (substr b_base 3)
)
)
)
((= "C" (strcase (substr b_base 2 1)))
(setq b_base (strcat (substr b_base 1 1) "A") )
)
)
(cond
( (or (= "A" (strcase (substr b_base 2 1))
)
(= "B" (strcase (substr b_base 2 1))
)
)
(setq b_base (strcat (substr b_base 1 1) (chr (1+ (ascii (substr b_base 2 1))) ) (substr b_base 3)
)
)
)
((= "C" (strcase (substr b_base 2 1)))
(setq b_base (strcat (substr b_base 1 1) "A") )
)
)
)
(setq value (strcat t_base (strcat stnum (rtos num 2 deci)) b_base))
(setq nx (car bpoint))
(setq ny (car(cdr bpoint)))
(setq dx (- nx x))
(setq dy (- ny y))
(setq mx (car (getvar "ucsxdir")))
(setq my (car (cdr (getvar "ucsxdir"))))
(setq loca1 (+ bx (* mx dx)))
(setq loca2 (+ by (* my dx)))
(setq mx (car (getvar "ucsydir")))
(setq my (car (cdr (getvar "ucsydir"))))
(setq loca1 (+ loca1 (* mx dy)))
(setq loca2 (+ loca2 (* my dy)))
(setq attr_ent (subst (cons 1 value) (assoc 1 attr) attr))
(if (and (= (cdr (assoc 72 attr_ent)) 0) (= (cdr (assoc 73 attr_ent)) 0))
(setq attr_ent (subst (list 10 loca1 loca2 0) (assoc 10 attr_ent) attr_ent))
(setq attr_ent (subst (list 11 loca1 loca2 0) (assoc 11 attr_ent) attr_ent))
)
(entmake attr_ent)
(setq count (+ count 1))
) ;end while
(princ)
)


<<

Filename: 393662_dsc.lsp

Trang 201/330

201