Jump to content
InfoFile
Tác giả: Doan Van Ha
Bài viết gốc: 418520
Tên lệnh: ha
Vẽ Một Hình Chữ Nhật Khi Đã Biết Chiều Dài 4 Cạnh.

Đây là 1 bài toán đưa đến việc phải giải 1 phương trình bậc cao >> cách giải gần đúng là chấp nhận được (vì theo lý thuyết thì không phải pt nào cũng giải được kết quả đúng tuyệt đối).

Làm cú lisp, với chấp nhận sai số ~ 1E-6 thì pt có 2 nghiệm, với L là đường chéo nối 2 cạnh 4.000 và 4.050 ta được:

- Với L=7.71455 >> S=45.0099936850

- Với L=7.41764 >>...

>>

Đây là 1 bài toán đưa đến việc phải giải 1 phương trình bậc cao >> cách giải gần đúng là chấp nhận được (vì theo lý thuyết thì không phải pt nào cũng giải được kết quả đúng tuyệt đối).

Làm cú lisp, với chấp nhận sai số ~ 1E-6 thì pt có 2 nghiệm, với L là đường chéo nối 2 cạnh 4.000 và 4.050 ta được:

- Với L=7.71455 >> S=45.0099936850

- Với L=7.41764 >> S=45.0100003754

Cad đây:

http://www.cadviet.com/upfiles/7/67029_dung_hinh.dwg

Lisp đây:

(defun C:HA(/ a1 a2 a3 a4 a5 step p1 p2 s1 s2 lst)
 (setq a1 4.000 a2 4.050 a3 11.150 a4 11.260 step 1E-6 a5 (+ a1 step))
 (while (< a1 a5 (+ a1 a2))
  (setq p1 (/ (+ a1 a2 a5) 2))
  (setq p2 (/ (+ a3 a4 a5) 2))
  (setq s1 (sqrt (* p1 (- p1 a1) (- p1 a2) (- p1 a5))))
  (setq s2 (sqrt (* p2 (- p2 a3) (- p2 a4) (- p2 a5))))
  (if (equal (+ s1 s2) 45.01 step) (setq lst (cons a5 lst)))
  (setq a5 (+ a5 step)))
 lst) 
; L=(7.71455 7.41764)
; S=(45.0099936850 45.0100003754)

<<

Filename: 418520_ha.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 418545
Tên lệnh: ha
Vẽ Một Hình Chữ Nhật Khi Đã Biết Chiều Dài 4 Cạnh.

Đây là 2 hình thỏa mãn yêu cầu ngộ của bạn:

Cad:

http://www.cadviet.com/upfiles/7/67029_dung_hinh_1.dwg

Lisp:

(defun C:HA(/ a1 a2 a3 a4 a5 step p1 p2 s1 s2 lst)
 (setq a1 4.050 a2 11.260 a3 4.00 a4 11.150 step 1E-6 a5 (+ (- a2 a1) step))
 (while (< (- a2 a1) a5 (+ a3 a4))
  (setq p1 (/ (+ a1 a2...
>>

Đây là 2 hình thỏa mãn yêu cầu ngộ của bạn:

Cad:

http://www.cadviet.com/upfiles/7/67029_dung_hinh_1.dwg

Lisp:

(defun C:HA(/ a1 a2 a3 a4 a5 step p1 p2 s1 s2 lst)
 (setq a1 4.050 a2 11.260 a3 4.00 a4 11.150 step 1E-6 a5 (+ (- a2 a1) step))
 (while (< (- a2 a1) a5 (+ a3 a4))
  (setq p1 (/ (+ a1 a2 a5) 2))
  (setq p2 (/ (+ a3 a4 a5) 2))
  (setq s1 (sqrt (* p1 (- p1 a1) (- p1 a2) (- p1 a5))))
  (setq s2 (sqrt (* p2 (- p2 a3) (- p2 a4) (- p2 a5))))
  (if (equal (+ s1 s2) 45.01 step) (setq lst (cons a5 lst)))
  (setq a5 (+ a5 step)))
 lst) 
; L=(12.1367 11.6696)
; S=(45.00994873 45.01000977)

<<

Filename: 418545_ha.lsp
Tác giả: snowman.hms
Bài viết gốc: 362508
Tên lệnh: xrec
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Chuyển rectangle sẵn có sang có arc segment (cạnh nhỏ sẽ chuyển thành arc) 

(defun c:xrec ( / s e i el bl d1 d2)
  
  (if (setq s (ssget '((0 . "LWPOLYLINE") (90 . 4) (-4 . "&=") (70 . 1))))
    (repeat (setq i (sslength s))
      (setq e  (ssname s (setq i (1- i))) el (entget e)
	    vl (_massoc 10 el)  e (vlax-ename->vla-object e))
      
      (if (Rectangle-p el)
	(progn
          (if (LM:Clockwise-p (car vl) (cadr...
>>

Chuyển rectangle sẵn có sang có arc segment (cạnh nhỏ sẽ chuyển thành arc) 

(defun c:xrec ( / s e i el bl d1 d2)
  
  (if (setq s (ssget '((0 . "LWPOLYLINE") (90 . 4) (-4 . "&=") (70 . 1))))
    (repeat (setq i (sslength s))
      (setq e  (ssname s (setq i (1- i))) el (entget e)
	    vl (_massoc 10 el)  e (vlax-ename->vla-object e))
      
      (if (Rectangle-p el)
	(progn
          (if (LM:Clockwise-p (car vl) (cadr vl) (caddr vl)) (setq bl '(-1 -1)) (setq bl '(1 1)))
	  (setq d1 (vlax-curve-getdistatparam e 1)
		d2 (- (vlax-curve-getdistatparam e 2) d1))
	  (if (<= d1 d2)
	    (mapcar '(lambda (i b) (vla-SetBulge e i b)) '(0 2) bl)
	    (mapcar '(lambda (i b) (vla-SetBulge e i b)) '(1 3) bl) 
	  )
	)
      )
    )
  )
  (princ)
)
;;==============================================================;;
(defun Rectangle-p (el / lst p1 p2 p3 p4)
  (and
    (= "LWPOLYLINE" (cdr (assoc 0 el)))
    (= 1 (cdr (assoc 70 el)))
    (setq lst (_massoc 10 el))
    (= 4 (length lst))
    (vl-every
      '(lambda (x) (zerop x))
      (_massoc 42 el)
    )
    (mapcar '(lambda (v p) (set v p)) '(p1 p2 p3 p4) lst)
    (equal 1 (/ (distance p1 p2) (distance p3 p4)) 1e-9)
    (equal 1 (/ (distance p1 p4) (distance p2 p3)) 1e-9)
    (equal 1 (/ (distance p1 p3) (distance p2 p4)) 1e-9)
  )
)
(defun _massoc (key lst)
  (if (setq itm (assoc key lst))
    (cons (cdr itm) (_massoc key (cdr (member itm lst))))
  )
)

;; Clockwise-p  -  Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented or collinear
                 
(defun LM:Clockwise-p ( p1 p2 p3 )
    (<  (-  (* (- (car  p2) (car  p1)) (- (cadr p3) (cadr p1)))
            (* (- (cadr p2) (cadr p1)) (- (car  p3) (car  p1)))
        )
        1e-8
    )
)

<<

Filename: 362508_xrec.lsp
Tác giả: quocmanh04tt
Bài viết gốc: 363695
Tên lệnh: mld
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Sao đọc mà k hiểu ý hỏi ta ....

Xin lỗi bác, do em đặt câu hỏi chưa rõ ràng. Chính xác hơn Entmake MLEADERSTYLE (chứ không phải là mleader).
Đây là code:
(defun c:mld (/ createmultileader shtdata)
(defun createmultileader (data $stylename / dic obj)
(if (not (member $stylename
(foreach lstnfo (dictsearch (namedobjdict)...
>>

Sao đọc mà k hiểu ý hỏi ta ....

Xin lỗi bác, do em đặt câu hỏi chưa rõ ràng. Chính xác hơn Entmake MLEADERSTYLE (chứ không phải là mleader).
Đây là code:
(defun c:mld (/ createmultileader shtdata)
(defun createmultileader (data $stylename / dic obj)
(if (not (member $stylename
(foreach lstnfo (dictsearch (namedobjdict) "ACAD_MLEADERSTYLE")
(if (= 3 (car lstnfo))
(if (not newlst)
(setq newlst (list lstnfo))
(setq newlst (append (list lstnfo) newlst)))))))
(if (and (setq dic (dictsearch (namedobjdict) "ACAD_MLEADERSTYLE"))
(setq dic (cdr (assoc -1 dic)))
(setq obj (entmakex data)))
(progn (dictremove dic $stylename) (dictadd dic $stylename obj))))
(if (vl-catch-all-error-p (vl-catch-all-apply '(lambda () (vla-put-arrowsymbol $stylename "_Origin2"))))
(not (vl-catch-all-error-p
(vl-catch-all-apply '(lambda () (vla-put-arrowsymbol $stylename acarrowdefault)))))))
(setq shtdata (list (cons 0 "MLEADERSTYLE")
(cons 5 "362")
(cons 102 "{ACAD_REACTORS")
(cons 102 "}")
(cons 100 "AcDbMLeaderStyle")
(cons 179 2)
(cons 170 1)
(cons 171 1)
(cons 172 0)
(cons 90 2)
(cons 40 0.0)
(cons 41 3.14159)
(cons 173 1)
(cons 91 -1056964608)
(cons 92 -2)
(cons 290 1)
(cons 42 2.0)
(cons 291 1)
(cons 43 750.0)
(cons 3 "Standard")
(cons 44 100.0)
(cons 300 "")
(cons 174 5)
(cons 178 5)
(cons 175 1)
(cons 176 0)
(cons 93 -1073741824)
(cons 45 250.0)
(cons 292 0)
(cons 297 0)
(cons 46 4.0)
(cons 94 -1056964608)
(cons 47 0.75)
(cons 49 0.75)
(cons 140 0.75)
(cons 293 1)
(cons 141 0.0)
(cons 294 1)
(cons 177 0)
(cons 142 1.0)
(cons 295 0)
(cons 296 0)
(cons 143 10.0)
(cons 271 0)
(cons 272 9)
(cons 273 9)
(cons 298 1)))
(createmultileader shtdata "SHT")
(princ))
Nếu như này thì khi vẽ mleader cad sẽ hỏi block tên gì?
<<

Filename: 363695_mld.lsp
Tác giả: Nguyen Hoanh
Bài viết gốc: 132
Tên lệnh: chl chl
Xử lý bản vẽ bị lẻ số
- Bạn đang vẽ một bản cad lẻ toét, các số cứ sêm sêm nhau cỡ: 8399.9899 thay vì 8400. Mặc dù bạn đánh kích thước thì vẫn có kết quả là 8400 nhưng rất 'ngứa ngáy'. Số lẻ này làm một lệnh (như pedit, hatch)không hoạt động tốt. Làm gì để các con số này chẵn với nhau? làm sao để các kích thước không còn lẻ?

- Đơn giản, bạn sử dụng chương trình làm chẵn của cadviet, appload chương...
>>
- Bạn đang vẽ một bản cad lẻ toét, các số cứ sêm sêm nhau cỡ: 8399.9899 thay vì 8400. Mặc dù bạn đánh kích thước thì vẫn có kết quả là 8400 nhưng rất 'ngứa ngáy'. Số lẻ này làm một lệnh (như pedit, hatch)không hoạt động tốt. Làm gì để các con số này chẵn với nhau? làm sao để các kích thước không còn lẻ?

- Đơn giản, bạn sử dụng chương trình làm chẵn của cadviet, appload chương trình lên, sau đó sử dụng lệnh chl chương trình sẽ yêu cầu bạn chọn các đối tượng muốn làm chẵn và điểm gốc chẵn (để các tọa độ sẽ chẵn với điểm gốc này), và mức làm chẵn. Ví dụ bạn muốn làm chẵn đến đơn vị mét (là 1000) thì bạn nhập mức 5..


(defun c:chl (/ p ss x y solt mlt)
(defun lamtron (so / t1)
(setq
t1 (abs so)
t2 (* solt (float (fix (/ t1 solt))))
t1 (cond
((< (- t1 t2) (* 0.5 solt)) t2)
(t (+ t2 (* 1.0 solt)))
)
)
(if (> so 0.0)
t1
(* -1.0 t1)
)
)
(defun chlone (ent / p1 p2 dx dy tt x1 y1 z1 x2 y2 z2)
(setq
tt (entget ent)
)
(foreach pp tt
(if (or (= (car pp) 10)
(= (car pp) 11)
)
(progn
(setq
p1 (cdr pp)

x1 (car p1)
y1 (cadr p1)
z1 (cond
((= (length p1) 3) (caddr p1))
(t nil)
)
dx1 (- x1 x)
dy1 (- y1 y)
dx1 (lamtron dx1)
dy1 (lamtron dy1)
x1 (+ x dx1)
y1 (+ y dy1)

p1m (cond
(z1 (list x1 y1 z1))
(t (list x1 y1))
)

tt (subst (cons (car pp) p1m) pp tt)
)
(entmod tt)
)
)
)

)
(H:init)
(setq ss (ssget) ;'((0 . "LINE")))
muctron (list 1.0 5.0 10.0 100.0 500.0 1000.0 2000.0 5000.0
100000.0)
p (getpoint "\nDiem chen: ")
temp (getint
"\nMuc lam tron: 0=1, 1=5, 2=10, 3=100, 4=500, 5=1000, 6=2000, 7=5000, 8=100000 <0>: "
)
mlt (cond
(temp temp)
(t 0)
)
x (car p)
y (cadr p)
solt 1.0
)
(setq solt (nth mlt muctron))
(H:sudung chlone ss)
(H:done)
)

;;------------------------------------------------------------
(defun H:newerror (msg)
(if (and (/= msg "Function cancelled")
(/= msg "quit / exit abort")
)
(princ (strcat "\n" msg))
)
(H:done)
)
;;----------
(defun H:init ()
(setq
H:VAR_CMDECHO
(getvar "CMDECHO")
H:VAR_OLDERROR
*error*
*error* H:newerror

)
(setvar "CMDECHO" 0)
(command ".undo" "BE")
)
;;----------
(defun H:done ()
(if (null command-s)
(command ".redraw")
(command-s ".redraw")
)
(if (null command-s)
(command ".undo" "E")
(command-s ".undo" "E")
)
(if H:VAR_CMDECHO
(setvar "CMDECHO" H:VAR_CMDECHO)
)
(if H:VAR_OLDERROR
(setq *error* H:VAR_OLDERROR)
)
(princ)
)
;;----------
(defun H:sudung (hamsudung ss /)
(length
(vl-remove-if
'null
(mapcar 'hamsudung
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
)
)

(defun c:chl (/ p ss x y solt mlt)
(defun lamtron (so / t1)
(setq
t1 (abs so)
t2 (* solt (float (fix (/ t1 solt))))
t1 (cond
((< (- t1 t2) (* 0.5 solt)) t2)
(t (+ t2 (* 1.0 solt)))
)
)
(if (> so 0.0)
t1
(* -1.0 t1)
)
)
(defun chlone (ent / p1 p2 dx dy tt x1 y1 z1 x2 y2 z2)
(setq
tt (entget ent)
)
(foreach pp tt
(if (or (= (car pp) 10)
(= (car pp) 11)
)
(progn
(setq
p1 (cdr pp)

x1 (car p1)
y1 (cadr p1)
z1 (cond
((= (length p1) 3) (caddr p1))
(t nil)
)
dx1 (- x1 x)
dy1 (- y1 y)
dx1 (lamtron dx1)
dy1 (lamtron dy1)
x1 (+ x dx1)
y1 (+ y dy1)

p1m (cond
(z1 (list x1 y1 z1))
(t (list x1 y1))
)

tt (subst (cons (car pp) p1m) pp tt)
)
(entmod tt)
)
)
)

)
(H:init)
(setq ss (ssget) ;'((0 . "LINE")))
muctron (list 1.0 5.0 10.0 100.0 500.0 1000.0 2000.0 5000.0
100000.0)
p (getpoint "\nDiem chen: ")
temp (getint
"\nMuc lam tron: 0=1, 1=5, 2=10, 3=100, 4=500, 5=1000, 6=2000, 7=5000, 8=100000 <0>: "
)
mlt (cond
(temp temp)
(t 0)
)
x (car p)
y (cadr p)
solt 1.0
)
(setq solt (nth mlt muctron))
(H:sudung chlone ss)
(H:done)
)

<<

Filename: 132_chl_chl.lsp
Tác giả: Tue_NV
Bài viết gốc: 108199
Tên lệnh: veh
Viết lisp theo yêu cầu [phần 2]

Của bác đây :

Filename: 108199_veh.lsp
Tác giả: classicgt
Bài viết gốc: 418945
Tên lệnh: arf
Nhờ Các Bác Sửa Cho Lisp Copy Theo Kiểu Array
(defun c:arf ( / ss->list copyv dx dy gr i1 i2 nx ny obs obx oby p0 px py vx vy ) (vl-load-com)
(defun ss->list ( ss / i l )
(if ss
(repeat (setq i (sslength ss))
(setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
)
)
)
(defun copyv ( ob n v / i b l ) (setq i 1 b (vlax-3D-point '(0. 0. 0.)))
(repeat n
(foreach obj ob
(vla-move (car (setq l (cons (vla-copy obj) l))) b (vlax-3D-point (mapcar '* v (list i i...
>>
(defun c:arf ( / ss->list copyv dx dy gr i1 i2 nx ny obs obx oby p0 px py vx vy ) (vl-load-com)
(defun ss->list ( ss / i l )
(if ss
(repeat (setq i (sslength ss))
(setq l (cons (vlax-ename->vla-object (ssname ss (setq i (1- i)))) l))
)
)
)
(defun copyv ( ob n v / i b l ) (setq i 1 b (vlax-3D-point '(0. 0. 0.)))
(repeat n
(foreach obj ob
(vla-move (car (setq l (cons (vla-copy obj) l))) b (vlax-3D-point (mapcar '* v (list i i i))))
)
(setq i (1+ i))
)
l
)
(if
(and
(setq obs (ss->list (ssget '((0 . "~VIEWPORT")))))
(setq p0 (getpoint "\nBase Point (P0): "))
(setq px (getpoint "\nArray X-Vector (Px): " p0))
(setq py (getpoint "\nArray Y-Vector (Py): " p0))
)
(progn
(setq vx (mapcar '- px p0) dx (distance '(0. 0. 0.) vx)
vy (mapcar '- py p0) dy (distance '(0. 0. 0.) vy)
)
(princ "\nArray Endpoint: ")
(while (= 5 (car (setq gr (grread 't 13 0)))) (redraw)
(setq obx (car (mapcar 'vla-delete obx))
oby (car (mapcar 'vla-delete oby))
gr (mapcar '- (cadr gr) p0)
i1 (inters '(0. 0. 0.) vx gr (mapcar '+ gr vy) nil)
i2 (inters '(0. 0. 0.) vy gr (mapcar '+ gr vx) nil)
nx (fix (/ (caddr (trans i1 1 vx)) dx))
ny (fix (/ (caddr (trans i2 1 vy)) dy))
obx (copyv obs (abs nx) (mapcar (if (minusp nx) '- '+) vx))
oby (copyv (append obs obx) (abs ny) (mapcar (if (minusp ny) '- '+) vy))
)
(grvecs (list -3 '(0. 0. 0.) i1 i1 gr '(0. 0. 0.) i2 i2 gr)
(list
(list 1. 0. 0. (car p0))
(list 0. 1. 0. (cadr p0))
(list 0. 0. 1. (caddr p0))
(list 0. 0. 0. 1.)
)
)
)
)
)
(redraw) (princ)
)

111024_lisparraynangcaotrongautocad.gif


<<

Filename: 418945_arf.lsp
Tác giả: Bee
Bài viết gốc: 418976
Tên lệnh: test
Lisp Tự Mirror, Sau Đó Join Các Đường Đã Mirror

Em mò trên mạng, ra cái Polylines Program của Lee-Mac, nhưng cái này khi mình mirror tất cả, rồi join, thì với các đường giao nhau, nó sẽ join loạn lên, không join chuẩn các đường đối xứng qua trục Y như em cần.

Em mò trên mạng, ra cái Polylines Program của Lee-Mac, nhưng cái này khi mình mirror tất cả, rồi join, thì với các đường giao nhau, nó sẽ join loạn lên, không join chuẩn các đường đối xứng qua trục Y như em cần.

http://www.lee-mac.com/polylineprograms.html#polyjoin

 

em mò theo kiểu thủ công như cái này, thì lượng polyline bị xót rất nhiều, vì nhiều poliline quá gần nhau, nên chọn không chuẩn :wacko: .

http://www.cadviet.com/upfiles/7/12799_123.lsp

 

Làm sao để mình chọn tất cả objects, rồi nó tự chạy lisp theo kiểu one by one đc các bác ơi  :blush:

Quả Lisp thô sơ này chắc chạy ngon. Nhớ move chuẩn trục Y ở 0.0 nhé. ^_^

(defun c:test (/ ss n ss1)
  (setq ss (ssget))
  (setq n 0)
  (setq ss1 (ssadd))
  (repeat (sslength ss)
    (setq ss1 (ssadd (ssname ss n) ss1))    
    (command "mirror" ss1 "" "0,0" "0,1" "N" "")
    (setq ss1 (ssadd (entlast) ss1))
    (command ".PEDIT" "m" ss1 "" "j" "0.025" "" )
    (setq ss1 (ssadd))
    (setq n (1+ n))
    )
  (princ)
  )

<<

Filename: 418976_test.lsp
Tác giả: Kieu Tan
Bài viết gốc: 409573
Tên lệnh: mb
Viết Chữ Tiếng Việt Trong Lisp (Unicode)

Mình có đoạn lsp dùng để viết chữ (chữ mặc định), nhưng sau khi gõ lệnh và dùng thì nó bị lỗi font 

Mình muốn dùng font arial (bảng mã unicode, kiểu gõ vni)

Mình muốn ghi ra là chữ" MẶT BẰNG TÔN MÁI 

Mong mọi người sửa dùm tí, mình xin cảm ơn ! 


(DEFUN C:MB (/ TILE P)
  (IF (= (TBLOBJNAME "STYLE" "ARIAL") NIL)
  	(command ".STYLE" "ARIAL"...
>>

Mình có đoạn lsp dùng để viết chữ (chữ mặc định), nhưng sau khi gõ lệnh và dùng thì nó bị lỗi font 

Mình muốn dùng font arial (bảng mã unicode, kiểu gõ vni)

Mình muốn ghi ra là chữ" MẶT BẰNG TÔN MÁI 

Mong mọi người sửa dùm tí, mình xin cảm ơn ! 


(DEFUN C:MB (/ TILE P)
  (IF (= (TBLOBJNAME "STYLE" "ARIAL") NIL)
  	(command ".STYLE" "ARIAL" "VNI-ARIAL" "" "" "" "" "" "")
    )
  (SETQ
	tile (getint "\nTi le: ")
	p (getpoint "\nChon diem chen text: ")
	)
  (COMMAND "TEXT" "S" "ARIAL" "J" "MC" P (* TILE 2) "0" "%%UMẶT BẰNNG TÔN MÁI"
	            )
)





<<

Filename: 409573_mb.lsp
Tác giả: dinhvantrang
Bài viết gốc: 418984
Tên lệnh: attdef2text
Lisp đổi tên hàng loạt Layouts!

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

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

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

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

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

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

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

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

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

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

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

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

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


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

Gửi bác VanHoa


<<

Filename: 418984_attdef2text.lsp
Tác giả: Bommak
Bài viết gốc: 33972
Tên lệnh: dx arearon dx
Viết Lisp theo yêu cầu
Em định viết 1 đoạn lisp thực hiện lệnh dimlinear của cad nhưng gặp khó khăn mong được các bác giúp đỡ. Đoạn code em viết thử thì thấy hoạt động bình thường (giống như CAD) đối với các đối tượng đơn (LINE, ARC) nhưng nếu đối tượng chọn (LINE, ARC) là một segment trong 1 LWPOLYLINE thì đoạn code của em không giải quyết được (lệnh dimlinear của CAD thì vẫn giải quyết ngon lành), điều...
>>
Em định viết 1 đoạn lisp thực hiện lệnh dimlinear của cad nhưng gặp khó khăn mong được các bác giúp đỡ. Đoạn code em viết thử thì thấy hoạt động bình thường (giống như CAD) đối với các đối tượng đơn (LINE, ARC) nhưng nếu đối tượng chọn (LINE, ARC) là một segment trong 1 LWPOLYLINE thì đoạn code của em không giải quyết được (lệnh dimlinear của CAD thì vẫn giải quyết ngon lành), điều này làm em băn khoăn mà không hiểu tại sao. Em không có kiến thức sâu về xử lý ENTITY data nên loay hoay mãi không biết cách làm. Em mong các bác giúp đỡ. Thanks


<<

Filename: 33972_dx_arearon_dx.lsp
Tác giả: Bee
Bài viết gốc: 419179
Tên lệnh: test
Giúp Xóa Trích Đoạn Trên Đường Thẳng Hoặc Đường Cong

Vâng ạ. Mong muốn được giúp đỡ, vì em cắt thủ công mất nhiều time quá!

Em cần để thiết kế file dạng này :162071_z731808364319_482d37fa11448598cee

Viết nhanh xem Người phán xử, ^_^ Lỗi gì...

>>

Vâng ạ. Mong muốn được giúp đỡ, vì em cắt thủ công mất nhiều time quá!

Em cần để thiết kế file dạng này :162071_z731808364319_482d37fa11448598cee

Viết nhanh xem Người phán xử, ^_^ Lỗi gì chỉnh sau. Chạy thử đi nhé.

(defun c:test ()
  (princ "\nChon doi tuong can cat: ")
  (setq ss (ssget))
  (setq foo (getdist "\nChon khoang cach cat: "))
  (setq n (getint "\nChon so luong cat: "))
  (if (and foo ss n)
    (progn      
      (foreach e (ssnamex ss); 
	(command "divide" (cadr e) (1+ n))
	(setq ss1 (ssadd))
	(setq pts (ssget "_P"))
	(foreach pt (ssnamex pts)
	  (command "circle" "_none" (cdr (assoc 10 (entget (cadr pt)))) (/ foo 2))
	  (setq ci (entlast))
	  (setq ss1 (ssadd ci ss1))
	  (command "erase" (cadr pt) "")
	  )
	(foreach c (ssnamex ss1)
	  (command "trim" (cadr c) "" (cdr (assoc 10 (entget (cadr c)))) "")
	  )
	(command "erase" ss1 "")
	);for
      );progn
    );if
  (princ)
  )

<<

Filename: 419179_test.lsp
Tác giả: ksgia
Bài viết gốc: 16535
Tên lệnh: test
Mẹo sử dụng AutoCAD


Bạn vào Express > Tools > Command Alias Editor...> Hiện bảng các lệnh tắt.
Bạn có thể thay đổi lệnh tắt hoặc đặt lệnh tắt cho riêng mình ví dụ: ngày tháng năm sinh của người iu...

Filename: 16535_test.lsp
Tác giả: Bee
Bài viết gốc: 419173
Tên lệnh: test2
Lisp Tự Mirror, Sau Đó Join Các Đường Đã Mirror

Bác ơi cái file của em đây, làm như nào hả bác?

 

Các frames nẳm trên mặt x0z, giờ move từng Frame (từ trong ra ngoài ) theo trục y, , mỗi đường cách nhau 500, thì làm như nào hả bác?

 

Để nguyên Pline sau khi join trên mặt phẳng XoY. Chạy lisp mới chọn những pline trước sau đó chọn Line // trục X với điểm bắt đầu từ trục Y trở đi để tính 1 điểm cắt với pline thôi nhé. Sau khi move hết theo trục Z xuống cách 1 khoảng 500 thì xoay toàn bộ đối tượng sau nhé. Chúc ngon miệng ^_^

moveandjoin1.png

(defun LM:intersections	(ob1 ob2 mod / lst rtn)
  (if (and (vlax-method-applicable-p ob1 'intersectwith)
	   (vlax-method-applicable-p ob2 'intersectwith)
	   (setq lst (vlax-invoke ob1 'intersectwith ob2 mod))
      )
    (repeat (/ (length lst) 3)
      (setq rtn	(cons (list (car lst) (cadr lst) (caddr lst)) rtn)
	    lst	(cdddr lst)
      )
    )
  )
  (reverse rtn)
)
(vl-load-com)

(defun c:test2 ()
  (setq osm (getvar "osmode"))
  (setvar "osmode" 0)
  (command "undo" "be")
  (princ "\nChon doi tuong: ")
  (if (setq ss (ssget '((0 . "LWPOLYLINE"))))
    (progn
      (if (setq line_X (car (entsel "\nChon doan thang // X: ")))
	(progn
	  (setq	lst_e (vl-remove-if
			'listp
			(mapcar 'cadr (ssnamex ss))
		      )
	  )
	  (setq lst_pt nil)
	  (foreach e lst_e
	    (setq pt (LM:intersections
		       (vlax-ename->vla-object e)
		       (vlax-ename->vla-object line_X)
		       acextendnone
		     )
	    )
	    (setq lst_pt (cons (cons e (car pt)) lst_pt))
	  )
	  (vl-sort lst_pt '(lambda (e1 e2) (< (cadr e1) (cadr e2)))) ;
	  (setq n 500)
	  (foreach pl (cdr lst_pt)
	    (command "move"
		     (car pl)
		     ""
		     "0,0,0"
		     (strcat "0,0,-" (rtos n 2 0))
	    )
	    (setq n (+ n 500))
	  )
	)				;progn line_X
	(princ "\nBan da khong chon doan thang // X.")
      )					;if
    )					;progn ss
    (princ "\nBan da khong chon doi tuong.")
  )					;if

  (command "undo" "end")
  (setvar "osmode" osm)
  (princ)
)					;defun

<<

Filename: 419173_test2.lsp
Tác giả: MANHHUNGXDA
Bài viết gốc: 16540
Tên lệnh: test
KHUNG TÊN BẢN VẼ


oi thôi, mình xin lỗi, mình làm tren cad 2007 các bạn khác phục hôn mình nhwe
ai có khung tên khác, mình có thể thiết kế hộ 1 bản.

Filename: 16540_test.lsp
Tác giả: Bee
Bài viết gốc: 419286
Tên lệnh: test
Hoán đổi vị trí hai đối tượng cho nhau

Em muốn hoán đổi vị trí 2 text cho nhau, dùng lệnh này cũng đc nhưng phải làm nhièu thao tác qua,mà em cần phải hoán đổi vị trí text rất nhiều. Em muốn chỉ cần chon 2 text là nó tự chuyển vị trí cho nhau. Bac nào có thể sửa lại cho em đc không?Cam ơn các bác!!

Nghịch cái này nhìn 2 text...

>>

Em muốn hoán đổi vị trí 2 text cho nhau, dùng lệnh này cũng đc nhưng phải làm nhièu thao tác qua,mà em cần phải hoán đổi vị trí text rất nhiều. Em muốn chỉ cần chon 2 text là nó tự chuyển vị trí cho nhau. Bac nào có thể sửa lại cho em đc không?Cam ơn các bác!!

Nghịch cái này nhìn 2 text hoàn đổi vui phết ^_^

(defun c:test ()
  (while (and (setq a (car (entsel "\nChon text 1: ")))
	      (setq b (car (entsel "\nChon text 2: ")))
	      )
    (setq b_ins (assoc 10 (entget b)))
    (entmod (subst (assoc 10 (entget a)) (assoc 10 (entget b)) (entget b)))
    (entmod (subst b_ins (assoc 10 (entget a)) (entget a)))
    )
  (princ)
  )

<<

Filename: 419286_test.lsp
Tác giả: Bee
Bài viết gốc: 419345
Tên lệnh: merge
Nâng Cao Lệnh Chia Dim, Nối Dim

Em có 2 cái lisp sưu tầm, do Em download về, mà lâu quá rồi nên không nhớ nguồn gốc.

1. Lisp chia dim ( hiện tại cứ click là chia )

2. Lisp nối dim ( chọn 2 dim là tự nối với nhau thành 1 dim )

 

Mong mọi người giúp Em nâng cao lên

1. Lisp chia dim ( hiện tại cứ click là chia ), thêm option...

>>

Em có 2 cái lisp sưu tầm, do Em download về, mà lâu quá rồi nên không nhớ nguồn gốc.

1. Lisp chia dim ( hiện tại cứ click là chia )

2. Lisp nối dim ( chọn 2 dim là tự nối với nhau thành 1 dim )

 

Mong mọi người giúp Em nâng cao lên

1. Lisp chia dim ( hiện tại cứ click là chia ), thêm option 2

       +  click là chia

       +  nhập số lần để chia đều, ví dụ chia 10 thì nhập 10, dim tự chia ra 10 phần bằng nhau

 

2. Lisp nối dim ( chọn 2 dim là tự nối với nhau thành 1 dim ), thêm option 2

       +  chọn nhiều dim => nối với nhau thành 1 dim

 

http://www.cadviet.com/upfiles/7/5798_21a_cdd__cat_dim_2.lsp

http://www.cadviet.com/upfiles/7/5798_21_jd__noi_dim_.lsp

 

Mong mọi người giúp Em.

Tóm tắt cái lisp trên tí thôi. Không dài dòng các kiểu. Trường hợp đặc biệt là các dim cùng hàng và chân dim dài như nhau nhé. 

Nghịch thử nhé ^_^

(defun c:merge ()
  (if (setq ss (ssget '((0 . "DIMENSION"))))
    (progn
      (setq lst nil)
      (setq pt (cdr (assoc 10 (entget (ssname ss 0)))))
      (foreach dim (ssnamex ss)
	(if (= 'ename (type (cadr dim)))
	  (progn
	    (setq lst (cons (cdr (assoc 13 (entget (cadr dim)))) lst))
	    (setq lst (cons (cdr (assoc 14 (entget (cadr dim)))) lst))
	  )
	)
      )
      (setq lst (vl-sort lst '(lambda (e1 e2) (< (car e1) (car e2)))))
      (command "erase" ss "")
      (command "dimrotated"
	       (RtD (angle (car lst)
			   (car (reverse lst))
		    )
	       )
	       (car lst)
	       (car (reverse lst))
	       pt
      )
    )
  )
  (princ)
)
(defun RtD (r) (* 180.0 (/ r pi)))

<<

Filename: 419345_merge.lsp
Tác giả: quang_lac
Bài viết gốc: 419384
Tên lệnh: brc
Xin Giúp Đỡ Lisp Chèn 1 Block Vào Tâm Của Nhiều Hình Chữ Nhật
(defun c:brc (/ retcen osmode idx rectangles ins );Chen Block vao tam rectang
(defun rectcen (rect / pl p1 p2 p3 p4 pm1 pm2 an di ceo)
(setq ceo (vlax-ename->vla-object rect))
(setq pl (vlax-safearray->list (vlax-variant-value (vla-get-coordinates ceo))))
(if (> (length pl) 6)
(progn
(setq p1 (list (nth 0 pl) (nth 1 pl)))
(setq p2 (list (nth 2 pl) (nth 3 pl)))
(setq p3 (list (nth 4 pl) (nth 5 pl)))
(setq p4 (list (nth 6 pl) (nth 7 pl)))
(setq pm1 (mapcar '/...
>>
(defun c:brc (/ retcen osmode idx rectangles ins );Chen Block vao tam rectang
(defun rectcen (rect / pl p1 p2 p3 p4 pm1 pm2 an di ceo)
(setq ceo (vlax-ename->vla-object rect))
(setq pl (vlax-safearray->list (vlax-variant-value (vla-get-coordinates ceo))))
(if (> (length pl) 6)
(progn
(setq p1 (list (nth 0 pl) (nth 1 pl)))
(setq p2 (list (nth 2 pl) (nth 3 pl)))
(setq p3 (list (nth 4 pl) (nth 5 pl)))
(setq p4 (list (nth 6 pl) (nth 7 pl)))
(setq pm1 (mapcar '/ (mapcar '+ p1 p3) '(2.0 2.0 2.0)))
(setq pm2 (mapcar '/ (mapcar '+ p2 p4) '(2.0 2.0 2.0)))
(cond
((and
(equal (distance pm1 p1)(distance pm2 p1) 0.001)
(equal (distance pm1 p2)(distance pm2 p2) 0.001)
(equal (distance pm1 p3)(distance pm2 p3) 0.001)
(equal (distance pm1 p4)(distance pm2 p4) 0.001)
)
(inters p1 p3 p2 p4 nil)
)
)
)
)
)
;----------------------------------------------
(vl-load-com)
(command "undo" "begin")
(command "ucs" "w")
(setq osmode (getvar "osmode"))
(setvar "osmode" 0)
(if
(setq rectangles (ssget '((0 . "LWPOLYLINE"))))
(progn
(setq idx 0)
(repeat (sslength rectangles)
(setq ins (rectcen (ssname rectangles idx)))
(if ins (command "-insert" "s" ins "" "" ""))
(setq idx (1+ idx))
)
)
(princ "\n Selected(s) object(s) are not Lwpolyline!")
)
(command "undo" "end")
(setvar "osmode" osmode)
(princ)
) 

thay từ "S" bôi đỏ bằng tên block của bạn


<<

Filename: 419384_brc.lsp
Tác giả: lp_hai
Bài viết gốc: 419401
Tên lệnh: cbr
Xin Giúp Đỡ Lisp Chèn 1 Block Vào Tâm Của Nhiều Hình Chữ Nhật

Góp vui tí :)

(defun c:cbr (/ dt bl sdt id en)
  (command "Undo" "be")
  (setq osm (getvar "osmode")
	bl (cdr (assoc 2 (entget(car (entsel "\nSelect block:")))))
	dt (ssget '((-4 . "<OR")
		(0 . "LWPOLYLINE")
		(-4 . "OR>")	
		))
	sdt (sslength dt)
	id 0
	)
  (setvar "osmode" 0)
  (repeat sdt
    (setq en (ssname dt id)
	  id (1+ id)
	  )
    (midp en)
    )
  (setvar "osmode" osm)
  (command "undo" "end")
  (princ)
  )
   ...
>>

Góp vui tí :)

(defun c:cbr (/ dt bl sdt id en)
  (command "Undo" "be")
  (setq osm (getvar "osmode")
	bl (cdr (assoc 2 (entget(car (entsel "\nSelect block:")))))
	dt (ssget '((-4 . "<OR")
		(0 . "LWPOLYLINE")
		(-4 . "OR>")	
		))
	sdt (sslength dt)
	id 0
	)
  (setvar "osmode" 0)
  (repeat sdt
    (setq en (ssname dt id)
	  id (1+ id)
	  )
    (midp en)
    )
  (setvar "osmode" osm)
  (command "undo" "end")
  (princ)
  )
    
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;	
(defun midp (en / p2 p4 pm)
  (setq p2 (vlax-curve-getPointAtParam en 2)
	p4 (vlax-curve-getPointAtParam en 4)
	pm (list (/(+(car p2)(car p4))2) (/(+(cadr p2)(cadr p4))2))
	)
  (entmake (list  (cons 0 "insert")  (cons 2 bl) (cons 10 pm)))
  )

<<

Filename: 419401_cbr.lsp
Tác giả: lp_hai
Bài viết gốc: 419431
Tên lệnh: cld
Lisp Tự Động Revcloud Các Đối Tượng Cùng 1 Layer

Có thể viết được chọn theo layer, nhưng tốt hơn bạn nên quét chọn các pl để cloud. Thao tác là bạn chọn block revision, tiếp theo chọn các pl.
Còn về arc và kiểu cloud bạn có thể chọn bằng cách dùng lệnh revclound bên ngoài để trong lisp tự động theo

(defun c:cld (/ dt bl sdt id en)
  (command "Undo" "be")
  (setq osm (getvar "osmode")
	bl (cdr (assoc 2 (entget(car (entsel "\nSelect...
>>

Có thể viết được chọn theo layer, nhưng tốt hơn bạn nên quét chọn các pl để cloud. Thao tác là bạn chọn block revision, tiếp theo chọn các pl.
Còn về arc và kiểu cloud bạn có thể chọn bằng cách dùng lệnh revclound bên ngoài để trong lisp tự động theo

(defun c:cld (/ dt bl sdt id en)
  (command "Undo" "be")
  (setq osm (getvar "osmode")
	bl (cdr (assoc 2 (entget(car (entsel "\nSelect Revision block:")))))
	dt (ssget '((-4 . "<OR")
		(0 . "LWPOLYLINE")		    
		(-4 . "OR>")	
		))
	sdt (sslength dt)
	id 0
	)
  (setvar "osmode" 0)
  (repeat sdt
    (while
      (setq en (ssname dt id)
	    id (1+ id)
	    )
      (cloud en)
      )
    )
  (setvar "osmode" osm)
  (command "undo" "end")
  (princ)
  )
    
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;	
(defun cloud (en / p0 p1 pm)
  (setq p0 (vlax-curve-getPointAtParam en 0)
	p1 (vlax-curve-getPointAtParam en 1)
	pm (list (/(+(car p0)(car p1))2) (+(/(+(cadr p0)(cadr p1 ))2)8))
	)
  (command "revcloud" "o" en "")
  (entmake (list  (cons 0 "insert")  (cons 2 bl) (cons 10 pm)))
  ) 

<<

Filename: 419431_cld.lsp

Trang 220/304

220