Jump to content
InfoFile
Tác giả: pawuta
Bài viết gốc: 338292
Tên lệnh: trx
Nhờ viết Lisp thay đổi lệnh Trim (TR)

 

Slow code cho bạn đây. Chọn 2 line rồi chọn những line cần cắt.

(defun c:trx (/ A B SS TT10A TT10B TT11A...
>>

 

Slow code cho bạn đây. Chọn 2 line rồi chọn những line cần cắt.

(defun c:trx (/ A B SS TT10A TT10B TT11A TT11B)
(defun dxf(id v) (cdr (assoc id (entget v))))
(command "undo" "be") (setvar 'cmdecho 0)
(princ "\nChon 2 line:")
(while (/= 2 (length (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LINE")))))))))
(Alert "\nChi chon 2 line!!")
)
(setq tt10a (dxf 10 (car ss))
tt11a (dxf 11 (car ss))
tt10b (dxf 10 (last ss))
tt11b (dxf 11 (last ss))
)
 
(princ "\nChon cac line bi cat:") 
(foreach v (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LINE"))))))
(if (and (setq a (inters tt10a tt11a (dxf 10 v) (dxf 11 v)))
(setq b (inters tt10b tt11b (dxf 10 v) (dxf 11 v))))
(command "trim" (car ss) (last ss) "" (dxf 10 v) (dxf 11 v) "")))
(command "undo" "e") (setvar 'cmdecho 1)
(princ)
)

Cảm ơn bạn Tot77 nhiều đã làm theo đúng ý mình, nhưng chỉ có tác dụng với Line thôi hả bạn, bạn có thể chỉnh lại một chút xíu là có thể áp dụng cho Line, Pline, Xline, Rectang, Circle không. Thanks bạn nhiều! chúc các bạn buổi tối vui vẻ !!!


<<

Filename: 338292_trx.lsp
Tác giả: duy782006
Bài viết gốc: 439375
Tên lệnh: rdpl
nhờ viết lisp đánh số thứ tự đỉnh Pline và đo kích thước tự động

Sửa vầy đi. 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun pline>listdinh (curve / listd)
(if (wcmatch (cdr(assoc 0 (entget curve))) "*POLYLINE")
  (foreach x (entget curve) (if (= (car x) 10) (setq listd (append listd (list(cdr x))))))
)
listd)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:rdpl...
>>

Sửa vầy đi. 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun pline>listdinh (curve / listd)
(if (wcmatch (cdr(assoc 0 (entget curve))) "*POLYLINE")
  (foreach x (entget curve) (if (= (car x) 10) (setq listd (append listd (list(cdr x))))))
)
listd)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:rdpl ()
(setq ddd (car (entsel "\nChon Pline:")))
(setq tapdinh (cdr (pline>listdinh ddd)))
(setq tendinh 0)
(foreach tddinh tapdinh 
(setq tendinh (+ 1 tendinh))
(setq tendinhnoi (strcat "D" (rtos tendinh 2 0)))
(entmake (list (cons 0 "TEXT")(cons 10 tddinh)(cons 11 tddinh)(cons 40 1)(cons 50 0)(cons 72 0)(cons 1 tendinhnoi)(cons 7 (getvar "TEXTSTYLE"))(cons 8 "layerkhac_text")(cons 62 256))) 
(cond
((/= tendinh 1) (command ".DIMALIGNED" "_non" dinhcu "_non" tddinh "_non" tddinh))
)
(setq dinhcu tddinh)
)
)

 


<<

Filename: 439375_rdpl.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 439403
Tên lệnh: ha
Tính độ dài đường Spline


(defun C:HA(/ ent)
 (setq ent (car (entsel "\nChon Spline: ")))
 (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)))


Filename: 439403_ha.lsp
Tác giả: khanh10
Bài viết gốc: 422532
Tên lệnh: can
SỬA GIÚP MÌNH LISP DÙNG HỘP THOẠI DIALOG?

Mình có sửa lisp theo sự giúp đỡ của bạn @Thaistreetz nhưng có vài điều mình không hiểu, mong được các bạn giúp đỡ.

Trong biến danh sách dùng *canopy* và canopy thì khác nhau chổ nào vậy? Mục đích của đoạn code này...

>>

Mình có sửa lisp theo sự giúp đỡ của bạn @Thaistreetz nhưng có vài điều mình không hiểu, mong được các bạn giúp đỡ.

Trong biến danh sách dùng *canopy* và canopy thì khác nhau chổ nào vậy? Mục đích của đoạn code này là gì:  (foreach l dcl_code (write-line l file_dcl)).

Với thêm nhờ các bạn bổ sung giúp mình khi nhập dữ liệu tại edit_box này xong thì enter sẽ nhảy con trỏ xuống edit_box dưới, mình sửa hoài mà không được.

Ah, thêm cái nữa là sao mình dùng lệnh: (setq i (atof  (get_tile "slope"))) thì lại không lấy được giá trị của "slope trong hộp thoại nhỉ? Cám ơn các bạn nhiều!

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/170843-s%E1%BB%ADa-gi%C3%BAp-m%C3%ACnh-lisp-d%C3%B9ng-h%E1%BB%99p-tho%E1%BA%A1i-dialog/
(defun mc (/ p q1 q2 q3 q4 q5 q6 q7 oldos tana a sec1 sec2 c d1 d2)
(setq p (getpoint "\nNhap chon vi tri dat:"))
(setq tana (/ i 100))
(setq a (atan tana))
	(setq p1 (polar p 0 b))
	(setq p2 (polar p1 (/ (* pi 90) 180) 200))
	(setq p0 (polar p2 pi 150))
	(setq p3 (polar p0 (/ (* pi 90) 180) 200))
	(setq p4 (polar p3 (/ (* (- 180 (/ (* a 180) pi)) pi) 180) (/ (- b 150) (cos a))))
  	(command "pline" p p1 p2 "a" p3 "l" p4 "c")
	(setq sec1 (entlast))
	(command "change" sec1 "" "p" "la" "thay" "")
	(command "hatch" "ANSI32" 600 45 sec1 "")
	(command "change" "l" "" "p" "la" "hatch" "")    
    (setq n1 1 ch1 "canopy")
    (setq bl1 (strcat ch1 (itoa n1)))
    (while (tblsearch "block" bl1)
	(progn
        (setq n1 (1+ n1))
        (setq bl1 (strcat ch1 (itoa n1)))
        )
    )
	(command "-block" bl1 p "c" "non" p1 "non" p4 "")
	(command "-insert" bl1 p "" "" "" )
)
(defun md (/ p h h1 q1 q2 q3 q4 q5 q6 q7 oldos tana a sec1 sec2 c d1 d2)
(setq p (getpoint "\nNhap chon vi tri dat:"))
(setq tana (/ i 100))
(setq a (atan tana))
   	
	(setq h (+ 400 (* tana (- b 150))))
	(setq p1 (polar p 0 l))
	(setq p2 (polar p1 (/ (* pi 90) 180) h))
	(setq p3 (polar p 0 150))
	(setq p4 (polar p3 (/ (* pi 90) 180) h))
	(setq p5 (polar p1 pi 150))
	(setq p6 (polar p5 (/ (* pi 90) 180) h))
	(setq p7 (polar p3 (/ (* pi 90) 180) 200))
	(setq p8 (polar p5 (/ (* pi 90) 180) 200))
	(setq p9 (polar p7 (/ (* pi 45) 180) 200))
	(command "rectangle" p p2)
  	(command "line" p3 p4 "")
	(command "line" p5 p6 "")
	(command "line" p7 p8 "")
	(command "-hatch" "p" "ANSI32" 600 45 p9 "")
	(command "change" "l" "" "p" "la" "hatch" "")
    (setq n2 1 ch2 "canopy")
    (setq bl2 (strcat ch2 (itoa n2)))
    (while (tblsearch "block" bl2)
	(progn
        (setq n2 (1+ n2))
        (setq bl2 (strcat ch2 (itoa n2)))
        )
    )
	(command "-block" bl2 p "c" "non" p2 "non" p "")
	(command "-insert" bl2 p "" "" "" )
)
(defun mb (/ p p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 sec1 n3 ch3 bl3)
(setq p (getpoint "\nNhap chon vi tri dat:"))
	(setq p1 (polar p 0 l))
	(setq p2 (polar p1 (/ (* pi 90) 180) b))
	(setq p3 (polar p 0 150))
	(setq p4 (polar p3 (/ (* pi 90) 180) b))
	(setq p5 (polar p1 pi 150))
	(setq p6 (polar p5 (/ (* pi 90) 180) b))
	(setq p7 (polar p3 (/ (* pi 45) 180) 300))
	(setq p8 (polar p (/ (* pi 90) 180) b))
	(setq p9 (polar p8 (/ (* pi 270) 180) 150))
	(setq p10 (polar p9 (/ (* pi 270) 180) 200))
	(setq p11 (polar p10 (/ (* pi 270) 180) 300))
	(setq p12 (polar p11 (/ (* pi 270) 180) 500))
	(command "rectangle" p p2)
  	(command "line" p3 p4 "")
	(command "line" p5 p6 "")
	(command "-hatch" "p" "ANSI32" 700 45 p7 "")
	(command "change" "l" "" "p" "la" "hatch" "")
	(command "line" p4 p6 "")
	(setq sec1 (entlast))
	(command "move" sec1 "" p8 p9)
	(command "copy" "l" "" p9 p10 "")
	(command "copy" "l" "" p10 p11 "")
	(command "copy" "l" "" p11 p12 "")
    (setq n3 1 ch3 "canopy")
    (setq bl3 (strcat ch3 (itoa n3)))
    (while (tblsearch "block" bl3)
	(progn
        (setq n3 (1+ n3))
        (setq bl3 (strcat ch3 (itoa n3)))
        )
    )
	(command "-block" bl3 p "c" "non" p2 "non" p "")
	(command "-insert" bl3 p "" "" "" )
)
(defun c:can ( / dcl_code dcl_id file_dcl temp)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq old_layer (getvar "clayer"))
(setq lay1 (tblsearch "layer" "roof"))
(if (= lay1 nil) (command "-layer" "n" "roof" "c" "252" "roof" "lw" 0.15 "roof" ""))
(setq lay2 (tblsearch "layer" "hatch"))
(if (= lay2 nil) (command "-layer" "n" "hatch" "c" "8" "hatch" "lw" 0.09 "hatch" ""))
(setq lay3 (tblsearch "layer" "thay"))
(if (= lay3 nil) (command "-layer" "n" "thay" "c" "4" "thay" "lw" 0.15 "thay" ""))
(setq lay4 (tblsearch "layer" "block"))
(if (= lay4 nil) (command "-layer" "n" "block" "c" "21" "block" "lw" 0.09 "block" ""))
(setq lay5 (tblsearch "layer" "gutter"))
(if (= lay5 nil) (command "-layer" "n" "gutter" "c" "6" "gutter" "lw" 0.3 "gutter" ""))
(setvar "clayer" "roof")
 (if (not *canopy*) (setq *canopy* (list "1" "0" "0" "0" "0" "0")))
 (setq dcl_code (list (strcat
"canopy : dialog { label = \"&Lisp ve canopy\";"
" : boxed_radio_row { label = \"Select drawing type\"; key = \"dt\";"
"		 : radio_button { label = \"&Side elevation\"; key = \"se\";}"
"		 : radio_button { label = \"&Front elevation\"; key = \"fe\";}"
"		 : radio_button { label = \"&plan\"; key = \"pl\";}}"
"	: column {"
"	   : edit_box { label = \"Roof slope (%)\"; edit_width = 6; key = \"slope\";}"
"	   : edit_box { label = \"Canopy length\"; edit_width = 6; key = \"length\";}"
"	   : edit_box { label = \"Canopy width\"; edit_width = 6; key = \"width\";}}"
" ok_cancel;}")))
 (setq temp (vl-filename-mktemp "canopy.dcl")	file_dcl (open temp "W"))
 (foreach l dcl_code (write-line l file_dcl))
 (close file_dcl)
 (setq dcl_id (load_dialog temp))
 (vl-file-delete temp)
 (new_dialog "canopy" dcl_id)
 (mapcar 'set_tile (list "se" "fe" "pl" "slope" "length" "width") canopy)
 (cond ((= (car *canopy*) "1") (mapcar 'mode_tile '("slope" "length" "width") '(0 1 0)))
			 ((= (cadr *canopy*) "1") (mapcar 'mode_tile '("slope" "length" "width") '(0 0 0)))
			 ((= (caddr *canopy*) "1") (mapcar 'mode_tile '("slope" "length" "width") '(1 0 0))))
 (action_tile "se" "(mapcar 'mode_tile '(\"slope\" \"length\" \"width\" \"slope\") '(0 1 0 2))")
 (action_tile "fe" "(mapcar 'mode_tile '(\"slope\" \"length\" \"width\" \"slope\") '(0 0 0 2))")
 (action_tile "pl" "(mapcar 'mode_tile '(\"slope\" \"length\" \"width\" \"length\") '(1 0 0 2))")
 (action_tile "accept" "(setq *canopy* (mapcar 'get_tile '(\"se\" \"fe\" \"pl\" \"slope\" \"length\" \"width\"))) (done_dialog)")
 (action_tile "cancel" "(done_dialog) (exit)")
 (start_dialog) (unload_dialog dcl_id)
	(setq i (atof (cadddr *canopy*)))
	(setq l (atof (nth 4 *canopy*)))
	(setq b (atof (last *canopy*)))
 (cond ((= (car *canopy*) "1") (mc))
			 ((= (cadr *canopy*) "1") (md))
			 ((= (caddr *canopy*) "1") (mb)))
(setvar "clayer" old_layer)
(setvar "osmode" oldos)
 (princ))

 


<<

Filename: 422532_can.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 439439
Tên lệnh: td1
Nhờ các bác chỉnh sửa Lisp pick tọa độ ghi lên bãn vẽ trong CAD
18 phút trước, huunhantvxdts đã nói:

Ok đúng rồi lỗi là do...

>>
18 phút trước, huunhantvxdts đã nói:

Ok đúng rồi lỗi là do nó

E thêm cái hàm của Lee, set sẵn qld setting khi chưa có thiết lập.

Còn thiết lập rồi thì k hiểu sao k chạy đc

(vl-load-com)
(defun C:td1 (/ lst bl diem PT1 PT2 PT3 tapx tapy
	x y xx yy h n di kc
	C PT PTX PTY PTD PTC N
	p1 p2 p3 p4 p11 p22 p33 L1 L2 L11 L22)
(setvar "cmdecho" 0 )
(command "Undo" "Begin") 
 (setq om (getvar "osmode"))
 (setq tapx '()
tapy '()
stt '()
k 0
h (getreal "\nnhap chieu cao chu:"))
  (acet-ql-set
   '((3 . "")
     (40 . 0.0)
     (60 . 4) 
     (61 . 0) 
     (62 . 1)
     (63 . 3)
     (64 . 0)
     (65 . 0)
     (66 . 0) 
     (67 . 3) 
     (68 . 0) 
     (69 . 0)
     (70 . 0) 
     (71 . 2)
     (72 . 0)
     (170 . 0)))
(while
 (setq diem (getpoint "\nchon cac vi tri co toa do can ghi:"))
(setq pt1 (getpoint diem "Diem dat Text"))
(setq  PT2 (list (car PT1) (- (cadr PT1)(+ 1 h) ) )
  x (strcat "X = " (rtos(car diem) 2 4))
y (strcat "Y = " (rtos(cadr diem) 2 4))
       k (1+ k)
tapx (append tapx (list x))
tapy (append tapy (list y))
 stt (append stt (list k) )     
  );setq
 
 (if (> (car pt1) (car diem)) (setq bl "BL") (setq bl "BR"))
 (command "text" "j" bl "non" PT1 h 0 x)
 (setq TB (textbox (entget(entlast)))
LC (car TB)
RC (cadr TB)
di (distance LC RC))
   (if (> (car pt1) (car diem)) (setq PT3 (polar PT1 0 (+ di h))) (setq PT3 (polar PT1 pi (+ di h))))
(if (> (car pt1) (car diem)) (command "text"  "non" PT2 h 0 y) (command "text" "j" "R" "non" PT2 h 0 y))
(command  "qleader" "non" diem "non" PT1 "non" PT3 "" )
  (vla-put-scalefactor (vlax-ename->vla-object (entlast) ) (* h 1))
 );dong while
;tao bang thong ke
 (setq 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))
 n (length tapx)
 k 0
);setq
 (command "line" "non" p1 "non" p2 ""
"text" "j" "m" "non" p11 h 0 "STT"
"text" "j" "m" "non" p22 h 0 "Toa Do X"
"text" "j" "m" "non" p33 h 0 "Toa Do Y"
"line" "non" p3 "non" p4 "")
 (while (< k n)
(setq xx (nth k tapx)
  yy (nth k tapy)
 tstt(nth k stt))
(command "text" "j" "m" "non" PTD h 0 tstt
"text" "j" "m" "non" PTX h 0 xx
  "text" "j" "m" "non" PTY h 0 yy
  "line" "non" PT "non" 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 "line" "non" p3 "non" PT ""
"line" "non" p4 "non" PTC ""
  "line" "non" L1 "non" L11 ""
  "line" "non" L2 "non" L22 "")
(setvar "cmdecho" 1)
(prompt"\nxong\n")
 (command "Undo" "End")
 (princ)
);DONG toado

(defun acet-ql-get  (/ xr cod itm reply)
 (if (setq xr (dictsearch (namedobjdict) "AcadDim"))
   (progn
     (foreach cod  '(3 40 60 61 62 63 64 65 66 67 68 69 70 71 72 170 340)
       (if (setq itm (assoc cod xr))
         (setq reply (append reply (list itm)))))
     reply)
   '((3 . "")
     (40 . 0.0)
     (60 . 0)
     (61 . 1)
     (62 . 1)
     (63 . 3)
     (64 . 0)
     (65 . 0)
     (66 . 0)
     (67 . 3)
     (68 . 1)
     (69 . 0)
     (70 . 0)
     (71 . 0)
     (72 . 0)
     (170 . 0))))

(defun acet-ql-set  (arg / cur prm)
 ;;  fetch current
 (setq cur (acet-ql-get))

 ;;  override per argument
 (while arg
   (setq prm (car arg)
         arg (cdr arg)
         cur (subst prm (assoc (car prm) cur) cur))
   ;;  handle DIMLDRBLK
   (if (= 3 (car prm))
     (setvar "DIMLDRBLK" (cdr prm))))

 ;;  put back
 (dictremove (namedobjdict) "AcadDim")
 (setq cur (append '((0 . "XRECORD") (100 . "AcDbXrecord") (90 . 990106))
                   cur))
 (dictadd (namedobjdict) "AcadDim" (entmakex cur))

 (acet-ql-get))

 


<<

Filename: 439439_td1.lsp
Tác giả: duy782006
Bài viết gốc: 438960
Tên lệnh: layso
Lisp Lọc Text Dạng Số Ra Khỏi Chuỗi Text
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Defun duy:xd_listngngancach<kytub (chuoi kytu / chuoi kytu ckq) 
(setq lkq nil)
(setq bdd 1) 
(setq b 1)
(setq l (fix (strlen chuoi)))
(repeat l
(setq a (substr chuoi b 1))
(cond
((= a kytu) 
(setq dkt (substr chuoi bdd (- b bdd)))
(cond
((/= dkt "")
(setq lkq (append lkq (list dkt)))
))
(setq bdd (+ b 1)) 
)
)
(setq b (+ b...
>>
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Defun duy:xd_listngngancach<kytub (chuoi kytu / chuoi kytu ckq) 
(setq lkq nil)
(setq bdd 1) 
(setq b 1)
(setq l (fix (strlen chuoi)))
(repeat l
(setq a (substr chuoi b 1))
(cond
((= a kytu) 
(setq dkt (substr chuoi bdd (- b bdd)))
(cond
((/= dkt "")
(setq lkq (append lkq (list dkt)))
))
(setq bdd (+ b 1)) 
)
)
(setq b (+ b 1))
)
(setq dkt (substr chuoi bdd (+ (- l bdd) 1)))
(setq lkq (append lkq (list dkt)))
lkq)
;;;;;;;;;;;;;;;;
(defun c:layso ()
(command "undo" "be")
(setq sb (ssget (list (cons 0 "TEXT"))))
(setq SUMb 0)
(setq im 0)
(setq N (sslength sb))
(while (< im N)
(setq nddd (cdr (assoc 1 (entget (ssname sb im))))) 
(setq kqthay (duy:xd_listngngancach<kytub nddd " "))
(setq ndddau (nth 0 kqthay))
(setq ktdt (substr ndddau 1 1))
(cond
((= ktdt "T")
(setq kqthaym (nth 2 kqthay))
(cond
((/= ktdt nil)
(setq DTMs (subst (cons 1 kqthaym) (assoc 1 (entget (ssname sb im))) (entget (ssname sb im))))
(entmod DTMs)
))

))
(setq im (1+ im))
)
(command "undo" "end")
(princ)
)

Thử phát xem sao. Lệnh LAYSO.


<<

Filename: 438960_layso.lsp
Tác giả: NGUYENVANHIEUGTVT
Bài viết gốc: 439556
Tên lệnh: cd cdm ucd ucdm
Nhờ Mn kiểm tra dùm e Lỗi pick Cao độ.

4 phút trước, Doan Nguyen Van đã nói:

 

Lisp...

>>
4 phút trước, Doan Nguyen Van đã nói:

 

Lisp bạn mua hay sao mà không post được lên vậy? cái con số đó mình cũng đã biết, nhưng nếu không có file lisp thì cũng đành bó tay

;-----------------------------------------------------------------
(prompt "\n		CD  : Insert a elevation block (scale 1:10)")
(defun c:CD ( / DZ pt y ptside ang OT CurrLayer)
;  (if (= scale nil)  (setq scale (getreal "\nInput current scale : ")))
  (if (= scale nil) (c:TL))
  (setq DZ (getvar "DIMZIN")
	OT (getvar "ORTHOMODE")
	CurrLayer (getvar "clayer")
  )
  (setvar "DIMZIN" 0)
  (setvar "ORTHOMODE" 0)
  (setq pt (getpoint "\nSpecify inserted point : ")
	ptside (getpoint "\nSpecify side point : " pt)
	ang (angle pt ptside)
	y (/ (cadr pt) (/ 1000 TyleVe))
  )
  (cond
    ((> y 0) (setq y (strcat "+" (rtos y 2 #Bacc))))
    ((< y 0) (setq y (rtos y 2 #Bacc)))
    ((= y 0) (setq y "%%p0.00"))
  )
  (setq y (ustr 0 "Input elevation : " y T))
  (if (null (tblsearch "layer" "2")) (command "LAYER" "N" "2" "C" "2" "2" ""))
  (setvar "clayer" "2")
  (if (AND (>= ang 0) (< ang 1.5708)) (command "-INSERT" "CD" pt scale scale "0" y))
  (if (AND (>= ang 1.5708) (< ang 3.1416)) (command "-INSERT" "CD3" pt scale scale "0" y))
  (if (AND (>= ang 3.1416) (< ang 4.7124)) (command "-INSERT" "CD2" pt scale scale "0" y))
  (if (AND (>= ang 4.7124) (< ang 6.2832)) (command "-INSERT" "CD1" pt scale scale "0" y))
  (setvar "clayer" CurrLayer)
  (setvar "DIMZIN" DZ)
  (setvar "ORTHOMODE" OT)
  (princ)
);defun c:CD


;-----------------------------------------------------------------
;(prompt "\n		CDM : Insert a elevation block (scale 1:1000)")
(defun c:CDM ( / DZ pt y ptside ang OT CurrLayer)
  (if (= scale nil)  (c:TL))
  (setq DZ (getvar "DIMZIN")
	OT (getvar "ORTHOMODE")
	CurrLayer (getvar "clayer")
  )
  (setvar "DIMZIN" 0)
  (setvar "ORTHOMODE" 0)
  (setq pt (getpoint "\nSpecify inserted point : ")
	ptside (getpoint "\nSpecify side point : " pt)
	ang (angle pt ptside)
	y (/ (cadr pt) 1.0)
  )
  (cond
    ((> y 0) (setq y (strcat "+" (rtos y 2 #Bacc))))
    ((< y 0) (setq y (rtos y 2 #Bacc)))
    ((= y 0) (setq y "%%p0.00"))
  )
  (setq y (ustr 0 "Input elevation : " y T))
  (if (null (tblsearch "layer" "2")) (command "LAYER" "N" "2" "C" "2" "2" ""))
  (setvar "clayer" "2")
  (if (AND (>= ang 0) (< ang 1.5708)) (command "INSERT" "CD" pt scale scale "0" y))
  (if (AND (>= ang 1.5708) (< ang 3.1416)) (command "INSERT" "CD3" pt scale scale "0" y))
  (if (AND (>= ang 3.1416) (< ang 4.7124)) (command "INSERT" "CD2" pt scale scale "0" y))
  (if (AND (>= ang 4.7124) (< ang 6.2832)) (command "INSERT" "CD1" pt scale scale "0" y))
  (setvar "clayer" CurrLayer)
  (setvar "DIMZIN" DZ)
  (setvar "ORTHOMODE" OT)
  (princ)
);defun c:CDM



;---------------------------------------------------------------------------
(prompt "\n		UCD : Update elevation block to current elevation (scale 1:10)")
(defun c:UCD( / ssl temp ed old new  insert_pt y rndy)
  (if (eq (getvar "UCSNAME") "") 
    (prompt (strcat "\nYOUR CURRENT 'UCS' IS : ""WORLD""\n"))
    (prompt (strcat "\nYOUR CURRENT 'UCS' IS : " (getvar "UCSNAME") "\n"))
  )
  (block_u_ssget)
;     (if (= scale nil) (setq scale (getreal "\nInput current scale: ")))
  (setq DZ (getvar "DIMZIN"))
  (setvar "DIMZIN" 0)
  (setq ssl (sslength sset))
  (while (> ssl 0)
    (setq temp (ssname sset (setq ssl (1- ssl)))
	  ed (entget temp)
	  insert_pt (dxf 10 ed)
	  bname (dxf 2 ed)
    )
    (if (OR (= bname "CD") (= bname "CD1") (= bname "CD2") (= bname "CD3"))
      (progn
	(setq temp (entnext temp)
	      ed (entget temp)
	      y (/ (cadr (trans insert_pt 0 1)) (/ 1000 TyleVe))
	      rndy (expt 10.0 (- #Bacc))
	      y (* rndy (atof (rtos (/ y rndy) 2 0)))
	)
	(cond
	  ((> y 0) (setq y (strcat "+" (rtos y 2 #Bacc))))
	  ((< y 0) (setq y (rtos y 2 #Bacc)))
	  ((= y 0) (setq y (strcat "%%p" (rtos y 2 #Bacc))))
        )
	(setq old (assoc 1 ed)
	      new (cons 1 y)
	      ed (subst new old ed)
	); setq
	(entmod ed)  
	(entupd temp)
      );progn
    );if
  );while
  (setvar "DIMZIN" DZ)
  (princ)
);defun c:UCD



;---------------------------------------------------------------------------
;(prompt "\n		UCDM: Update elevation block to current elevation (scale 1:1000)")
(defun c:UCDM( / ssl temp ed old new  insert_pt y )
     (if (eq (getvar "UCSNAME") "") 
    (prompt (strcat "\nYOUR CURRENT 'UCS' IS : ""WORLD""\n"))
    (prompt (strcat "\nYOUR CURRENT 'UCS' IS : " (getvar "UCSNAME") "\n"))
  )
  (block_u_ssget)
;     (if (= scale nil) (setq scale (getreal "\nInput current scale: ")))
  (setq DZ (getvar "DIMZIN"))
  (setvar "DIMZIN" 0)
  (setq ssl (sslength sset))
  (while (> ssl 0)
    (setq temp (ssname sset (setq ssl (1- ssl)))
	  ed (entget temp)
	  insert_pt (dxf 10 ed)
	  bname (dxf 2 ed)
    )
    (if (OR (= bname "CD") (= bname "CD1") (= bname "CD2") (= bname "CD3"))
      (progn
	(setq temp (entnext temp)
	      ed (entget temp)
	      y (/ (cadr (trans insert_pt 0 1)) 1.0)
	)
	(cond
	  ((> y 0) (setq y (strcat "+" (rtos y 2 #Bacc))))
	  ((< y 0) (setq y (rtos y 2 #Bacc)))
	  ((= y 0) (setq y "%%p0.00"))
        )
	(setq old (cons 1 (DXF 1 ed))
	      new (cons 1 y)
	      ed (subst new old ed)
	); setq
	(entmod ed)  
	(entupd temp)
      );progn
    );if
  );while
  (setvar "DIMZIN" DZ)
  (princ)
);defun c:UCDM

 


<<

Filename: 439556_cd_cdm_ucd_ucdm.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 439636
Tên lệnh: gc
NHỜ SỬA LISP LÀM COPY NỘI DUNG DIM VÀ LÀM TRÒN DIM GHI RA TEXT
14 giờ trước, BinhQN đã nói:

Chào anh em,

Hiện tại...

>>
14 giờ trước, BinhQN đã nói:

Chào anh em,

Hiện tại lisp đang hoạt động copy nội dung dim và ghi ra text. Mình muốn nhờ anh em sửa giúp mình thêm chức năng làm tròn dim. Hoặc lấy giá trị text dim

Mong cao thủ giúp đỡ . Cảm ơn!

4652_dim.dwg

ghichu.lsp

(defun c:gc (/ P1 sel1 sel2 ro1 ro2 dis1 dis2 str)
(setq sel1 (car (entsel "\n Select Dim1:")))
  (setq ro1 (vla-get-rounddistance (vlax-ename->vla-object sel1))
	dis1 (vla-get-measurement (vlax-ename->vla-object sel1)))
(setq sel2 (car (entsel "\n Select Dim2:")))
  (setq ro2 (vla-get-rounddistance (vlax-ename->vla-object sel2))
	dis2 (vla-get-measurement (vlax-ename->vla-object sel2)))
  (if (/= ro1 0) (setq dis1 (* (abs ro1) (fix (/ ((if (minusp dis1) - +) dis1 (* (abs ro1) 0.5)) (abs ro1))))))
  (if (/= ro2 0) (setq dis2 (* (abs ro2) (fix (/ ((if (minusp dis2) - +) dis2 (* (abs ro2) 0.5)) (abs ro2))))))
(setq str (strcat "(" (rtos dis1 2 0) "x" (rtos dis2 2 0) ")"))
   (setq P1 (getpoint "\nSpecify text point: "))
   (command "_.text" P1 "400" "0" str )
 (princ)
)

Gửi bạn test


<<

Filename: 439636_gc.lsp
Tác giả: duongts
Bài viết gốc: 213162
Tên lệnh: ha
Nhờ viết lisp ghi đường dẫn file nguồn

Lisp thì đây bạn!


(defun C:HA( / lst)
(command "date")
(setq lst (jtoc (getvar "date")))
(setq a (strcat (getvar...
>>

Lisp thì đây bạn!


(defun C:HA( / lst)
(command "date")
(setq lst (jtoc (getvar "date")))
(setq a (strcat (getvar "dwgname") "-/" (itoa (nth 2 lst)) "-" (itoa (nth 1 lst)) "-" (itoa (nth 0 lst)) "/" (itoa (nth 3 lst)) ":" (itoa (nth 4 lst)))))

Lisp sao dùng không được bạn ơi, bạn kiểm tra lại xem thế nào với nhé. cảm ơn


<<

Filename: 213162_ha.lsp
Tác giả: duy782006
Bài viết gốc: 429088
Tên lệnh: ttl
Lisp vẽ thước tỷ lệ cho trắc dọc

Thay đổi tí không hỏi tỉ lệ vẻ mà hỏi một mét bằng bao nhiêu, trường hợp 1/500 thì một mét bằng 1000/500 nghĩa là bằng 2. Bạn xem đúng rồi thì mình sẽ chỉnh thành hỏi tỷ lệ vẽ như ý bạn. Có cái gì chưa đúng thì nói rỏ ra, tập diển tả chứ không phải lúc nào cũng load cái bản vẽ về ngồi ngó và đoán mệt lắm.

 

>>

Thay đổi tí không hỏi tỉ lệ vẻ mà hỏi một mét bằng bao nhiêu, trường hợp 1/500 thì một mét bằng 1000/500 nghĩa là bằng 2. Bạn xem đúng rồi thì mình sẽ chỉnh thành hỏi tỷ lệ vẽ như ý bạn. Có cái gì chưa đúng thì nói rỏ ra, tập diển tả chứ không phải lúc nào cũng load cái bản vẽ về ngồi ngó và đoán mệt lắm.

 

(defun c:ttl ()
(or ssmin (setq ssmin 0))
(setq ssmin (cond ((getint (strcat "\nMuc so sanh min < " (rtos ssmin 2 0) " >:")))(ssmin)))

(or ssmax (setq ssmax 10))
(setq ssmax (cond ((getint (strcat "\nMuc so sanh max < " (rtos ssmax 2 0) " >:")))(ssmax)))

(or tlve (setq tlve 1))
(setq tlve (cond ((getreal (strcat "\nMot met bang bao nhieu < " (rtos tlve 2 1) " >:")))(tlve)))

(setq diemved (getpoint "\nChon diem ve thuoc :"))
(setq diemve (polar diemved (* pi 1.5) (* 0.1 tlve)))
(setq diemdau diemve)
(setq slc ssmin)

(repeat (fix (- ssmax ssmin))
(setq diemve (polar diemve (/ pi 2) (* 0.1 tlve)))
(entmake (list (cons 0 "LINE")(cons 10 diemve)(cons 11 (polar diemve pi (* 0.1 tlve)))(cons 8 "Clayer")(cons 62 256)(cons 6 "bylayer")(cons 48 1) )) 
(entmake (list (cons 0 "TEXT")(cons 10 (polar diemve pi (* 0.25 tlve)))(cons 11 (polar diemve pi (* 0.5 tlve)))(cons 40 (/ tlve 5))(cons 50 0)(cons 72 1)(cons 1 (rtos slc 2 0))(cons 7 (getvar "TEXTSTYLE"))(cons 8 "Clayer")(cons 62 256))) 


(repeat 9
(setq diemve (polar diemve (/ pi 2) (* 0.1 tlve)))
(entmake (list (cons 0 "LINE")(cons 10 diemve)(cons 11 (polar diemve pi (* 0.05 tlve)))(cons 8 "Clayer")(cons 62 256)(cons 6 "bylayer")(cons 48 1) )) 
)

(setq slc (+ slc 1))
)

(setq diemve (polar diemve (/ pi 2) (* 0.1 tlve)))
(entmake (list (cons 0 "LINE")(cons 10 diemve)(cons 11 (polar diemve pi (* 0.1 tlve)))(cons 8 "Clayer")(cons 62 256)(cons 6 "bylayer")(cons 48 1) )) 
(entmake (list (cons 0 "TEXT")(cons 10 (polar diemve pi (* 0.25 tlve)))(cons 11 (polar diemve pi (* 0.5 tlve)))(cons 40 (/ tlve 5))(cons 50 0)(cons 72 1)(cons 1 (rtos slc 2 0))(cons 7 (getvar "TEXTSTYLE"))(cons 8 "Clayer")(cons 62 256))) 
(entmake (list (cons 0 "LINE")(cons 10 diemdau)(cons 11 diemve)(cons 8 "Clayer")(cons 62 256)(cons 6 "bylayer")(cons 48 1) )) 
(Princ))

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

 


<<

Filename: 429088_ttl.lsp
Tác giả: langqueyeudau_ns
Bài viết gốc: 114577
Tên lệnh: r
Nhờ giúp Lisp tính diện tích và lập bảng
Của bạn đây. lisp sẽ tính diện tích thực theo tỷ lệ bản vẽ bạn nhập vào. đầu tiên bạn phải chọn vị trí đặt bảng thống kê diện...
>>
Của bạn đây. lisp sẽ tính diện tích thực theo tỷ lệ bản vẽ bạn nhập vào. đầu tiên bạn phải chọn vị trí đặt bảng thống kê diện tích trên bản vẽ rồi mới pick chọn các miền cần đo diện tích. pick tới đâu diện tích sẽ được thống kê vào bảng đến đó. Mình viết thêm cho bạn một ô tính tổng diện tích các miền đã đo (yêu cầu của bạn không thấy nêu vấn đề này), tuy nhiên bạn phải Enter để kết thúc lệnh (không nhấn Esc nhé) thì lisp mới vẽ được ô cuối cùng này.

(defun c:r()
 (setvar "cmdecho" 0)
 (setq lacol (getvar "CEColor"))
 (setq ladin (getvar "dimzin"))
 (setq laos (getvar "osmode"))  
 (if (not tl) (setq tl 1))
 (if (not h) (setq h 1))
 (setq tl1 (getreal (strcat "\nty le ban ve < 1/" (rtos tl 2 0) " >: 1/"))
caot1 (getreal (strcat "\nCao text < " (rtos h 2 0) " >: ")))
 (if tl1 (setq tl tl1))
 (if caot1 (setq h caot1))

 (setq	 k 0 
tdt 0)
 (setq ss (ssadd))

(setvar "dimzin" 0)
(setvar "OSMODE" 0)
(setq PT (getpoint "\nChon diem xuat bang thong ke dien tich (mep trai):"))
(setq 	P1 (list (+ (car PT)(* 6 h)) (cadr PT))
P2 (list (+ (car PT)(* 22 h)) (cadr PT))
P3 (list (car PT) (- (cadr PT)(* 3 h)))
P4 (list (car P1) (cadr P3))
P5 (list (car P2) (cadr P3))
P6 (list (+ (car PT)(* 11 h)) (+ (cadr PT)(* 2 h)))
P7 (list (+ (car PT)(* 3 h)) (- (cadr PT)(* 1.5 h)))
P8 (list (+ (car PT)(* 14 h)) (- (cadr PT)(* 1.5 h)))
);setq
(command 	"pline" PT P2 P5 P3 "C"
	"pline" P1 P4 ""
	"text" "m" P6 (* 1.2 h) 0 "%%UB¶ng thèng kª diÖn tÝch"
	"text" "m" P7 h 0 "STT"
	"text" "m" P8 h 0 "DiÖn tÝch (m2)"
);command

(setq pt1 (getpoint "\n Chon mien tinh dien tich : "))
 (while (/= pt1 nil)
(setq k (+ 1 k))
(command "TEXT" "m" pt1 (* 3 h) 0 (rtos k 2 0))
(setq 	PT (list (car P3) (cadr P3))
P1 (list (+ (car PT)(* 6 h)) (cadr PT))
P2 (list (+ (car PT)(* 22 h)) (cadr PT))
P3 (list (car PT) (- (cadr PT)(* 3 h)))
P4 (list (car P1) (cadr P3))
P5 (list (car P2) (cadr P3))
P7 (list (+ (car PT)(* 3 h)) (- (cadr PT)(* 1.5 h)))
P8 (list (+ (car PT)(* 14 h)) (- (cadr PT)(* 1.5 h)))
P9 (list (car PT) (- (cadr P3)(* 3 h)))
P10 (list (car P1) (cadr P9))
P11 (list (car P2) (cadr P9))
P12 (list (car P7) (- (cadr P3)(* 1.5 h)))
P13 (list (car P8) (cadr P12))
);setq
(command "CECOLOR" 4 "-boundary" pt1 "" )
(setvar "CECOLOR" lacol)
(setq et (entlast))
(ssadd et ss)
(command "area" "e" "last")				
(setq et (entlast))
(ssadd et ss)
(setq dtcon (* (getvar "AREA") tl tl))
(setq tdt (+ dtcon tdt))
(command "erase" ss "")

(command "pline" PT P2 P5 P3 "C"
	"pline" P1 P4 ""
	"text" "m" P7 h 0 (rtos k 2 0)
	"text" "m" P8 h 0 (rtos dtcon 2 2))

(setq pt1 (getpoint "\n chon mien tinh dien tich tiep theo hoac enter de ket thuc lenh..."))
);while
(setq ss nil)
(setvar "DIMZIN" ladin)
(command 	"pline" P3 P9 P11 P5 "C"
	"pline" P10 P4 ""
	"text" "m" P12 h 0 "Tæng"
	"text" "m" P13 h 0 (rtos tdt 2 2)
);command
(setvar "OSMODE" laos)
(setvar "cmdecho" 1)
)

bạn quá giỏi,cảm ơn bạn nhiều nhé.ji


<<

Filename: 114577_r.lsp
Tác giả: Anlee
Bài viết gốc: 248387
Tên lệnh: test
VBA cho AutoCad-Hãy cùng tham gia trao đổi

 

Cảm ơn bạn đã quan tâm đến vấn đề của mình : mình ví dụ luôn như sau :

Sub...
>>

 

Cảm ơn bạn đã quan tâm đến vấn đề của mình : mình ví dụ luôn như sau :

Sub Example_PickfirstSelectionSet()
    ' This example lists all the objects in the pickfirst selection set.
    ' Before running this example, create some objects in the active
    ' drawing and select those objects. The objects currently selected
    ' in the active drawing will be returned in the pickfirst selection set.
            
    Dim pfSS As AcadSelectionSet
    Dim ssobject As AcadEntity
    Dim msg As String
    msg = vbCrLf
    
    Set pfSS = ThisDrawing.PickfirstSelectionSet
    For Each ssobject In pfSS
        msg = msg & vbCrLf & ssobject.ObjectName
    Next ssobject
    MsgBox "The Pickfirst selection set contains: " & msg
    
End Sub

*  Ý mình là hàm Ssget trong lisp --> cho phép chọn trước 1 đối tượng , còn trong vbarun có lẽ không làm được điều này !

 

==> Bạn thử làm theo các bước sau :

* Chọn trước mấy đối tượng trong bản vẽ :

* Trong trình soạn thảo vba : ấn F5 run code trên :====> code sẽ liệt kê hết tên các đối tượng được chọn trước trên bản vẽ

* Nhưng nếu trên autocad : bạn gõ lệnh : vbarun --> run code ở trên ==> code trên hoàn toàn không hoạt động

** Mình cũng không hiểu tại sao ???

==> Không có lẽ trong VBA ta không có cách nào lựa chọn các đối tượng trước khi thực hiện lệnh ???

ví dụ : như lệnh copy trong autocad : ta có thể chọn trước đối tượng rồi gõ lệnh copy

* Nhưng trong vba : kiểu gì ta cũng phải chọn lại đối tượng sau khi gõ lệnh ???? 

mình thử viết 1 đoạn code để thay đổi màu các đối tương như sau :

Sub ssget()
    Dim ssetObj As AcadSelectionSet
    Dim entity As AcadEntity
    On Error Resume Next
        Set ssetObj = ThisDrawing.PickfirstSelectionSet
        If ssetObj.Count Then
            For Each entity In ssetObj
                entity.color = 8
            Next
        Else
            Set ssetObj = ThisDrawing.SelectionSets.Add("#")
            If Err <> 0 Then
               Set ssetObj = ThisDrawing.SelectionSets("#"): ssetObj.Clear
            End If
            ssetObj.SelectOnScreen
            For Each entity In ssetObj
                entity.color = 8
            Next
        End If
End Sub

==> Nó hoàn toàn không " mạnh " bằng hàm ssget trong lisp  như sau :

(defun c:test ()
(setq ss (ssget))
(command "chprop" ss "" "c" "8" "")
)

Đoạn code bt ko có vấn đề gi cả nhưng cách thao tác của bạn chưa đúng vì:

-khi bạn chọn đối tượng xong, xong rồi bạn go lệnh vbarun thì nó thoat đối tượng ra rồi

-ban thử chọn đối tượng xong vào alt + F11 rồi ấn nút hình tam giác ý code chạy bình thường

Còn để so sánh vba với Lisp thì nó là cả 1 vấn đề nan giải. ai quen cái gì thì dùng cái đấy thôi.

Riêng mình thì mình thích vba hơn vì nó ứng dụng cả trong excel nữa.


<<

Filename: 248387_test.lsp
Tác giả: NGUYENVANHIEUGTVT
Bài viết gốc: 439761
Tên lệnh: sd sb st
Nhờ Mn kiểm tra cho lisp chọn nhanh đối tượng.

Mình có lisp chọn nhanh đối tượng này lúc load lên thì đôi lúc thì sự dụng được nhưng đôi lúc báo lỗi như hình. mà tìm trên diễn đàn thì có lisp tương tự của Bác KETXU thì load xong dùng đc nhưng 1 số lisp khác lại báo lỗi.
Mọi người ktra và có thể gỡ rối dùm mình đc k ạ. Cảm ơn MN quan tâm..
 

>>

Mình có lisp chọn nhanh đối tượng này lúc load lên thì đôi lúc thì sự dụng được nhưng đôi lúc báo lỗi như hình. mà tìm trên diễn đàn thì có lisp tương tự của Bác KETXU thì load xong dùng đc nhưng 1 số lisp khác lại báo lỗi.
Mọi người ktra và có thể gỡ rối dùm mình đc k ạ. Cảm ơn MN quan tâm..
 

image.png.6e8771d4454c6f0630c868ea7bcd9706.png

Lisp mình gắn ở đây luôn ạ.
 

(prompt "\n		SD  : select dimension(s)")
(defun c:SD (/ sset ssl)
  (setq sset (ssget (list '(-4 . "<OR") '(0 . "DIMENSION") '(0 . "LEADER") '(-4 . "OR>") ))
	ssl (sslength sset)
  )
  (princ (strcat (itoa ssl) " dimension(s) found !"))
  (command "_.PSELECT" "p" "")
  (princ)
);defun c:SD


;===================================================================
(prompt "\n		SB  : select block(s)")
(defun c:SB (/ sset ssl)
  (setq sset (ssget (list '(0 . "INSERT") ))
	ssl (sslength sset)
  )
  (princ (strcat (itoa ssl) " block(s) found !"))
  (command "_.PSELECT" "p" "")
  (princ)
);defun c:SB


;===================================================================
(prompt "\n		ST  : select text(s)")
(defun c:ST (/ sset ssl)
  (setq sset (ssget (list '(0 . "TEXT") ))
	ssl (sslength sset)
  )
  (princ (strcat (itoa ssl) " text(s) found !"))
  (command "_.PSELECT" "p" "")
  (princ)
);defun c:ST

 


<<

Filename: 439761_sd_sb_st.lsp
Tác giả: Hai_YenLang
Bài viết gốc: 198469
Tên lệnh: xscale xsc
Làm sao để viết chữ trên cung Elips ?

Lisp cũ thì thiếu hàm nên đừng dùng.

Lisp mới có lỗi khi down về nên tôi đã sửa lại ở dưới. Tôi đã test bản vẽ của...

>>

Lisp cũ thì thiếu hàm nên đừng dùng.

Lisp mới có lỗi khi down về nên tôi đã sửa lại ở dưới. Tôi đã test bản vẽ của bạn OK.

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=9753&st=0
;XSCALE Scale the mot chieu lenhtat :XSC
(DEFUN EXCUTE()
 (setq oldvalue (getvar "CMDECHO"))
 (setvar "CMDECHO" 0)
 (princ "Chon doi tuong can scale: ")
 (setq ss (ssget))
 (setq P0 (getpoint "\n Base point: "))
 (initget 1 "X Y X S")
 (setq C (getkword "\nScale theo  :"))
(setq hstr (getstring "\n Cho biet he so scale or Reference < R >"))
(if (/= hstr "R") (setq hs (distof hstr 2)))
(if (or (= hstr "R") (= hstr ""))
(progn
(setq po1 (getdist p0 "\n Nhap chieu dai cua doan 1 hay Pick diem thu 2 cua canh thu 1:"))
(setq po2 (getdist p0 "\n Nhap chieu dai cua doan 2 hay Pick diem thu 2 cua canh thu 2:"))
(setq hs (/ po2 po1))))
 (DELBLOCK "VKC_TEMP")
 (CREATEBLOCK ss P0)
 (Command "-Insert" "VKC_TEMP" C hs P0 "")  
 (setq dt (entlast))
 (Command "Explode" dt)
 (setvar "CMDECHO" oldvalue)
 (princ))
(DEFUN CREATEBLOCK(ss P)
 (command "-Block" "VKC_TEMP" P ss ""))
(DEFUN DELBLOCK (bname)
 (if (IsExistBlock bname)
(Command "-Purge" "B" bname "Y" "Y")))
(DEFUN IsExistBlock(bname / kq)
 (setq kq Nil)
 (setq n (length LiBlk))
 (setq i 0)
 (while (< i n)
(if (= bname (nth i LiBlk))
 	(progn
(setq i n)
(setq kq T)))
(setq i (1+ i)))
 kq)
(DEFUN CREALIBLK (/ NL)
 (setq LiBlk (List))
 (setq NL (tblnext "BLOCK" T))
 (while NL  
(setq LiBlk (append LiBlk (list (cdr (assoc 2 NL)))))
(setq NL (tblnext "BLOCK")))
 (setq LiBlk (Acad_strlsort LiBlk)))
(DEFUN C:XSCALE()
 (CREALIBLK)
 (EXCUTE))
(DEFUN C:XSC()
 (CREALIBLK)
 (EXCUTE))

Quá tuyệt vời bác ơi! Em dùng được rồi bác ạ:

Command: xsc

Chon doi tuong can scale:

Select objects: 1 found

Select objects:

Base point:

Scale theo :x

Cho biet he so scale or Reference < R >

Nhap chieu dai cua doan 1 hay Pick diem thu 2 cua canh thu 1:

Nhap chieu dai cua doan 2 hay Pick diem thu 2 cua canh thu 2:

 

1- Em chỉ có thắc mắc vì sao "Lisp cũ thì thiếu hàm nên đừng dùng." ?, Em đã từng dùng và dùng tốt cơ mà, sao bây giờ lại ko được(!)

2- Vì sao "Lisp mới có lỗi khi down về" Em vẫn Download bình thường như mọi khi chứ có khác gì đâu? Em hoang mang quá, chẳng hiểu vì sao cả?


<<

Filename: 198469_xscale_xsc.lsp
Tác giả: tuan_thietkedien
Bài viết gốc: 34417
Tên lệnh: textfitm
Xin các pác viết dùm lisp ở lệnh text fit
Lệnh là TEXTFITM.

-Vì áp dụng cho nhiều text nên tiện ích không tự nhận điểm đầu tiên mà bạn phải chọn cả điểm bắt đầu và kết thúc (nhập giá trị độ dài...

>>
Lệnh là TEXTFITM.

-Vì áp dụng cho nhiều text nên tiện ích không tự nhận điểm đầu tiên mà bạn phải chọn cả điểm bắt đầu và kết thúc (nhập giá trị độ dài bằng số cũng được).

-Tiện ích chỉ thay đổi độ rộng các dòng text bằng với khoảng độ dài mới (chọn 2 điểm hoặc nhập giá trị số) còn lại điểm canh lề thứ nhất và góc quay vẫn giữ nguyên.

 

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

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

(Defun c:textfitm ( )
(princ "\nPHAM QUOC DUY Binh Son - Quang ngai")
(Princ "\nHay chon doi tuong :")
(setq SS (ssget '((0 . "TEXT"))))

  (SETQ NDT (GETDIST "\nNhap do rong : "))

(setq i 0)
(setq N (sslength ss))
(while (< i N)
  (setq TEXTENT (ssname SS i))

 (setq luubatdiem (getvar "osmode"))
 (setvar "osmode" 0)

(command "ucs" "object" textent)
(setq tbTB (textbox (list (cons -1 textent)))
        ll (car tbTB)
       ur (cadr tbTB)
       ul (list (car ll) (cadr ur))
       lr (list (car ur) (cadr ll))
)

 (setq  daitext (distance ul lr))

          (setq e (entget TEXTENT))

          (setq tilehientai (cdr (assoc 41 e)))
          (setq daitextthuc (/ daitext tilehientai))
          (setq tilexmoi (/ NDT daitextthuc))

          (setq e (subst (cons 41 tilexmoi) (assoc 41 e) e))
          (entmod e)

 (command "ucs" "p")

  (setq i (1+ i))

 (setvar "osmode" luubatdiem)  

)
     (Princ)
) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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


<<

Filename: 34417_textfitm.lsp
Tác giả: damvinhduy
Bài viết gốc: 93978
Tên lệnh: dstt
Viết lisp theo yêu cầu [phần 2]
Bạn thử code Lisp này nhé :

(defun c:dstt(/ ss delta ob chuoi chdau chcuoi)
(vl-load-com)
;; copyright by Tue_NV
(setq ss (ssget "X" (list(cons 0 "*TEXT") (cons 1 "T10A030*"))) i...
>>
Bạn thử code Lisp này nhé :

(defun c:dstt(/ ss delta ob chuoi chdau chcuoi)
(vl-load-com)
;; copyright by Tue_NV
(setq ss (ssget "X" (list(cons 0 "*TEXT") (cons 1 "T10A030*"))) i -1)
(setq delta (getint "\n so tang giam :"))
(while (setq ent (ssname ss (setq i (1+ i))))
(setq ob (vlax-ename->vla-object ent))
(setq chuoi (vlax-get ob 'textstring))
(setq chdau "T10A030")
(setq chcuoi (atoi (substr chuoi (1+ (strlen chdau)) (strlen chuoi))))
  (if (and (>= (+ chcuoi delta) 0) (<= (+ chcuoi delta) 9))
(vlax-put ob 'textstring (strcat chdau "0" (itoa (+ chcuoi delta))))
  )
  (if (> (+ chcuoi delta) 9)
(vlax-put ob 'textstring (strcat chdau (itoa (+ chcuoi delta))))
  )
)
(princ)
)

load vào báo sucessful nhưng khi nhập lệnh dstt thi báo Unknown command "DSTT". Press F1 for help. Trong lệnh trên nếu thay T10A030 bằng một text khác bất kỳ có thể thay đổi kiểu TABCDEF, trong đó EF là kiểu ký tự số, TABCD có thể là chữ hoặc số thì phải làm sao. Mình chỉ cần 2 con số cuối của text thay đổi thôi còn các ký tự trước đó không quan tâm là gì. Cảm ơn Tue_NV


<<

Filename: 93978_dstt.lsp
Tác giả: thanhduan2407
Bài viết gốc: 191549
Tên lệnh: rft
lisp Phun tọa độ các điểm từ file txt vào CAD

Có bác nào giúp em chỉnh sửa lisp của bác Gia_Bach >>

Có bác nào giúp em chỉnh sửa lisp của bác Gia_Bach http://www.cadviet.c.../80142_rft2.lsp

;; free lisp from cadviet.com
(defun c:RFT(/ data f h line pt pXY spc str ten val);Read File Txt
 ;|  By : Gia Bach, gia_bach @  www.CadViet.com 			|;  
 (vl-load-com)
 (defun Split (Str Char / Lst pos)
(while (setq pos (vl-string-search Char Str))
 	(if (null Lst)
(setq Lst (list (substr Str 1 pos)))
(setq Lst (append Lst (list (read (substr Str 1 pos))))))
 	(setq Str (substr Str (+ pos 2)) ))
(setq Lst (append Lst (list (read Str)))))

 (if (setq ten (getfiled "Chon File txt" (getvar "dwgprefix") "txt" 8))
(progn
 	(or (tblsearch "layer" "Point") (command "-layer" "n" "Point" "") )
 	(or (tblsearch "layer" "Sothutu") (command "-layer" "n" "Sothutu" "c" 3 "Sothutu" "") )
 	(or (tblsearch "layer" "Caodo") (command "-layer" "n" "Caodo" "c" 4 "Caodo" "") )
 	(setq spc (vla-get-ModelSpace (vla-get-ActiveDocument(vlax-get-Acad-Object))))
 	(setq h 2);(* (getvar "dimtxt")(getvar "dimscale")))
 	(setq f (open (findfile ten) "r"))
 	(while (setq Line (read-line f))
(if (vl-string-search "\t" Line)
  (progn
(setq data (split Line "\t" )
val (car data)
pt  (cdr data))
(if (not(vl-catch-all-error-p (vl-catch-all-apply 'vlax-3d-point pt)))
  	(progn
 (setq pXY (list (car pt)(cadr pt)))
 (vla-put-Layer (vla-addpoint spc (vlax-3d-point pXY)) "Point")
 (vla-put-Layer (setq str (vla-addtext spc val (vlax-3d-point pXY) h)) "Sothutu")
 (vla-put-Alignment str 8)
 (vla-put-TextAlignmentPoint str (vlax-3d-point pXY))
 (vla-put-Layer (vla-addtext spc (caddr pt) (vlax-3d-point pXY) h) "Caodo") )))))  ))
 (princ))

với yêu cầu:

- File text dạng : SST,Y,X,Z,Code

- Độ cao Z có dấu chấm ở hàng thập phân nằm đúng vào vị trí tọa độ (X,Y) của điểm đó .

Em xin cảm ơn trước.

Bạn muốn như vậy thì phải tạo block Att rồi. Sau đó tách thành 2 kiểu nguyên và phần sau dấu phẩy. Cái này tôi làm được nhưng không có thời gian. Bác Ketxu sẽ giúp bạn nếu bạn đưa ra 1 file mẫu.

Chú ý với bất cứ ai yêu cầu đều phải đưa file mẫu lên.

Hề hề. Ketxu quan tâm mừ.


<<

Filename: 191549_rft.lsp
Tác giả: Bee
Bài viết gốc: 426209
Tên lệnh: mirror blockatt
Hỏi về cách sử dụng text trong Attribute.
23 phút trước, Mèo Mun đã nói:
>>
23 phút trước, Mèo Mun đã nói:

 

 

Bác giúp em code cách kiểm tra :Justify của Att với . :((( Kiểm tra thuộc tính đối tượng thì em đang dùng NENTSEL, nhưng để chọn được đối tượng khối ngoài cùng ( là Block chứa nó ) , thì em chưa biết làm. 

Ok đây là phần check justify với trường hợp là các dtuong cùng left hoặc right để mirror. Nếu lẫn lộn thì bạn tự modify code thêm nhé.

(defun c:mirror_blockatt  ()
  
  (command "select" "all" "")
  (setq remove (ssget "p"))

  (print "MIRROR Select objects: ")
  (if (setq ss (ssget))
    (progn
      (command "mirror" ss "" pause pause "N")

      (command "select" "all" "remove" remove "")
      (setq new (ssget "p"))

      (if (= 0 (check_justify (ssname new 0)))
        (setq j "R")
        (setq j "L")
        )

      (command "_justifytext" new "" j "")
      )
    )
  (princ)
  )

(defun check_justify (en / ent justify)
  (setq ent (entnext en))
  (while (/= "SEQEND" (cdr (assoc 0 (entget ent))))
    (if (= "ATTRIB" (cdr (assoc 0 (entget ent))))
      (setq justify (cdr (assoc 72 (entget ent))))
      )
    (setq ent (entnext ent))
    )
  justify
  )

@DVH: chắc bạn này chưa sài qua autolisp duyệt att in block. ^_^


<<

Filename: 426209_mirror_blockatt.lsp
Tác giả: Doan Nguyen Van
Bài viết gốc: 439903
Tên lệnh: te
Lisp gắn đối tượng text/mtext/dtext với đường dim kích thước (trở thành text override của dim)
31 phút trước, Nguyên Khải đã nói:

      Em có 1 bài toán...

>>
31 phút trước, Nguyên Khải đã nói:

      Em có 1 bài toán được đặt ra như sau: "Có một Mtext/Text/Dtext ở 1 vị trí bất kì trong bản vẽ (cùng model/layout) và một đường dim kích thước, tạo 1 lisp lệnh biến Mtext/Text/Dtext đã có trở thành Text Override của đường dim mà không làm thay đổi vị trí ban đầu của đoạn text hay đường dim đó". (Xem hình minh họa bên dưới)

 

      Các pro giúp em giải quyết nó với.

 

 

Nếu dim giống bài toán trước của bác thì có thể dùng lisp này.

(defun c:te (/ ndt ent1 ent2 dxf)
(setq ent1 (ent_pick '("TEXT" "MTEXT" "DTEXT") "Pick TEXT"))
  (setq ent2 (ent_pick '("DIMENSION" ) "Pick DIMENSION"))
(if (and ent1 ent2)
(progn
  (setq ndt (Cdr (assoc 1 (entget ent1))))
(setq dxf (entget ent2))
 (setq dxf (subst (cons 1 (strcat "<>" "\\X" ndt)) (assoc 1 dxf) dxf))
 (entmod dxf)
	  ))
  (princ))
(defun ent_pick (typ promp / ent)
  (if (not (listp typ)) (setq typ (list typ)))
  (setq typ (mapcar 'list typ))
  (while (not ent)
    (while (not (setq ent (car (entsel (strcat "\n" promp))))))
    (if (not (assoc (cdr (assoc 0 (entget ent))) typ)) (setq ent nil))
    )
  ent
  )

 


<<

Filename: 439903_te.lsp
Tác giả: mr.thanh2610
Bài viết gốc: 439947
Tên lệnh: qb
Về vấn đề lisp xoay block theo đường dẫn

Mình có sưu tầm một lisp trên CV của bác KangKung, lisp có công dụng xoay đối tượng block theo đường line, pline, nhưng spline thì không thực hiện được.

Xin nhờ các anh em trong diễn đàn chỉnh sửa giúp nhé, xin cảm ơn.

;; free lisp from cadviet.com
;;; this lisp was downloaded from...
>>

Mình có sưu tầm một lisp trên CV của bác KangKung, lisp có công dụng xoay đối tượng block theo đường line, pline, nhưng spline thì không thực hiện được.

Xin nhờ các anh em trong diễn đàn chỉnh sửa giúp nhé, xin cảm ơn.

;; free lisp from cadviet.com
;;; this lisp was downloaded from https://www.cadviet.com/forum/topic/69764-y%C3%AAu-c%E1%BA%A7u-lisp-xoay-block-theo-h%C6%B0%E1%BB%9Bng-pline-cho-tr%C6%B0%E1%BB%9Bc/
;========LISP XOAY BLOCK THEO HUONG TUYEN==========
;=============KANGKUNG 28/03/2013==================
(defun C:QB()
  (command "UNDO" "BE")
  (setq tuyen nil)
  (while (= (setq tuyen (car (entsel "\n Chon tuyen:\n"))) nil))
  (setq taphop(ssget '((0 . "INSERT"))))
  (setq index 0)
  (while (< index (sslength taphop))
    (setq block(entget (ssname taphop index)))
    (setq insertpoint(cdr (assoc 10 block)))
    (if (= (vlax-curve-getDistAtPoint tuyen (vlax-curve-getClosestPointTo tuyen insertpoint)) (vla-get-length (vlax-ename->vla-object tuyen)))
      (entmod (subst (cons 50 (+ pi (angle (vlax-curve-getClosestPointTo tuyen insertpoint) ( vlax-curve-getPointAtDist tuyen (+ (vlax-curve-getDistAtPoint tuyen (vlax-curve-getClosestPointTo tuyen insertpoint)) -0.001))))) (assoc 50 block) block))
      (entmod (subst (cons 50 (+ pi (angle ( vlax-curve-getPointAtDist tuyen (+ (vlax-curve-getDistAtPoint tuyen (vlax-curve-getClosestPointTo tuyen insertpoint)) 0.001)) (vlax-curve-getClosestPointTo tuyen insertpoint)))) (assoc 50 block) block))
      )
    (setq index (+ index 1)))
  (command "UNDO" "END")
  )
(princ "\n                Written By KangKung - 28/03/2013\n")
(princ "\n                  Nhap KK de chay chuong trinh\n")

 

QUAY BLOCK THEO DUONG DAN (QB).lsp


<<

Filename: 439947_qb.lsp

Trang 298/310

298