Jump to content
InfoFile
Tác giả: VoHoan
Bài viết gốc: 401460
Tên lệnh: kctt
Nhờ viết Lisp xác định lý trình và khoảng cách tới tim

Ngồi cả buổi tối chắp vá cóp nhặt từ các lisp lại thì được kết quả thế này, đưa lên cho ae nào cần thì dùng tạm vậy:

(defun c:KCTT( / oidos olddim e obj PL pr pt pt1 dis i)
(vl-load-com)
(command "CMDECHO" 0)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq olddim (getvar "dimzin"))
(setvar "dimzin" 0)

(setq e (car (entsel "\nChon tim tuyen")))
(setq obj...
>>

Ngồi cả buổi tối chắp vá cóp nhặt từ các lisp lại thì được kết quả thế này, đưa lên cho ae nào cần thì dùng tạm vậy:

(defun c:KCTT( / oidos olddim e obj PL pr pt pt1 dis i)
(vl-load-com)
(command "CMDECHO" 0)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq olddim (getvar "dimzin"))
(setvar "dimzin" 0)

(setq e (car (entsel "\nChon tim tuyen")))
(setq obj (vlax-ename->vla-object e))
(HLI e)

(setq PL (car (entsel "\nChon duong PL")))
(setq pr (vlax-curve-getEndParam PL) i 0)
(HLI PL)

(setq 	fn (getfiled "Chon file de ghi ket qua" "" "CSV" 1)
	fid (open fn "w")
)
(while (<= i pr)
(setq pt (vlax-curve-getPointAtParam PL i))
(setq pt1 (vlax-curve-getClosestPointTo obj pt))
(setq dis (distance pt pt1))
(setq i (1+ i))
(princ dis fid)
(princ "\n" fid)

)
(close fid)
(setvar "dimzin" olddim)
(setvar "osmode" oldos)
(command "undo" "end")
(Princ)
)

;---------------------------------
(defun HLI(enT)
(sssetfirst (ssadd enT (ssadd)) (ssadd enT (ssadd)))
)

<<

Filename: 401460_kctt.lsp
Tác giả: phongtran86
Bài viết gốc: 401484
Tên lệnh: 01
Nhờ Sửa Lisp Chuyển Nhanh Layer

e có tham khảo được 2 lisp này, sử dụng bình thường, giờ muốn nhờ mọi người ghép hộ e thành 1 lisp. yêu cầu lisp sau khi ghép: nếu chọn các đối tượng, dùng lệnh (đã được gán lệnh từ 01-->16 cho các layer) thì các đối tượng được chọn sẽ chuyển về layer...

>>

e có tham khảo được 2 lisp này, sử dụng bình thường, giờ muốn nhờ mọi người ghép hộ e thành 1 lisp. yêu cầu lisp sau khi ghép: nếu chọn các đối tượng, dùng lệnh (đã được gán lệnh từ 01-->16 cho các layer) thì các đối tượng được chọn sẽ chuyển về layer mình đã gán (màu đối tượng là by layer); nếu không chọn đối tượng nào, nhập lệnh (đã được gán lệnh từ 01-->16 cho các layer) thì layer đó sẽ là layer hiện hành.http://www.cadviet.com/upfiles/6/136661_chuyen_nhanh_layer_cho_doi_tuong.lsp

http://www.cadviet.com/upfiles/6/136661_chuyen_nhanh_layer_hien_hanh.lsp

(vl-load-com) ;;them vao dầu lisp thôi
(defun c:01() 
  (prompt "_.change ")
  (princ "\n thay doi layer sang layer netlien")
  (setq sset (ssget))
  (if (null sset)
	(progn
  	(princ "\nChuyen layer hien hanh")
(vl-cmdf "clayer" "01.Outline1") ;;;them dong nay nhe
  	(exit)
	) )
(command "_.change" sset "" "P" "la" "01.Outline1" "") ;muon doi layer khac thi ban doi ten layer netlien nhe
(princ))

sửa cho bạn 1 layer làm mẫu thôi. Thêm cái (vl-cmdf "clayer" "tên layer cần hiện hành") vào trc exit là dc


<<

Filename: 401484_01.lsp
Tác giả: phongtran86
Bài viết gốc: 401585
Tên lệnh: sl
Lisp Rãi Thép Sàn

mình c?ng có lisp này. v? mình up lên giúp b?n

(defun c:SL ( / a1 c)
(setq luu (getvar "osmode"))
(setq lay (getvar "clayer"))
;(command "layer" "s" "Defpoints" "")
;(command "osnap" "Perp,Near")
(setq a1 (getdist "\nCh\U+1ECDn kho\U+1EA3ng r\U+1EA3i th\U+00E9p: ")) 
(or (and a (or (= (type a) 'int) (= (type a)...
>>

mình c?ng có lisp này. v? mình up lên giúp b?n

(defun c:SL ( / a1 c)
(setq luu (getvar "osmode"))
(setq lay (getvar "clayer"))
;(command "layer" "s" "Defpoints" "")
;(command "osnap" "Perp,Near")
(setq a1 (getdist "\nCh\U+1ECDn kho\U+1EA3ng r\U+1EA3i th\U+00E9p: ")) 
(or (and a (or (= (type a) 'int) (= (type a) 'real))) (setq a 200))
(setq a (cond ((getdist (strcat "\nKho\U+1EA3ng c\U+00E1ch thanh th\U+00E9p <" (rtos a 2 2) ">:"))) (a)))
(or (and hbv (or (= (type hbv) 'int) (= (type hbv) 'real))) (setq hbv 10))
(setq hbv (cond ((getreal (strcat "\nduong kinh thep <" (rtos hbv 2 2) ">: "))) (hbv)))
(setq c (+ (/ a1 a) 1))
(while (setq ent (nentsel "\nCh\U+1ECDn ghi gi\U+00E1 tr\U+1ECB (Text ho\U+0103c ATT):" ))
(and (wcmatch (cdr (assoc 0 (entget (car ent)))) "ATTRIB,*TEXT")
(vla-put-textstring (vlax-ename->vla-object  (car ent)) (strcat (rtos c 2 0) "%%c" (rtos hbv 2 0) "a" (rtos a 2 0) ) )))
(SETVAR "clayer" lay)
(setvar "osmode" luu)
(princ)
)


<<

Filename: 401585_sl.lsp
Tác giả: Tot77
Bài viết gốc: 401692
Tên lệnh: hat
Hatch Scale Khác Nhau Ở 2 Bản Vẽ

Cái này là do biến MEASUREMENT, do khi tạo file bạn chọn acadiso.dwt hay acad.dwt thì units sẽ là english hay metric.

Nếu bạn muốn sửa lại theo cái hatch to thi dùng lisp này xem sao.

(defun c:hat ()
(setvar 'measurement 1)
(foreach x (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X" '((0 . "hatch"))))))
(command "-hatchedit" x "" "p"  "" (cdr (assoc 41 (entget x))) "" )
)
)


Filename: 401692_hat.lsp
Tác giả: duy782006
Bài viết gốc: 401789
Tên lệnh: cw
(Yêu C?u) Nh? Vi?t Lisp V? ?? Dày C?a ???ng ?c Ch?n.

Cái này ngày x?a trên cadviet ?ây

(DEFUN c:CW(/ SSET NET SSL M)

   (Princ "\nHay chon cac doi tuong muon chinh :")
   (Setq sset (Ssget))

  (if (Null sset)
  (princ "\nKhong chon duoc doi tuong nao")
)

   (IF (/= NIL SSET) (PROGN
   (SETQ SSL (SSLENGTH SSET))
   (INITGET 4)
   (SETQ NDT (GETDIST "\nNhap do rong : "))
   (IF (/= NIL NDT)
    (WHILE (> SSL 0)
      (SETQ M (SSNAME SSET (SETQ SSL (- SSL 1)) ))
      (IF (= (CDR (ASSOC '0...
>>

Cái này ngày x?a trên cadviet ?ây

(DEFUN c:CW(/ SSET NET SSL M)

   (Princ "\nHay chon cac doi tuong muon chinh :")
   (Setq sset (Ssget))

  (if (Null sset)
  (princ "\nKhong chon duoc doi tuong nao")
)

   (IF (/= NIL SSET) (PROGN
   (SETQ SSL (SSLENGTH SSET))
   (INITGET 4)
   (SETQ NDT (GETDIST "\nNhap do rong : "))
   (IF (/= NIL NDT)
    (WHILE (> SSL 0)
      (SETQ M (SSNAME SSET (SETQ SSL (- SSL 1)) ))
      (IF (= (CDR (ASSOC '0 (ENTGET M))) "LINE") 
          (COMMAND "PEDIT" M "Y" "W" NDT "") 
      ) 

      (IF (= (CDR (ASSOC '0 (ENTGET M))) "LWPOLYLINE") 
          (COMMAND "PEDIT" M "W" NDT "") 
      ) 

     (IF (= (CDR (ASSOC '0 (ENTGET M))) "ARC") 
          (COMMAND "PEDIT" M "Y" "W" NDT "") 
      ) 

     
    ) 
   )))
   (PRINC)
) 


<<

Filename: 401789_cw.lsp
Tác giả: tranduyquang25111
Bài viết gốc: 401868
Tên lệnh: mtl
[Yêu cầu] Lisp tạo viewport từ khung chọn bên model.

Chảo các anh. Nhờ các anh chỉnh sửa giúp lisp rev 2 này giúp mình với. Lisp này hiện tại đang đảo ngược thứ tự layout. Vd ở model sắp theo chiều ngang có 1 bản vẽ, từ trái qua phải. Thì layout tạo ra đầu tiên lại theo thứ tự từ phải sang trái. Thêm nữa, là chỉ chọn được trong model các hình chữ nhật nằm theo hàng ngang. Không chọn thêm một hàng khác được. Vậy nếu được nhờ cao nhân...
>>
Chảo các anh. Nhờ các anh chỉnh sửa giúp lisp rev 2 này giúp mình với. Lisp này hiện tại đang đảo ngược thứ tự layout. Vd ở model sắp theo chiều ngang có 1 bản vẽ, từ trái qua phải. Thì layout tạo ra đầu tiên lại theo thứ tự từ phải sang trái. Thêm nữa, là chỉ chọn được trong model các hình chữ nhật nằm theo hàng ngang. Không chọn thêm một hàng khác được. Vậy nếu được nhờ cao nhân sửa lại giúp mình như sau:
 
1. Có thể chọn sẵn khung bên model (có thẻ là xref, rectangel...)
2. Có thể chọn nhiều khung cả theo phương ngang và dọc.
3. Từ các khung đã chọn bên model, tao layout theo thứ tự: Từ trái qua phải, từ trên xuống dưới.
 
Cảm ơn các anh nhiều.
P/s: các rev sau của lisp chuyển tất cả các khung trong model thành viewport của 1 layout. Nhưng mình cần mỗi khung là 1 layout. Do đó chỉ dùng được rev 2 này.
 
 
 
 
;========LISP TAO VIEWPORT TREN LAYOUT BANG CACH CHON O MODEL========

;===============REV2=====================
(defun C:mtl()
  (command "UNDO" "BE")
  (setvar "OSMODE" 0)
  (setq taphop(ssget))
  (if (= TenLayout nil)
    (setq TenLayout1 "Layout")
    (setq TenLayout1 TenLayout))
  (setq TenLayout (getstring (strcat "\n Ten lay out: <" TenLayout1 "> ")))
  (if (= TenLayout nil)
    (setq TenLayout TenLayout1))
  (if (= Tyle nil)
    (setq Tyle1 1)
    (setq Tyle1 Tyle))
  (setq Tyle (getreal (strcat "\n Ty le: <" (rtos Tyle1 2 0) "> ")))
  (if (= Tyle nil)
    (setq Tyle Tyle1))
  (setq size(getstring "\n Kho giay in A0/A1/A2/A3/A4?: "))
  (setq soluong (sslength taphop))
  (setq index 0)
  (setq i 0)
  (while (< index soluong)
    (setq i(1+ i))
    (setq khung(ssname taphop index))
    (setq lst(acet-geom-vertex-list khung))
    (command "COPYCLIP" khung "")
    (command "LAYOUT" "N" (strcat TenLayout (rtos i 2 0)))
    (command "LAYOUT" "S" (strcat TenLayout (rtos i 2 0)))
    (command "ERASE" "ALL" "")
    (command "PASTECLIP" "0,0")
    (command "SCALE" (entlast) "" "0,0" (/ 1 tyle))
    (command "MVIEW" "O" (entlast))
    (command "MSPACE")
    (command "ZOOM" (nth 0 lst) (nth 2 lst))
    (command "PSPACE")
    (command "ZOOM" "E")
    (command "PLOT" "Y" "" "" size "M" "L" "N" "W" "0,0" (list (/ (abs(- (car (nth 2 lst)) (car (nth 0 lst)))) tyle) (/ (abs(- (cadr (nth 2 lst)) (cadr (nth 0 lst)))) tyle)) "1" "C" "Y" "acad" "Y" "N" "N" "N" "N" "Y" "N")
    (command "MODEL")
    (setq index (+ index 1))
    )
  (command "UNDO" "END")
  (setvar "OSMODE" 15359)
  (princ)
  )

<<

Filename: 401868_mtl.lsp
Tác giả: Tot77
Bài viết gốc: 401992
Tên lệnh: cpy
Nh? Vi?t Lisp

Có ph?i nh? này ko.

(defun c:cpy(/ EL HG KCACH OS PT SS TT)
(defun ssnext (el / l en) (if (setq en (entnext el)) (cons en (ssnext en)) ))
(defun ssfrom (sl / ss0) (setq ss0 (ssadd)) (mapcar '(lambda(x) (ssadd x ss0)) sl) ss0)
 
(prompt "\nChon cac doi tuong de copy:")
(setq ss (ssget)
pt (getpoint "\nDiem goc:")
hg (getangle pt "\nTheo huong:")
tt t
os (getvar 'osmode))
(setvar 'osmode 0)
 
(while tt    
(setq kcach...
>>

Có ph?i nh? này ko.

(defun c:cpy(/ EL HG KCACH OS PT SS TT)
(defun ssnext (el / l en) (if (setq en (entnext el)) (cons en (ssnext en)) ))
(defun ssfrom (sl / ss0) (setq ss0 (ssadd)) (mapcar '(lambda(x) (ssadd x ss0)) sl) ss0)
 
(prompt "\nChon cac doi tuong de copy:")
(setq ss (ssget)
pt (getpoint "\nDiem goc:")
hg (getangle pt "\nTheo huong:")
tt t
os (getvar 'osmode))
(setvar 'osmode 0)
 
(while tt    
(setq kcach (getstring (strcat "\nKhoang cach = " (if gl_kc (rtos gl_kc) (rtos (setq gl_kc 1)))  " <hoac nhan Z+Enter de ket thuc> :" )))
(cond ((and (/= kcach "") (/= (strcase kcach) "Z")) (setq kcach (atof kcach) gl_kc kcach))
((and (= kcach "") (/= gl_kc 0)) (setq kcach gl_kc))
((= (strcase kcach) "Z") (setq tt nil)))    
(if tt
(progn
(setq el (entlast))
(command "copy" ss "" pt (polar pt hg kcach))
(setq ss (ssfrom (ssnext el)))
))
)  
(setvar 'osmode os) (princ)
)


<<

Filename: 401992_cpy.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 402186
Tên lệnh: tt%C2%A0
Nh? Hoàn Thi?n

Lisp ?ây:

(defun c:tt  (/ pr_pt change-org xuat_kq elv ent lsp lst-l lst-r lsw txt x y sep cpr org)
?(vl-load-com)
 (defun pr_pt  (lst / i txt)
  (setq txt "")
  (repeat (setq i (length lst)) (setq txt (strcat txt (chr (nth (setq i (1- i)) (reverse lst))))))
  txt)
 (defun change-org  (poi / result doc)
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-put-activeucs...
>>

Lisp ?ây:

(defun c:tt  (/ pr_pt change-org xuat_kq elv ent lsp lst-l lst-r lsw txt x y sep cpr org)
?(vl-load-com)
 (defun pr_pt  (lst / i txt)
  (setq txt "")
  (repeat (setq i (length lst)) (setq txt (strcat txt (chr (nth (setq i (1- i)) (reverse lst))))))
  txt)
 (defun change-org  (poi / result doc)
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (vla-put-activeucs doc
                     (setq result (vla-add (vla-get-usercoordinatesystems doc)
                                           (vlax-3d-point poi)
                                           (vlax-3d-point (polar poi 0 1))
                                           (vlax-3d-point (polar poi (* 0.5 pi) 1))
                                           (pr_pt '(87 111 114 108 100))))))
 (defun xuat_kq  (str lst / filename fn i)
  (setq i 1)
  (setq filename (strcat (getvar 'dwgprefix) (vl-filename-base (getvar 'dwgname)) (pr_pt '(46 116 120 116))))
  (or (findfile fileName) (progn (setq fn (open fileName (pr_pt '(119)))) (close fn)))
  (setq fn (open fileName (pr_pt '(97))))
  (princ (strcat (pr_pt '(10)) (write-line str fn)))
  (foreach x  lst
   (princ (strcat (pr_pt '(10)) (write-line (strcat (itoa i) sep (car x) sep (cadr x)) fn)))
   (setq i (1+ i)))
  (close fn))
 (setq sep (pr_pt '(9)))
 (if (setq org (getpoint (pr_pt '(71 111 99 32 116 111 97 32 100 111 32 109 111 105 58 32))))
  (progn (change-org org)
         (while (and (setq ent (car
                                (entsel
                                 (pr_pt '(10 67 104 111 110 32 80 108 105 110 101 32 116 114 97 99 32 110 103 97 110 103 58 32)))))
                     (wcmatch (cdr (assoc 0 (entget ent))) (pr_pt '(42 80 79 76 89 76 73 78 69)))
                     (not (redraw ent 3))
                     (setq txt (car (entsel (pr_pt '(10 67 104 111 110 32 84 101 120 116 32 99 97 111 32 100 111 32 116 105 109 32 100 117 111 110 103 58 32)))))
                     (wcmatch (cdr (assoc 0 (entget txt))) (pr_pt '(42 84 69 88 84)))
                     (not (redraw ent 4))
                     (setq elv (distof (cdr (assoc 1 (entget txt))) 2))
                     (setq cpr (pr_pt '(76 105 115 112 32 99 114 101 97 116 101 100 32 66 121 32 81 117 111 99 77 97 110 104 48 52 116 116 45 67 97 100 86 105 101 116 46 99 111 109
                                        33))))
          (setq lsp (acet-geom-vertex-list ent))
          (foreach pt  lsp
           (setq x (car pt)
                 y (+ (cadr pt) elv))
           (cond ((< x 0) (setq lst-l (cons (list (rtos (abs x) 2 2) (rtos y 2 2)) lst-l)))
                 ((> x 0) (setq lst-r (cons (list (rtos x 2 2) (rtos y 2 2)) lst-r)))))
          (xuat_kq (strcat (pr_pt '(10 83 84 84))
                           sep
                           (pr_pt '(75 46 99 97 99 104))
                           sep
                           (pr_pt '(67 97 111 32 100 111 10 66 101 110 32 116 114 97 105 58)))
                   lst-l)
          (xuat_kq (pr_pt '(66 101 110 32 112 104 97 105 58)) (reverse lst-r))
          (setq lst-l nil
                lst-r nil))
         (change-org '(0 0 0))))
 (and cpr (princ cpr) (textscr))
 (and ent (redraw ent 4))
 (princ))

<<

Filename: 402186_tt%C2%A0.lsp
Tác giả: quansla
Bài viết gốc: 400276
Tên lệnh: ttttt
[Nhờ Vả] Xin Sửa Giúp Lisp Dành Cho Vẽ Mũi Tên Dạng Leader Bằng Lwpolyline

Em mới tìm ra một cách nhưng lại không đảm bảo được việc dùng như nguyen bản của Cad trong khi thực hiện lệnh LWPolyline (yêu cầu 2 ở #1)
(progn
(setq p0 (getpoint))
(command "PLINE" p0
(while (> (getvar "cmdactive") 0)
(progn
(if (setq p0 (getpoint p0 "\nChon diem tiep theo"))
(command p0)
(command "")
)))))
 
 
 
Cách thứ 2 dù chưa hoàn toàn giống nhưng đủ dùng (yêu...

>>

Em mới tìm ra một cách nhưng lại không đảm bảo được việc dùng như nguyen bản của Cad trong khi thực hiện lệnh LWPolyline (yêu cầu 2 ở #1)
(progn
(setq p0 (getpoint))
(command "PLINE" p0
(while (> (getvar "cmdactive") 0)
(progn
(if (setq p0 (getpoint p0 "\nChon diem tiep theo"))
(command p0)
(command "")
)))))
 
 
 
Cách thứ 2 dù chưa hoàn toàn giống nhưng đủ dùng (yêu cầu kiên quyết USER phải nhớ rõ tuỳ chọn của LWPOLYLINE)
(defun c:ttttt()
(setq p0 (getpoint))
(command "PLINE" p0
(while (> (getvar "cmdactive") 0)
(progn
(initget "A H L U W CE LC D C L R S")
(setq p0 (getpoint "\nChon diem tiep theo"))
(cond
((member (type p0) '(LIST STR)) (command p0))
((not p0) (command ""))
)
)
))
)


Cách cuối cùng có thể nghĩ được, ek toàn mình tự hỏi, tự trả lời

 

 

(defun c:ttttt()
(setq lst_str
(list
(cons "A" "Specify endpoint of arc or\n:")
(cons "L" "Specify next point or :")
(cons "H" "Specify starting/ending half-width ")
))
(setq p0 (getpoint "\nChon diem thu nhat"))
(setq str "Chon diem tiep theo")
(command "PLINE" p0
(while (> (getvar "cmdactive") 0)
(progn
(initget "A H L U W CE LC D C L R S")
(setq p0 (getpoint (strcat "\n" str)))
(cond
((= (type p0) 'LIST) (command p0))
((= (type p0) 'STR)
(command p0)
(setq str (cdr (assoc p0 lst_str)))
)
((not p0) (command ""))
)
)
))
)


<<

Filename: 400276_ttttt.lsp
Tác giả: hiepttr
Bài viết gốc: 402203
Tên lệnh: ve
Nhờ Các Bác Nghiên Cứu Và Viết Giúp Em Cái Lisp Này Với !

1. Bạn sửa lại tiêu đề cho đúng nội quy diễn đàn kẻo bị xóa đó :D

2. Về lisp bạn yêu cầu, mình viết đại với quy ước:

- Đường chuẩn là Line

- Đi từ điểm đầu đến điểm cuối của line thì đường tròn được vẽ ra phía trái của line khi c>0 (và ngược lại)

- Khi số dư của phép chia L/P = 0 lấy n = L/P

...

>>> Mần tới như sau:

:D :D...

>>

1. Bạn sửa lại tiêu đề cho đúng nội quy diễn đàn kẻo bị xóa đó :D

2. Về lisp bạn yêu cầu, mình viết đại với quy ước:

- Đường chuẩn là Line

- Đi từ điểm đầu đến điểm cuối của line thì đường tròn được vẽ ra phía trái của line khi c>0 (và ngược lại)

- Khi số dư của phép chia L/P = 0 lấy n = L/P

...

>>> Mần tới như sau:

:D :D :D

(defun c:VE( / line p c R info sta end ang len du n cen lst_cen)
(setq line (entsel "\nChon line chuan: ")
	  p (getreal "\nNhap P: ")
	  c (getreal "\nNhap C: ")
	  R (getreal "\nNhap R: ")
	  )
(if (and line p c R)
	(progn
		(setq info (entget (car line))
			  sta (cdr (car (vl-remove-if-not '(lambda (x) (= (car x) 10)) info)))
			  end (cdr (car (vl-remove-if-not '(lambda (x) (= (car x) 11)) info)))
			  ang (angle sta end)
			  len (distance sta end)
			  )
		(cond
			((> (setq du (rem len p)) 0)
				(setq n (1+ (fix (/ len p))))
				(setq cen (polar (polar sta ang (/ du 2)) (+ ang (/ pi 2)) c))
				)
			(t 
				(setq n (/ len p))
				(setq cen (polar (polar sta ang (/ p 2)) (+ ang (/ pi 2)) c))
				)
		)	  ;cond
		(setq lst_cen (list cen))
		(repeat (1- n)
			(setq cen (polar cen ang p)
			  lst_cen (cons cen lst_cen))
		)
		(mapcar '(lambda (x) (MakeCircle x R nil nil "Dg_tron" nil nil)) lst_cen)
	)
	(princ "*** Dau vao chua dung ! ***")
)	 ;if
(princ)
)
;=================================
(defun MakeCircle (point R Linetype LTScale Layer Color xdata)	
(entmakex (list '(0 . "CIRCLE")									
				(cons 8 (if Layer Layer (getvar "Clayer")))								  
				(cons 6 (if Linetype Linetype "bylayer"))									
				(cons 48 (if LTScale LTScale 1))								  
				(cons 62 (if Color Color 256))									
				(cons 10 point)									
				(cons 40 R)									
				(cons -3 (if xdata (list xdata) nil))))
);end
;=================================

<<

Filename: 402203_ve.lsp
Tác giả: hiepttr
Bài viết gốc: 402221
Tên lệnh: ve
Nhờ Các Bác Nghiên Cứu Và Viết Giúp Em Cái Lisp Này Với !

Thôi thì thử cái này, mình làm đại vậy :D

 

- Nếu n là số đường tròn thì p=(L1/(n-1)) đó bạn ^^

(defun c:VE( / line n c R A B info sta end ang len cen lst_cen)
(setq line (entsel "\nChon line chuan: ")
	  n (getint "\nNhap so duong tron n: ")
	  c (getdist "\nNhap khoang cach C: ")
	  R (getdist "\nNhap ban kinh R: ")
	  A (getdist "\nNhap A: ")
	  B (getdist "\nNhap B: ")
	  )
(if (and line n c R A...
>>

Thôi thì thử cái này, mình làm đại vậy :D

 

- Nếu n là số đường tròn thì p=(L1/(n-1)) đó bạn ^^

(defun c:VE( / line n c R A B info sta end ang len cen lst_cen)
(setq line (entsel "\nChon line chuan: ")
	  n (getint "\nNhap so duong tron n: ")
	  c (getdist "\nNhap khoang cach C: ")
	  R (getdist "\nNhap ban kinh R: ")
	  A (getdist "\nNhap A: ")
	  B (getdist "\nNhap B: ")
	  )
(if (and line n c R A B)
	(progn
		(setq info (entget (car line))
			  sta (cdr (car (vl-remove-if-not '(lambda (x) (= (car x) 10)) info)))
			  end (cdr (car (vl-remove-if-not '(lambda (x) (= (car x) 11)) info)))
			  ang (angle sta end)
			  len (distance sta end)
			  p (/ (- len A B) (1- n))
			  cen (polar (polar sta ang A) (+ ang (/ pi 2)) c)
			  lst_cen (list cen)
		)
		(repeat (1- n)
			(setq cen (polar cen ang p)
			  lst_cen (cons cen lst_cen))
		)
		(mapcar '(lambda (x) (MakeCircle x R nil nil "Dg_tron" nil nil)) lst_cen)
	)
	(princ "*** Dau vao chua dung ! ***")
)	 ;if
(princ)
)
;=================================
(defun MakeCircle (point R Linetype LTScale Layer Color xdata)	
(entmakex (list '(0 . "CIRCLE")									
				(cons 8 (if Layer Layer (getvar "Clayer")))								  
				(cons 6 (if Linetype Linetype "bylayer"))									
				(cons 48 (if LTScale LTScale 1))								  
				(cons 62 (if Color Color 256))									
				(cons 10 point)									
				(cons 40 R)									
				(cons -3 (if xdata (list xdata) nil))))
);end
;=================================

<<

Filename: 402221_ve.lsp
Tác giả: hiepttr
Bài viết gốc: 402254
Tên lệnh: ve
Nhờ Các Bác Nghiên Cứu Và Viết Giúp Em Cái Lisp Này Với !

Uh, thì nhập p, vẽ ra n đường tròn

Lần này thì cấm có sai :D . Sai là bạn sai chứ mình ko sai nhá :D :D :D

(defun c:VE( / line p n c R A B info sta end ang len cen lst_cen)
(setq line (entsel "\nChon line chuan: ")
	  p (getdist "\nNhap khoang cach p: ")
	  c (getdist "\nNhap khoang cach C: ")
	  R (getdist "\nNhap ban kinh R: ")
	  A (getdist "\nNhap A: ")
	  B (getdist "\nNhap B: ")
	  )
(if (and line p c R A...
>>

Uh, thì nhập p, vẽ ra n đường tròn

Lần này thì cấm có sai :D . Sai là bạn sai chứ mình ko sai nhá :D :D :D

(defun c:VE( / line p n c R A B info sta end ang len cen lst_cen)
(setq line (entsel "\nChon line chuan: ")
	  p (getdist "\nNhap khoang cach p: ")
	  c (getdist "\nNhap khoang cach C: ")
	  R (getdist "\nNhap ban kinh R: ")
	  A (getdist "\nNhap A: ")
	  B (getdist "\nNhap B: ")
	  )
(if (and line p c R A B)
	(progn
		(setq info (entget (car line))
			  sta (cdr (car (vl-remove-if-not '(lambda (x) (= (car x) 10)) info)))
			  end (cdr (car (vl-remove-if-not '(lambda (x) (= (car x) 11)) info)))
			  ang (angle sta end)
			  len (distance sta end)
			  n (if (equal (rem len p) 0 1e-9) (fix (/ len p)) (1+ (fix (/ len p))))
			  p (/ (- len A B) (1- n))
			  cen (polar (polar sta ang A) (+ ang (/ pi 2)) c)
			  lst_cen (list cen)
		)
		(repeat (1- n)
			(setq cen (polar cen ang p)
			  lst_cen (cons cen lst_cen))
		)
		(mapcar '(lambda (x) (MakeCircle x R nil nil "Dg_tron" nil nil)) lst_cen)
	)
	(princ "*** Dau vao chua dung ! ***")
)	 ;if
(princ)
)
;=================================
(defun MakeCircle (point R Linetype LTScale Layer Color xdata)	
(entmakex (list '(0 . "CIRCLE")									
				(cons 8 (if Layer Layer (getvar "Clayer")))								  
				(cons 6 (if Linetype Linetype "bylayer"))									
				(cons 48 (if LTScale LTScale 1))								  
				(cons 62 (if Color Color 256))									
				(cons 10 point)									
				(cons 40 R)									
				(cons -3 (if xdata (list xdata) nil))))
);end
;=================================

<<

Filename: 402254_ve.lsp
Tác giả: hiepttr
Bài viết gốc: 402304
Tên lệnh: ve
Nhờ Các Bác Nghiên Cứu Và Viết Giúp Em Cái Lisp Này Với !

:D :D :D

Đại loại là bạn đang bố trí gì gì đó, khống chế 2 đầu là A, B & bước @ <= p nhập vào

Nếu vậy thì rút kinh nghiệm lần sau yêu cầu cho rõ ràng từ đầu nhé :D

(defun c:VE( / line p n c R A B info sta end ang len L1 cen lst_cen)
(setq line (entsel "\nChon line chuan: ")
	  p (getdist "\nNhap khoang cach p: ")
	  c (getdist "\nNhap khoang cach C: ")
	  R (getdist "\nNhap ban...
>>

:D :D :D

Đại loại là bạn đang bố trí gì gì đó, khống chế 2 đầu là A, B & bước @ <= p nhập vào

Nếu vậy thì rút kinh nghiệm lần sau yêu cầu cho rõ ràng từ đầu nhé :D

(defun c:VE( / line p n c R A B info sta end ang len L1 cen lst_cen)
(setq line (entsel "\nChon line chuan: ")
	  p (getdist "\nNhap khoang cach p: ")
	  c (getdist "\nNhap khoang cach C: ")
	  R (getdist "\nNhap ban kinh R: ")
	  A (getdist "\nNhap A: ")
	  B (getdist "\nNhap B: ")
	  )
(if (and line p c R A B)
	(progn
		(setq info (entget (car line))
			  sta (cdr (car (vl-remove-if-not '(lambda (x) (= (car x) 10)) info)))
			  end (cdr (car (vl-remove-if-not '(lambda (x) (= (car x) 11)) info)))
			  ang (angle sta end)
			  len (distance sta end)
			  L1 (- len A B)
			  n (if (equal (rem L1 p) 0 1e-9) (fix (/ L1 p)) (1+ (fix (/ L1 p))))
			  p (/ L1 n)
			  cen (polar (polar sta ang A) (+ ang (/ pi 2)) c)
			  lst_cen (list cen)
		)
		(repeat n
			(setq cen (polar cen ang p)
			  lst_cen (cons cen lst_cen))
		)
		(mapcar '(lambda (x) (MakeCircle x R nil nil "Dg_tron" nil nil)) lst_cen)
	)
	(princ "*** Dau vao chua dung ! ***")
)	 ;if
(princ)
)
;=================================
(defun MakeCircle (point R Linetype LTScale Layer Color xdata)	
(entmakex (list '(0 . "CIRCLE")									
				(cons 8 (if Layer Layer (getvar "Clayer")))								  
				(cons 6 (if Linetype Linetype "bylayer"))									
				(cons 48 (if LTScale LTScale 1))								  
				(cons 62 (if Color Color 256))									
				(cons 10 point)									
				(cons 40 R)									
				(cons -3 (if xdata (list xdata) nil))))
);end
;=================================

<<

Filename: 402304_ve.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 402550
Tên lệnh: cls%C2%A0
Lisp Ch?nh Nét ??t Trong Cad


  • Members
  • bullet_black.pngbullet_black.png
  • 28 Bài viết
Điểm đánh giá: -2(bình thường)
 

Đã...
>>


  • Members
  • bullet_black.pngbullet_black.png
  • 28 Bài viết
Điểm đánh giá: -2(bình thường)
 

Đã gửi Hôm qua, 10:04 AM

Nhờ Các Bác Trên Diễn Đàn Viết Giúp Cho Em
lisp Thay đổi giá trị khoảng cách của nét đứt (linetype) :
Lisp sử dụng như sau:
a) Thay đổi giá trị với nét đứt được chọn thì nét đứt có thể co hoặc giãn khoảng cách nét đứt được chọn đó.
B) Thay đổi giá trị khoảng cách nét đứt của 1 nét chọn thì toàn bản vẽ mà có nét đó  có thể có hoặc giãn khoảng cách  (VD chọn vào nét hiddn  khi thay đổi K/C thì toàn bộ nét hiddn của toàn bản vẽ được thay đổi K/C và các nét khác vần giữ nguyên) .
Cám Ơn Các Bác!

Thử cái này xem:
 
(defun c:cls  (/ ent i lsc lty obj ss)
 (vl-load-com)
 (if (setq ss (ssget "_+.:E:S" '((0 . "*LINE,ARC,CIRCLE,ELLIPSE"))))
  (progn (setq ent (ssname ss 0)
               obj (vlax-ename->vla-object ent)
               lty (vla-get-linetype obj)
               lsc (vla-get-linetypescale obj))
         (setq lsc (cond ((getreal (strcat "\nLinetype-Scale <" (rtos lsc 2 2) ">: ")))
                         (lsc)))
         (if (setq ss (ssget "_X" (list (cons 0 "*LINE,ARC,CIRCLE,ELLIPSE") (cons 6 lty))))
          (repeat (setq i (sslength ss))
           (setq ent (ssname ss (setq i (1- i)))
                 obj (vlax-ename->vla-object ent))
           (vla-put-linetypescale obj lsc)))))
 (princ))
<<

Filename: 402550_cls%C2%A0.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 402493
Tên lệnh: tt%C2%A0
Viết Lisp Kéo Đường Pline Địa Chất Vào Đường Pline Tự Nhiên Bằng 2 Điểm Pick

+ 1 Thao tác cho tất cả TN thì khó lắm, vì mỗi TN phải chọn 2 điểm kia mà.

+ Chú ý khi dùng lsp, phải pick thứ tự theo lsp đòi hỏi (nghĩa là pick bên trái trước, bên phải sau).

(defun c:tt  (/ Line Polyline cmd col l-tmp lay lpn lpr lpt lsp lst-dc lst-ent lst-ptn lst-tn pgl pgr pl-tn pr1 pt1 ptl ptr ss pxl pxr)
 (defun Line  (p1 p2)
  (entmakex (list (cons 0 "LINE") (cons 10...
>>

+ 1 Thao tác cho tất cả TN thì khó lắm, vì mỗi TN phải chọn 2 điểm kia mà.

+ Chú ý khi dùng lsp, phải pick thứ tự theo lsp đòi hỏi (nghĩa là pick bên trái trước, bên phải sau).

(defun c:tt  (/ Line Polyline cmd col l-tmp lay lpn lpr lpt lsp lst-dc lst-ent lst-ptn lst-tn pgl pgr pl-tn pr1 pt1 ptl ptr ss pxl pxr)
 (defun Line  (p1 p2)
  (entmakex (list (cons 0 "LINE") (cons 10 (trans p1 1 0)) (cons 11 (trans p2 1 0)))))
 (defun Polyline  (lst col lay)
  (entmakex (list (cons 0 "POLYLINE") (cons 62 col) (cons 8 lay) (cons 10 '(0 0 0))))
  (mapcar (function (lambda (p) (entmake (list (cons 0 "VERTEX") (cons 10 (trans p 1 0)))))) lst)
  (entmakex (list (cons 0 "SEQEND"))))
 (setq cmd (getvar 'CMDECHO))
 (setvar 'CMDECHO 0)
 (vl-load-com)
 (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
 (if (and (setq ss (ssget '((0 . "*POLYLINE") (8 . "PLINEDIACHATTN,PLINETNTN"))))
          (setq ptl (getpoint "\nDiem ben trai: "))
          (setq ptr (getpoint "\nDiem ben phai: ")))
  (progn (setq lst-ent (acet-ss-to-list ss))
         (foreach x  lst-ent
          (if (wcmatch (cdr (assoc 8 (entget x))) "PLINETNTN")
           (progn (setq lpn   (acet-geom-vertex-list x)
                        lpn   (vl-remove-if-not '(lambda (x) (< (car ptl) (car x) (car ptr))) lpn)
                        pl-tn x)
                  (setq lst-tn (cons lpn lst-tn)))
           (setq lst-dc (cons x lst-dc))))
         (foreach x  lst-dc
          (if (wcmatch (cdr (assoc 8 (entget x))) "PLINEDIACHATTN")
           (progn (setq lsp (acet-geom-vertex-list x)
                        els (vl-remove-if '(lambda (x) (member x '(-1 5))) (entget x))
                        lpt (vl-remove-if '(lambda (x) (> (car x) (car ptl))) lsp)
                        pt1 (car (cdr (reverse lpt)))
                        lpr (vl-remove-if '(lambda (x) (< (car x) (car ptr))) lsp)
                        pr1 (cadr lpr)
                        lay (cdr (assoc 8 (entget x)))
                        col (cdr (assoc 62 (entget x))))
                  (or col (setq col 256))
                  (setq l-tmp (line pt1 (last lpt))
                        pgl   (acet-geom-intersectwith l-tmp pl-tn 1)
                        pgl   (vl-remove-if '(lambda (x) (> (cadr x) (cadr (trans ptl 1 0)))) pgl))
                  (and pgl (setq pgl (trans (car pgl) 0 1)))
                  (entdel l-tmp)
                  (setq l-tmp (line pr1 (car lpr))
                        pgr   (acet-geom-intersectwith l-tmp pl-tn 1)
                        pgr   (vl-remove-if '(lambda (x) (> (cadr x) (cadr (trans ptr 1 0)))) pgr))
                  (and pgr (setq pgr (trans (last pgr) 0 1)))
                  (entdel l-tmp)))
          (progn (if pgl
                  (setq pxl pgl)
                  (setq pxl ptl))
                 (if pgr
                  (setq pxr pgr)
                  (setq pxr ptr))
                 (setq lst-ptn (vl-remove-if-not '(lambda (x) (< (car pxl) (car x) (car pxr))) (car lst-tn)))
                 (Polyline (append (if pgl
                                    (append lpt (list pgl))
                                    lpt)
                                   lst-ptn
                                   (if pgr
                                    (append (list pgr) lpr)
                                    lpr))
                           col
                           lay)
                 (entdel x)))))
 (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
 (setvar 'CMDECHO cmd)
 (princ))

<<

Filename: 402493_tt%C2%A0.lsp
Tác giả: 790312
Bài viết gốc: 402831
Tên lệnh: tdt
[Yêu Cầu] Chỉnh Sửa Lisp

Mình sưu tầm được đoạn lisp ghi tọa độ điểm, nhưng ghi tọa độ làm tròn số sau dấu phẩy, nhờ các bác chỉnh lại cho lấy cả số sau dấu phẩy giùm mình với. Chân thành cảm ơn trước.

(defun c:tdt (/ tam oldos ss cao i)
(setq ent (ssname ss i))
(setq tam (cen ent))
(wa (strcat "(" (rtos (car tam) 2 0) "," (rtos (cadr tam) 2 0) ")") tam cao) 
(setq i (1+ i))
) 
(setvar "osmode"...
>>

Mình sưu tầm được đoạn lisp ghi tọa độ điểm, nhưng ghi tọa độ làm tròn số sau dấu phẩy, nhờ các bác chỉnh lại cho lấy cả số sau dấu phẩy giùm mình với. Chân thành cảm ơn trước.

(defun c:tdt (/ tam oldos ss cao i)
(setq ent (ssname ss i))
(setq tam (cen ent))
(wa (strcat "(" (rtos (car tam) 2 0) "," (rtos (cadr tam) 2 0) ")") tam cao) 
(setq i (1+ i))
) 
(setvar "osmode" oldos)
(princ)
)
;
(defun wa (txt p h / sty)
(setq sty (getvar "textstyle"))
(entmake (list (cons 0 "TEXT") (cons 7 sty) (cons 1 txt) (cons 10 p) (cons 11 p) 
(cons 72 1) (cons 73 2) (cons 40 h) (cons 41 1))
)
)
;
(defun cen (ent / p1 p2)
(vla-getboundingbox (vlax-ename->vla-object ent) 'p1 'p2)
(setq p1 (vlax-safearray->list p1)
p2 (vlax-safearray->list p2)
pt (mapcar '+ p1 p2)
pt (mapcar '* pt '(0.5 0.5 0.5))
)
pt
) 

<<

Filename: 402831_tdt.lsp
Tác giả: Tot77
Bài viết gốc: 402875
Tên lệnh: tes
Nh? Các Bác Giúp Em Gi?i Quy?t Bài Toán Này V?i !

Xài t?m cái này. Ch? dùng cho LWPOLYLINE.

(defun c:tes(/ D D1 D2 D3 DN DT E EG EL EL1 EL2 X Y)
(defun doimn (v a b) (command "change" v "" "P" "C" a "LT" b ""))
(defun laydinhr (e) (mapcar 'cdr (vl-remove-if-not '(lambda(x) (= 10 (car x))) (entget e))))
(defun line (a b m) (entmake (list '(0 . "LINE") (cons 10 a) (cons 11 b) (cons 62 m))))
 
(command "ucs" "w")
(setq e (car (entsel "\nChon polyline:"))
eg (laydinhr e)
dt (polar (car...
>>

Xài t?m cái này. Ch? dùng cho LWPOLYLINE.

(defun c:tes(/ D D1 D2 D3 DN DT E EG EL EL1 EL2 X Y)
(defun doimn (v a b) (command "change" v "" "P" "C" a "LT" b ""))
(defun laydinhr (e) (mapcar 'cdr (vl-remove-if-not '(lambda(x) (= 10 (car x))) (entget e))))
(defun line (a b m) (entmake (list '(0 . "LINE") (cons 10 a) (cons 11 b) (cons 62 m))))
 
(command "ucs" "w")
(setq e (car (entsel "\nChon polyline:"))
eg (laydinhr e)
dt (polar (car eg) (angle (car eg) (nth 2 eg)) (* 0.5 (distance (car eg) (nth 2 eg)) ))
dn (polar (car eg) (angle (nth 2 eg) (car eg)) (* 0.5 (distance (car eg) (nth 2 eg)) )))
 
(setq d (getreal "\nKich thuoc D:"))
(command "offset" (abs d) e (if (> d 0) dn dt) "") (setq el (entlast)) (doimn el 6 "continuous")
 
(setq d1 (getreal "\nKich thuoc D1:"))
(command "offset" d1 el dn "") (setq el1 (entlast)) (doimn el1 3 "continuous")
 
(setq d2 (getreal "\nKich thuoc D2:"))
(command "offset" d2 el dt "") (doimn (entlast) 3 "continuous")
 
(setq d3 (getreal "\nKich thuoc D3:"))
(command "offset" (+ d2 d3) el dt "") (setq el2 (entlast)) (doimn el2 3 "continuous") 
 
(mapcar '(lambda(x y) (line x y 3)) (laydinhr el1) (laydinhr el2))
(princ)
)

<<

Filename: 402875_tes.lsp
Tác giả: Tot77
Bài viết gốc: 402889
Tên lệnh: tes
Nhờ Các Bác Giúp Em Giải Quyết Bài Toán Này Với !

 Lisp trên chỉ cốt có cái nhìn "trực quan" về từng bước offset thôi. Còn muốn quét nhieu thì xài cái này.

(defun c:tes(/ D D1 D2 D3 DN DT E EG EL EL1 EL2 X Y)
(defun doimn (v a b) (command "change" v "" "P" "C" a "LT" b ""))
(defun laydinhr (e) (mapcar 'cdr (vl-remove-if-not '(lambda(x) (= 10 (car x))) (entget e))))
(defun line (a b m) (entmake (list '(0 . "LINE") (cons 10 a) (cons 11 b) (cons 62...
>>

 Lisp trên chỉ cốt có cái nhìn "trực quan" về từng bước offset thôi. Còn muốn quét nhieu thì xài cái này.

(defun c:tes(/ D D1 D2 D3 DN DT E EG EL EL1 EL2 X Y)
(defun doimn (v a b) (command "change" v "" "P" "C" a "LT" b ""))
(defun laydinhr (e) (mapcar 'cdr (vl-remove-if-not '(lambda(x) (= 10 (car x))) (entget e))))
(defun line (a b m) (entmake (list '(0 . "LINE") (cons 10 a) (cons 11 b) (cons 62 m))))
 
(command "ucs" "w")
(prompt "\nChon polyline:")
(setq d (getreal "\nKich thuoc D:")
d1 (getreal "\nKich thuoc D1:")
d2 (getreal "\nKich thuoc D2:")
d3 (getreal "\nKich thuoc D3:")
)
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LWPOLYLINE"))))))
(setq eg (laydinhr e)
dt (polar (car eg) (angle (car eg) (nth 2 eg)) (* 0.5 (distance (car eg) (nth 2 eg)) ))
dn (polar (car eg) (angle (nth 2 eg) (car eg)) (* 0.5 (distance (car eg) (nth 2 eg)) )))
 
(command "offset" (abs d) e (if (> d 0) dn dt) "") (setq el (entlast)) (doimn el 6 "continuous")
(command "offset" d1 el dn "") (setq el1 (entlast)) (doimn el1 3 "continuous")
(command "offset" d2 el dt "") (doimn (entlast) 3 "continuous")
(command "offset" (+ d2 d3) el dt "") (setq el2 (entlast)) (doimn el2 3 "continuous") 
 
(mapcar '(lambda(x y) (line x y 3)) (laydinhr el1) (laydinhr el2))
)
(princ)
)

<<

Filename: 402889_tes.lsp
Tác giả: 790312
Bài viết gốc: 402968
Tên lệnh: tdn
[Yêu Cầu] Gán Layer Cho Đối Tượng

Mình sưu tầm được một lisp, nhưng gán layer chưa đúng theo ý muốn, nhờ các bác chỉnh sửa gán cho đoạn thẳng là layer LINE, text là layer TEXT, 2 layer này đã có trên bản vẽ. Chân thành cảm ơn trước.

(defun C:tdn ()
(setvar "cmdecho" 0 )
(command "Undo" "Begin")
(setq om (getvar "osmode"))
(setq tapx '() tapy '() stt '() k 0
  	ten (getstring "\nNhap ten nut:"))
(if (not h) (setq h 1))
(setq caot1...
>>

Mình sưu tầm được một lisp, nhưng gán layer chưa đúng theo ý muốn, nhờ các bác chỉnh sửa gán cho đoạn thẳng là layer LINE, text là layer TEXT, 2 layer này đã có trên bản vẽ. Chân thành cảm ơn trước.

(defun C:tdn ()
(setvar "cmdecho" 0 )
(command "Undo" "Begin")
(setq om (getvar "osmode"))
(setq tapx '() tapy '() stt '() k 0
  	ten (getstring "\nNhap ten nut:"))
(if (not h) (setq h 1))
(setq caot1 (getreal (strcat "\nCao text < " (rtos h 2 0) " >:")))
(if caot1 (setq h caot1))
(setvar "osmode" 125)
(setq lacol (getvar "CEColor"))
;================================================
(While
(setq   D1 (getpoint "\nPick diem toa do:"))
(Progn
  (setvar "osmode" 0)
  (setq DX (getpoint "\nDiem dat text:" D1)
    	x (rtos (cadr D1) 2 4)
	y (rtos (car D1) 2 4)
TX (strcat "X="(rtos (Cadr D1) 2 4))
TY (strcat "Y="(rtos (Car D1) 2 4)) 
   	tapx (append tapx (list x))
   	tapy (append tapy (list y))
    	k   (+ 1 k)
    	N   (strcat ten (rtos k 2 0))
    	stt (append stt (list N))
  );setq
  (if (>= (car DX) (car D1))
(progn
(setq D2 (list (+ (car DX) (* 0.5 h)) (cadr DX)))  
	(command "text" "BL" D2 h 0 tX)
   (setq   TB  (textbox (entget(entlast)))
  	LC  (car TB)
	RC  (cadr TB)
  	di  (distance LC RC)
  PT3 (polar D2 0 (+ di (* 0.6 h)))
  pt4 (list (car D2) (- (cadr D2) (* 1.4 h)))
  pt5 (list (+ (car D2) di) (- (cadr D2) (* 1.4 h)))
  C   (polar PT3 0 (* 1.5 h))
   );setq
   (command "text" "F" PT4 PT5 h ty
     		"pline" D1 DX PT3 ""
     		"circle" (polar PT3 0 (* 1.5 h)) (* 1.5 h)
     		"circle" (polar PT3 0 (* 1.5 h)) (* 1.35 h)
     		"text" "m" (polar PT3 0 (* 1.5 h)) h 0 N
     		"CECOLOR" 8
   "circle" (polar PT3 0 (* 1.5 h)) (* 1.35 h)
	);command
   (setvar "CECOLOR" lacol)
);progn
   );if
  (if (< (car DX) (car D1))
(progn
   (setq D2 (list (- (car DX) (* 0.5 h)) (cadr DX)))  
	(command "text" "BR" D2 h 0 tx)
	(setq   TB  (textbox (entget(entlast)))
    	LC  (car TB)
   	RC  (cadr TB)
    	di  (distance LC RC)
	PT3 (polar D2 0 (- (+ di (* 0.6 h))))
	pt4 (list (- (car D2) di) (- (cadr D2) (* 1.4 h)))
	pt5 (list (car D2) (- (cadr D2) (* 1.4 h)))
	PT6 (list (- (car PT3) (* 3 h)) (cadr PT3))
	C   (polar PT3 0 (* 1.5 h))
	);setq
	(command "text" "F" PT4 PT5 h TY
       		"pline" D1 DX PT3 ""
       		"circle" (polar PT6 0 (* 1.5 h)) (* 1.5 h)
       		"text" "m" (polar PT6 0 (* 1.5 h)) h 0 N
       		"CECOLOR" 8
	"circle" (polar PT6 0 (* 1.5 h)) (* 1.35 h)
	);command
   (setvar "CECOLOR" lacol)
);progn
   );if
);progn
(setvar "osmode" 125)
);while
;=============================================
;tao bang thong ke
  (setq di (- di (* 2 h))
kc (* 2 di)
    	PT (getpoint"\nvi tri dat bang :")
	PTC (list (+ (* 2 kc) di (car PT)) (cadr PT))
   	p1 (list (car PT) (+ (cadr PT)(* 2 h)))
   	p2 (list (car PTC) (+ (cadr PTC)(* 2 h)))
   	p3 (list (car p1) (+ (cadr p1)(* 2 h)))
   	p4 (list (car p2) (+ (cadr p2)(* 2 h)))
  	PTD (list (+ (/ di 2) (car PT))  (+ h (cadr PT)))
  	PTX (list (+ di (/ di 2) (car PTD)) (cadr PTD))
  	PTY (list (+ kc (car PTX)) (cadr PTX))
   	p11 (list (+ (/ di 2) (car p1))  (+ h (cadr p1)))
   	p22 (list (+ di (/ di 2) (car p11)) (cadr p11))
   	p33 (list (+ kc (car p22)) (cadr p22))
   	L1 (list (+ di (car p3))(cadr p3))
   	L2 (list (+ kc (car L1))(cadr L1))
PTB (list (+ (* 0.5 (+ (* 2 kc) di)) (car PT)) (+ (cadr P3) (* 1.8 h)))
  	n (length tapx)
  	k 0
	);setq
  (setvar "osmode" 0)
  (command "CECOLOR" 3
"line" p1 p2 ""
    	"line" p3 p4 ""
    	"CECOLOR" 2
    	"text" "m" p11 h 0 "STT"
    	"text" "m" p22 h 0 "T&#228;a &#174;&#233; X"
    	"text" "m" p33 h 0 "T&#228;a &#174;&#233; Y"
    	"text" "m" pTB (* 1.3 h) 0 "%&#11;&#182;ng th&#232;ng k&#170; t&#228;a &#174;&#233; n&#243;t")  
  (while (< k n)
	(setq xx (nth k tapx)
  	yy (nth k tapy)
	tstt(nth k stt))
	(command "CECOLOR" 2
  	"text" "m" PTD h 0 tstt
     		"text" "m" PTX h 0 xx
     		"text" "m" PTY h 0 yy
  	"CECOLOR" 3
     		"line" PT PTC "")  
	(setq PT (list (car PT) (- (cadr PT)(* 2 h)))
      	PTC (list (+ (* 2 kc) di (car PT)) (cadr PT))
      	PTD (list (+ (/ di 2) (car PT))  (+ h (cadr PT)))
      	PTX (list (+ di (/ di 2) (car PTD)) (cadr PTD))
      	PTY (list (+ kc (car PTX)) (cadr PTX))
      	k (+ 1 k));setq
  );while
  (if (= k n)
	(setq PT (list (car PT) (+ (cadr PT)(* 2 h)))
      	PTC (list (+ (* 2 kc) di (car PT)) (cadr PT))
      	L11 (list (+ di (car PT))(cadr PT))
      	L22 (list (+ kc (car L11))(cadr L11))
	);setq
   );if
(command "CECOLOR" 3
"line" p3 PT ""
"line" p4 PTC ""
"line" L1 L11 ""
"line" L2 L22 "")
(setvar "CECOLOR" lacol)
(setvar "osmode" om)
(setvar "cmdecho" 1)
(prompt"\nxong\n")
(command "Undo" "End")
(princ)
);DONG toado

<<

Filename: 402968_tdn.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 403086
Tên lệnh: tdn%C2%A0
Gán Layer Cho ??i T??ng

Xem ?ã ?ng ý ch?a:

(defun C:tdn  (/ c caot1 d1 d2 di dx h k kc l1 l11 l2 l22 lacol lacur lc n om p1 p11 p2 p22 p3 p33 p4 pt pt3 pt4 pt5 pt6 ptb ptc ptd ptx pty rc stt tapx tapy tb ten tstt tx ty x xx
               y yy)
 (setvar "cmdecho" 0)
 (command "Undo" "Begin")
 (setq om (getvar "osmode")
       h  (getvar...
>>

Xem ?ã ?ng ý ch?a:

(defun C:tdn  (/ c caot1 d1 d2 di dx h k kc l1 l11 l2 l22 lacol lacur lc n om p1 p11 p2 p22 p3 p33 p4 pt pt3 pt4 pt5 pt6 ptb ptc ptd ptx pty rc stt tapx tapy tb ten tstt tx ty x xx
               y yy)
 (setvar "cmdecho" 0)
 (command "Undo" "Begin")
 (setq om (getvar "osmode")
       h  (getvar 'TEXTSIZE))
 (setq tapx '()
       tapy '()
       stt  '()
       k    0
       ten  (getstring "\nNhap ten nut:"))
 (setq h (cond ((getreal (strcat "\nCao text < " (rtos h 2 0) ">: ")))
               (h)))
 (setvar 'TEXTSIZE h)
 (setvar "osmode" 125)
 (setq lacol (getvar "CEColor")
       lacur (getvar "CLAYER"))
 ;;================================================
 (While (setq D1 (getpoint "\nPick diem toa do:"))
  (Progn (setvar "osmode" 0)
         (setq DX   (getpoint "\nDiem dat text:" D1)
               x    (rtos (cadr D1) 2 4)
               y    (rtos (car D1) 2 4)
               TX   (strcat "X=" (rtos (Cadr D1) 2 4))
               TY   (strcat "Y=" (rtos (Car D1) 2 4))
               tapx (append tapx (list x))
               tapy (append tapy (list y))
               k    (+ 1 k)
               N    (strcat ten (rtos k 2 0))
               stt  (append stt (list N)))
         (if (>= (car DX) (car D1))
          (progn (setq D2 (list (+ (car DX) (* 0.5 h)) (cadr DX)))
                 (command "CLAYER" "TEXT" "text" "BL" D2 h 0 tX)
                 (setq TB  (textbox (entget (entlast)))
                       LC  (car TB)
                       RC  (cadr TB)
                       di  (distance LC RC)
                       PT3 (polar D2 0 (+ di (* 0.6 h)))
                       pt4 (list (car D2) (- (cadr D2) (* 1.4 h)))
                       pt5 (list (+ (car D2) di) (- (cadr D2) (* 1.4 h)))
                       C   (polar PT3 0 (* 1.5 h)))
                 (command "text"
                          "F"
                          PT4
                          PT5
                          h
                          ty
                          "CLAYER"
                          "LINE"
                          "pline"
                          D1
                          DX
                          PT3
                          ""
                          "circle"
                          (polar PT3 0 (* 1.5 h))
                          (* 1.5 h)
                          "circle"
                          (polar PT3 0 (* 1.5 h))
                          (* 1.35 h)
                          "CLAYER"
                          "TEXT"
                          "text"
                          "m"
                          (polar PT3 0 (* 1.5 h))
                          h
                          0
                          N
                          "CLAYER"
                          "LINE"
                          "CECOLOR"
                          8
                          "circle"
                          (polar PT3 0 (* 1.5 h))
                          (* 1.35 h))
                 (setvar "CECOLOR" lacol)))
         (if (< (car DX) (car D1))
          (progn (setq D2 (list (- (car DX) (* 0.5 h)) (cadr DX)))
                 (command "CLAYER" "TEXT" "text" "BR" D2 h 0 tx)
                 (setq TB  (textbox (entget (entlast)))
                       LC  (car TB)
                       RC  (cadr TB)
                       di  (distance LC RC)
                       PT3 (polar D2 0 (- (+ di (* 0.6 h))))
                       pt4 (list (- (car D2) di) (- (cadr D2) (* 1.4 h)))
                       pt5 (list (car D2) (- (cadr D2) (* 1.4 h)))
                       PT6 (list (- (car PT3) (* 3 h)) (cadr PT3))
                       C   (polar PT3 0 (* 1.5 h)))
                 (command "CLAYER"
                          "TEXT"
                          "text"
                          "F"
                          PT4
                          PT5
                          h
                          TY
                          "CLAYER"
                          "LINE"
                          "pline"
                          D1
                          DX
                          PT3
                          ""
                          "circle"
                          (polar PT6 0 (* 1.5 h))
                          (* 1.5 h)
                          "CLAYER"
                          "TEXT"
                          "text"
                          "m"
                          (polar PT6 0 (* 1.5 h))
                          h
                          0
                          N
                          "CLAYER"
                          "LINE"
                          "CECOLOR"
                          8
                          "circle"
                          (polar PT6 0 (* 1.5 h))
                          (* 1.35 h))
                 (setvar "CECOLOR" lacol))))
  (setvar "osmode" 125))
 ;;=============================================
 ;;tao bang thong ke
 (setq di  (- di (* 2 h))
       kc  (* 2 di)
       PT  (getpoint "\nvi tri dat bang :")
       PTC (list (+ (* 2 kc) di (car PT)) (cadr PT))
       p1  (list (car PT) (+ (cadr PT) (* 2 h)))
       p2  (list (car PTC) (+ (cadr PTC) (* 2 h)))
       p3  (list (car p1) (+ (cadr p1) (* 2 h)))
       p4  (list (car p2) (+ (cadr p2) (* 2 h)))
       PTD (list (+ (/ di 2) (car PT)) (+ h (cadr PT)))
       PTX (list (+ di (/ di 2) (car PTD)) (cadr PTD))
       PTY (list (+ kc (car PTX)) (cadr PTX))
       p11 (list (+ (/ di 2) (car p1)) (+ h (cadr p1)))
       p22 (list (+ di (/ di 2) (car p11)) (cadr p11))
       p33 (list (+ kc (car p22)) (cadr p22))
       L1  (list (+ di (car p3)) (cadr p3))
       L2  (list (+ kc (car L1)) (cadr L1))
       PTB (list (+ (* 0.5 (+ (* 2 kc) di)) (car PT)) (+ (cadr P3) (* 1.8 h)))
       n   (length tapx)
       k   0) ;setq
 (setvar "osmode" 0)
 (command "line"
          p1
          p2
          ""
          "line"
          p3
          p4
          ""
          "CLAYER"
          "TEXT"
          "text"
          "m"
          p11
          h
          0
          "STT"
          "text"
          "m"
          p22
          h
          0
          "T&#228;a &#174;&#233; X"
          "text"
          "m"
          p33
          h
          0
          "T&#228;a &#174;&#233; Y"
          "text"
          "m"
          pTB
          (* 1.3 h)
          0
          "%&#11;&#182;ng th&#232;ng k&#170; t&#228;a &#174;&#233; n&#243;t")
 (while (< k n)
  (setq xx   (nth k tapx)
        yy   (nth k tapy)
        tstt (nth k stt))
  (command "CLAYER" "TEXT" "text" "m" PTD h 0 tstt "text" "m" PTX h 0 xx "text" "m" PTY h 0 yy "CLAYER" "LINE" "line" PT PTC "")
  (setq PT  (list (car PT) (- (cadr PT) (* 2 h)))
        PTC (list (+ (* 2 kc) di (car PT)) (cadr PT))
        PTD (list (+ (/ di 2) (car PT)) (+ h (cadr PT)))
        PTX (list (+ di (/ di 2) (car PTD)) (cadr PTD))
        PTY (list (+ kc (car PTX)) (cadr PTX))
        k   (+ 1 k)))
 (if (= k n)
  (setq PT  (list (car PT) (+ (cadr PT) (* 2 h)))
        PTC (list (+ (* 2 kc) di (car PT)) (cadr PT))
        L11 (list (+ di (car PT)) (cadr PT))
        L22 (list (+ kc (car L11)) (cadr L11))))
 (command "line" p3 PT "" "line" p4 PTC "" "line" L1 L11 "" "line" L2 L22 "")
 (setvar "CECOLOR" lacol)
 (setvar "CLAYER" lacur)
 (setvar "osmode" om)
 (setvar "cmdecho" 1)
 (princ "\nxong\n")
 (command "Undo" "End")
 (princ))

<<

Filename: 403086_tdn%C2%A0.lsp

Trang 206/303

206