Jump to content
InfoFile
Tác giả: NguyenNgocSon
Bài viết gốc: 233798
Tên lệnh: dof
Lệnh offset đặc biệt

(defun C:dof(/ lstDis obj)
(setq lstDIS '(9 10 -15))
(while (setq obj (car (entsel "\nSelect object:")))
(foreach dis lstDIS
(vla-offset (vlax-ename->vla-object obj) dis)
)
)
(princ)
)

Code này mình sưu tầm được nó cho phép Off như trên. Nhưng chưa hiện thị nhập giá trị từ bàn phím và xử lý có khoảng cách @


Filename: 233798_dof.lsp
Tác giả: NguyenNgocSon
Bài viết gốc: 233865
Tên lệnh: cop
Lệnh offset đặc biệt

3 chỗ sai:

1). Nhầm: ent mà ghi là dt.

2). p1 và p2 phải ở trong hàm vlax-3d-point

3). p2 chỉ để lấy hướng copy là p1->p2 chứ không phải là khoảng cách để copy.

các ý 1,3 đã hiểu. Ý 2 chưa rõ lắm

Mình code thử lại

(defun C:cop()
 (vl-load-com)
 (setq str...
>>

3 chỗ sai:

1). Nhầm: ent mà ghi là dt.

2). p1 và p2 phải ở trong hàm vlax-3d-point

3). p2 chỉ để lấy hướng copy là p1->p2 chứ không phải là khoảng cách để copy.

các ý 1,3 đã hiểu. Ý 2 chưa rõ lắm

Mình code thử lại

(defun C:cop()
 (vl-load-com)
 (setq str (getstring  "\nNh\U+1EADp bi\U+1EC3u th\U+1EE9c gi\U+00E1 tr\U+1ECB Offet <10,2@30,50,...>: "))
   (setq ent   (car (entsel "n\chon block"))
	 p1    (cdr (assoc 10 (entget ent)))
   );Setq
 (setq lst (apply 'append (mapcar '(lambda(x) (HA:str->lst x "@")) (LM:str->lst str ","))))
  (foreach dis lst
   (setq newobj (vla-copy ent))
   (command ".copy" newobj "" p1 (polar p1 0 dis))
   (setq ent (entlast)));)
 (princ))

Nó báo lỗi nchon block; error: bad argument type: VLA-OBJECT <Entity name: 7ef95610>


<<

Filename: 233865_cop.lsp
Tác giả: NguyenNgocSon
Bài viết gốc: 233871
Tên lệnh: cop
Lệnh offset đặc biệt

Cám ơn sự góp ý của mọi người. Mình đã thử thấy ok. Đang cố thêm nốt cái đoạn chọn hướng copy nữa là ok :)

;=======================================================================
(defun C:cop()
 (vl-load-com)
 (setq str (getstring  "\n Nh\U+1EADp bi\U+1EC3u th\U+1EE9c gi\U+00E1 tr\U+1ECB Offet <10,2@30,50,...>: "))
   (setq ent   (car (entsel "n \chon block"))
	 p1    (cdr (assoc 10 (entget ent)))
  ...
>>

Cám ơn sự góp ý của mọi người. Mình đã thử thấy ok. Đang cố thêm nốt cái đoạn chọn hướng copy nữa là ok :)

;=======================================================================
(defun C:cop()
 (vl-load-com)
 (setq str (getstring  "\n Nh\U+1EADp bi\U+1EC3u th\U+1EE9c gi\U+00E1 tr\U+1ECB Offet <10,2@30,50,...>: "))
   (setq ent   (car (entsel "n \chon block"))
	 p1    (cdr (assoc 10 (entget ent)))
   );Setq
 (setq lst (apply 'append (mapcar '(lambda(x) (HA:str->lst x "@")) (LM:str->lst str ","))))
  (foreach dis lst
   (setq newobj (vla-copy (vlax-ename->vla-object ent)))
   (setq p2 (list (+ dis (car p1)) (cadr p1)))
   (vla-move newobj (vlax-3d-point p1) (vlax-3d-point p2))
   (setq ent (entlast)));)
 (princ))
;=======================================================================

<<

Filename: 233871_cop.lsp
Tác giả: gia_bach
Bài viết gốc: 235634
Tên lệnh: cla
Lisp chamber đường line và arc (cung tròn)

Bác Gia_bach dùng câu nhập liệu này thì chiều lòng được mọi khách hàng khó tính nhất:

 

Select first line or :

Phương châm của chúng tôi là "làm hài lòng mọi khách hàng khó tính nhất".

Nhưng không phải "bấm 10 like"...

>>

Bác Gia_bach dùng câu nhập liệu này thì chiều lòng được mọi khách hàng khó tính nhất:

 

Select first line or :

Phương châm của chúng tôi là "làm hài lòng mọi khách hàng khó tính nhất".

Nhưng không phải "bấm 10 like"  mà là "like 10 chai" :P !

 

viettien_03 : Cad không có lệnh chamber nào cả ??

Gửi bạn Lisp gần giống lệnh Chamfer :

(defun c:cla (/ data1 data2 dis e1 e2 lst_pt oo pts tmp);CLA ->ChamferLineArc
  ;; By : Gia_Bach 2013 ;;
  (defun SysVarReal(name msg / cd)
    (initget 4)
    (setq cd (getdist (strcat msg " <" (rtos (getvar name)) "> : ")) )
    (if cd (setvar name cd) (setq cd (getvar name)) )  )
  (defun SelectLineArc(msg / ent esel pt)
    (while (not (and (setq esel (entsel msg)
			   ent (car esel))
		     (if ent (wcmatch (cdr (assoc 0 (entget ent))) "LINE,ARC") ) ) )
      (princ "\nSelect Again: ")    )
    (setq pt (vlax-curve-getClosestPointTo ent (cadr esel)))
    (if (< (distance pt (vlax-curve-getStartPoint ent))
	   (distance pt (vlax-curve-getEndPoint ent)))
      (list (vlax-ename->vla-object ent) (vlax-curve-getStartPoint ent))
      (list (vlax-ename->vla-object ent) (vlax-curve-getEndPoint ent))))
  (defun list->3pair (old / new)
    (while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
		 old (cdddr old))) new )
  (defun mid (p1 p2)
    (list (* (+ (car p1) (car p2)) 0.5)
	  (* (+ (cadr p1) (cadr p2)) 0.5)
	  (* (+ (caddr p1) (caddr p2)) 0.5) ))
  (defun updateObj (obj inter dis / cen ang pt rad)
    (if (eq (vla-get-Objectname obj) "AcDbLine")
      (if (< (distance inter (vlax-curve-getStartPoint obj))
	     (distance inter (vlax-curve-getEndPoint obj)))
	(vla-put-StartPoint obj (vlax-3D-point (setq pt (polar inter (angle (vlax-curve-getStartPoint obj)(vlax-curve-getEndPoint obj))dis))))
	(vla-put-EndPoint obj (vlax-3D-point (setq pt(polar inter (angle (vlax-curve-getEndPoint obj)(vlax-curve-getStartPoint obj))dis))) ))
      (progn
	(setq cen (vlax-safearray->list (variant-value (vla-get-Center obj)))
	      rad (vla-get-Radius obj))
	(if (< (distance inter (vlax-curve-getStartPoint obj))
	     (distance inter (vlax-curve-getEndPoint obj)))
	  (vla-put-StartAngle obj (vlax-make-variant (setq ang (+ (angle cen inter) (* 2(asin (/ dis 2 rad)))))) )
	  (vla-put-EndAngle obj (vlax-make-variant (setq ang (- (angle cen inter) (* 2(asin (/ dis 2 rad)))))) ) )
	(setq pt (polar cen ang rad)) ) )
    pt)
  (defun asin (f_ang)
    (if (= (atof (rtos (abs f_ang))) 1)
      0
      (atan (/ f_ang (sqrt (+ (* (- f_ang) f_ang) 1))))    ))
  ;Main 
  (if
    (and
      (setq dis (SysVarReal "Chamfera" "\nKhoang cach Chamfer:"))
      (setq data1 (SelectLineArc "\n Chon d/tuong 1:"))
      (setq data2 (SelectLineArc "\n Chon d/tuong 2:")))
    (progn
	(setq e1 (car data1) e2 (car data2))
	(if (setq pts (vlax-invoke e1 'IntersectWith e2 acExtendBoth))
	  (progn
	    (setq lst_pt (append (list->3pair pts) lst_pt) tmp (mid (cadr data1) (cadr data2))
		  oo (car (vl-sort lst_pt '(lambda (x y) (< (distance tmp x) (distance tmp y))))))
	    (vla-addLine (vla-get-modelspace (vla-get-ActiveDocument(vlax-get-acad-object)))
	      (vlax-3D-point (updateObj e1 oo dis)) (vlax-3D-point (updateObj e2 oo dis))) )
	  (alert "Khong co giao diem") )  ) )
  (princ))

 

- Đầu tiên là rất cảm ơn bạn phamthanhbinh và bạn gia_bach đã nhiệt tình giúp đỡ, cái lisp này đúng là cái mình cần. Nhưng mình mới sủ dụng được lisp của gia_bach chứ của bạn phamthanhbinh thì load lên thì bị lỗi @@. Nhưng không sao lisp của gia_bach hoạt đống rất tốt.

- Thứ nữa bạn gia_bach có thẻ gia công sửa thêm chút thế này để sủ dụng cho tiện được không:

+ Hiện tại lisp hoạt động yêu cầu chọn lần lượt từng đối tường rồi nhập khoảng cách 

gia_bach có thể sửa lại 1 chút cho cách hoạt động giống lệnh gốc (chamber) được không, minh đang quen nhập khoảng cách d trước rồi cứ thế chọn đối tượng rồi kết thúc lệnh.

- Dù có sửa được hay không đi nữa mình rất cảm ơn gia_bach 

 

<<

Filename: 235634_cla.lsp
Tác giả: duy782006
Bài viết gốc: 235640
Tên lệnh: vhcn
Lisp vẽ hình chữ nhật

Các bác cũng đã làm lisp mới rồi. Nhưng mình cũng sửa phát cho nó vui.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Tao moi rectang
;;;Cu phap su dung (duy:t_rectang toadoa toadob kieu tile Layer Color)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:t_rectang (diema diemb dorong tl stl La Co)


(setq toado (list diema (list (car diema) (cadr...
>>

Các bác cũng đã làm lisp mới rồi. Nhưng mình cũng sửa phát cho nó vui.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Tao moi rectang
;;;Cu phap su dung (duy:t_rectang toadoa toadob kieu tile Layer Color)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:t_rectang (diema diemb dorong tl stl La Co)


(setq toado (list diema (list (car diema) (cadr diemb)) diemb (list (car diemb) (cadr diema)) ))

(cond ((= la "") (setq la (getvar "Clayer")) ))
(cond ((= co "") (setq co 256) ))
(cond ((= tl "") (setq tl "bylayer") ))
(cond ((= stl "") (setq stl 1) ))


(setq Lst
  (list
   (cons 0 "LWPOLYLINE")
   (cons 100 "AcDbEntity")
   (cons 8 la)
   (cons 6 tl)
   (cons 48 stl)
   (cons 62 co)
   (cons 100 "AcDbPolyline")
   (cons 43 dorong)
   (cons 90 4)
   (cons 70 1)))
(setq x 0)
(repeat 4
  (setq Lst (append Lst (list (cons 10 (nth x toado)) )))
  (setq x (1+ x)))
(entmakex Lst)
(princ)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Xac dinh diem duoi trai va tren phai tu hai diem a va b
;;;Cu phap su dung (duy:xd_dttp<diemdiem diema diemb )
;;;Gia tri tra ve la list diem duoi ben trai va diem tren ben phai
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:xd_dttp<diemdiem (a b / a b xtr xph ytr ydu trd ptr lkq)
(setq luubatdiem (getvar "osmode"))
(setvar "osmode" 0)
(setq xtr (min (car a) (car b)))
(setq xph (max (car a) (car b)))
(setq ytr (max (cadr a) (cadr b)))
(setq ydu (min (cadr a) (cadr b)))
(setq trd (list xtr ydu))
(setq ptr (list xph ytr))
(setq lkq (list trd ptr))
(setvar "osmode" luubatdiem)
lkq)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Xac dinh gia tri so neu chua co thi gan cho gia tri mac dinh
;;;Cu phap su dung (duy:xd_gts gtn gtmd mdich)
;;;Gia tri tra ve la so gtn
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:xd_gts (gtn gtmd mdich / gtn gtmd mdich)
(or gtn (setq gtn gtmd))
(setq gtn (cond ((getreal (strcat "\n" mdich " < " (rtos gtn 2 2) " >:")))(gtn)))
gtn)



(defun c:vhcn (/ diemm diemh diema diemb)
(setq diemm (getpoint "\nDiem thu nhat:"))
(setq diemh (getpoint "\nDiem thu hai:"))
(setq trao (duy:xd_dttp<diemdiem diemm diemh))
(setq diemm (car trao))
(setq diemh (cadr trao))
(setq khoang (duy:xd_gts khoang 110 "Khoang cach offset: "))
(setq diema (polar diemm pi khoang))
(setq diema (polar diema (/ (* pi 3) 2) khoang))
(setq diemb (polar diemh (* 2 pi) khoang))
(setq diemb (polar diemb (/ pi 2) khoang))
(duy:t_rectang diema diemb 0 "" "" "" "")
(princ))

 

Mình dùng biện pháp củ chuối là làm 1 hàm cứ nhập vào 2 điểm kiểu gì thì kiểu nó cũng ném lại cho hai điểm theo thứ tự điểm dưới bên trái và điểm trên bên phải he he.


<<

Filename: 235640_vhcn.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 235767
Tên lệnh: ha
lisp vẽ mặt bằng kết cấu

Kết thúc lisp này ở đây, vì quá khó, quá mất công, và còn dành thời gian kiếm cơm nữa!

File cad để test:

http://www.cadviet.com/upfiles/3/67029_test2.dwg

File hình để rửa mắt:

>>

Kết thúc lisp này ở đây, vì quá khó, quá mất công, và còn dành thời gian kiếm cơm nữa!

File cad để test:

http://www.cadviet.com/upfiles/3/67029_test2.dwg

File hình để rửa mắt:

67029_untitled_10.png

File lisp trần ai:

 

;Doan Van Ha - CADViet.com - Ngay 22/05/2013
;Chuc nang: ve luoi dam/tuong theo he truc // XOY, be rong tuy chon, luoi break bat ky nhung o ngoai cung phai la HCN.
(defun C:HA(/ ss lsti lst lstg1 giao lstg kcm ptx pty ent)
 (vl-load-com) (command "undo" "be")
 (setq cmd (getvar "cmdecho") osm (getvar "osmode") hpb (getvar "hpbound")) (setvar "cmdecho" 0) (setvar "osmode" 0) (setvar "hpbound" 1)
 (while
  (and
   (princ "\nChon cac Line duong truc...")
   (setq ss (ssget '((0 . "LINE"))))
   (setq lsti (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
   (or kc (setq kc 110))
   (setq kc (cond ((getdist (strcat "\nBe rong tuong/dam <" (rtos kc 2 2) ">:"))) (kc))))
  (setq lst (append (mapcar '(lambda(ent) (list ent kc)) lsti) lst)))
 (foreach n1 lst
  (setq lstg1 nil)
  (foreach n2 lst
   (if (setq giao (car (HA:Giao (vlax-ename->vla-object (car n1)) (vlax-ename->vla-object (car n2)) acExtendNone)))
    (setq lstg1 (cons giao lstg1))))
  (if lstg1 (setq lstg (append lstg1 lstg))))
 (setq lstg (LM:UniqueFuzz (vl-sort lstg '(lambda(p q) (if (equal (car p) (car q) 1E-8) (< (cadr p) (cadr q)) (< (car p) (car q))))) 1E-8))
 (HA:hcn (car lstg) (last lstg) 0)
 (HA:OffsetInOut (entlast) lst "N")
 (setq kcm (* 0.9 (HA:DisMinMax lstg "min")))
 (setq ss (ssadd) ptx (polar (car lstg) 0 kcm))
 (while (< (car ptx) (car (last lstg)))
  (setq pty (polar ptx (/ pi 2) kcm))
  (while (< (cadr pty) (cadr (last lstg)))
   (setq ent (entlast))
   (command "boundary" pty "")
   (if (setq ent (entnext ent)) (setq ss (ssadd ent ss)))
   (setq pty (polar pty (/ pi 2) kcm)))
  (setq ptx (polar ptx 0 kcm)))
 (load "overkillsup.lsp") (acet-overkill2 (list ss 1E-8 nil "N" "N" "N"))
 (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "w" (car lstg) (last lstg) '((0 . "LWPOLYLINE"))))))
  (HA:OffsetInOut ent lst "T"))
 (acet-overkill2 (list (ssget "w" (car lstg) (last lstg) '((0 . "LWPOLYLINE"))) 1E-8 nil "N" "N" "N"))
 (setvar "cmdecho" cmd) (setvar "hpbound" hpb) (command "undo" "e") (princ) lst)
;----- Check xem 2 lines ent1 vµ ent2 n»m trªn cïng ®­êng th¼ng kh«ng?
(defun HA:2LineCollinear-p(ent1 ent2)
 (setq p1 (vlax-curve-getStartPoint ent1) p2 (vlax-curve-getEndPoint ent1)
       q1 (vlax-curve-getStartPoint ent2) q2 (vlax-curve-getEndPoint ent2))
 (and
  ((lambda(a b c) (or (equal (+ a b) c 1e-8) (equal (+ b c) a 1e-8) (equal (+ c a) b 1e-8))) (distance p1 p2) (distance p2 q1) (distance q1 p1))
  ((lambda(a b c) (or (equal (+ a b) c 1e-8) (equal (+ b c) a 1e-8) (equal (+ c a) b 1e-8))) (distance p1 p2) (distance p2 q2) (distance q2 p1))))
;----- Check xem ®iÓm p co n»m trong/ngoµi obj kin hay kh«ng?
(defun HA:PointInOut (p obj flag / flag1 obj1 obj2 lon nho)
 (setq obj1 (car (vlax-invoke obj 'Offset 1E-3))
       obj2 (car (vlax-invoke obj 'Offset -1E-3)))
 (if (> (vla-get-area obj1)(vla-get-area obj2))
  (setq lon obj1 nho obj2)
  (setq lon obj2 nho obj1))
 (if (> (distance p (vlax-curve-getClosestPointTo lon p))(distance p (vlax-curve-getClosestPointTo nho p)))
  (if (= flag "T")
   (setq flag1 T)))
 (mapcar 'vla-delete (list lon nho))
 flag1)
;----- Offset ent vµo bªn trong polygon, víi dis mçi c¹nh kh¸c nhau.
(defun HA:OffsetInOut(ent lstx flag / obj0 obj obj1 obj2 i mid objc objl lst lst1 lst2 lst3 lst4)
 (setq obj0 (vlax-ename->vla-object ent))
 (setq lst (mapcar 'cdr (vl-remove-if-not '(lambda(x) (= (car x) 10)) (entget ent))))
 (setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "cp" lst '((0 . "LINE")))))))
 (setq lst1 (append lst lst))
 (setq i 0)
 (repeat (length lst)
  (setq obj (vlax-ename->vla-object (setq ent1 (entmakex (list (cons 0 "LINE") (cons 10 (nth i lst1)) (cons 11 (nth (1+ i) lst1)))))))
  (foreach ent2 entlst
   (if (HA:2LineCollinear-p ent1 ent2) (setq entL ent2)))
  (foreach ent lstx
   (if (equal entL (car ent)) (setq kcx (cadr ent))))
  (setq obj1 (car (vlax-invoke obj 'Offset (/ kcx 2))) obj2 (car (vlax-invoke obj 'Offset (/ kcx -2))))
  (setq mid (mapcar '(lambda(x y) (/ (+ x y) 2)) (vlax-curve-getStartPoint obj1) (vlax-curve-getEndPoint obj1)))
  (if (HA:PointInOut mid obj0 flag)
   (setq objc obj1 objl obj2)
   (setq objc obj2 objl obj1))
  (setq lst2 (cons objc lst2))
  (mapcar 'vla-delete (list objl obj))
  (setq i (1+ i)))
 (setq lst3 (append lst2 lst2))
 (setq i 0)
 (repeat (length lst2)
  (if (setq giao (HA:Giao (nth i lst3) (nth (1+ i) lst3) acExtendBoth))
   (setq lst4 (cons (car giao) lst4)))
  (setq i (1+ i)))
 (LWPoly lst4 1)
 (mapcar 'vla-delete (cons obj0 lst2)))
(defun LWPoly(lst cls)
 (entmakex (append (list 
    (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst)) (cons 70 cls)) (mapcar (function (lambda (p) (cons 10 p))) lst))))
(defun HA:Giao(obj1 obj2 mode / l r)
 (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
 (repeat (/ (length l) 3)
  (setq r (cons (list (car l) (cadr l) (caddr l)) r) l (cdddr l)))
 r)
(defun HA:hcn(p1 p3 kc / p1x p3x)
 (setq p1x (list (+ (min (car p1) (car p3)) kc) (+ (min (cadr p1) (cadr p3)) kc))
       p3x (list (- (max (car p1) (car p3)) kc) (- (max (cadr p1) (cadr p3)) kc)))
 (command "rectang" p1x p3x))
(defun LM:UniqueFuzz(l fz)
 (if l 
  (cons (car l) (LM:UniqueFuzz (vl-remove-if '(lambda(x) (equal x (car l) fz)) (cdr l)) fz))))
(defun HA:DisMinMax(lst func / ghan)
 (if (= (strcase func) "MIN") (setq func min ghan 1E15) (setq func max ghan -1E15))
 (apply 'func (apply 'append (mapcar '(lambda(p) (mapcar '(lambda(q) (if (equal p q 1E-8) ghan (distance p q))) lst)) lst))))

<<

Filename: 235767_ha.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 235806
Tên lệnh: ha
[yêu cầu &thảo luận] lisp vẽ mặt bằng kết cấu

cái này là cái đánh dấu, khá hay. ý em là nếu mình đã lỡ chọn trục nhập kích thước 220 rồi chẳng hạn. mà về sau chọn này trục này nhập 150 thì nó vẫn theo cái bề rông ban đầu, ý em muốn là nó theo cái bề rông sau cùng mà mình chọn ấy. :D:D, như thế hay hơn. he he

Sửa tất tần tật các yêu...

>>

cái này là cái đánh dấu, khá hay. ý em là nếu mình đã lỡ chọn trục nhập kích thước 220 rồi chẳng hạn. mà về sau chọn này trục này nhập 150 thì nó vẫn theo cái bề rông ban đầu, ý em muốn là nó theo cái bề rông sau cùng mà mình chọn ấy. :D:D, như thế hay hơn. he he

Sửa tất tần tật các yêu cầu cho bạn đây!

 

;Doan Van Ha - CADViet.com - Ngay 22/05/2013
;Chuc nang: ve luoi dam/tuong theo he truc // XOY, be rong tuy chon, luoi break bat ky nhung o ngoai cung phai la HCN.
(defun C:HA(/ ss lsti lst lstg1 giao lstg kcm ptx pty ent)
 (vl-load-com) (command "undo" "be") (redraw)
 (setq cmd (getvar "cmdecho") osm (getvar "osmode") hpb (getvar "hpbound")) (setvar "cmdecho" 0) (setvar "osmode" 0) (setvar "hpbound" 1)
 (while
  (and
   (princ "\nChon cac Line duong truc...")
   (setq ss (ssget '((0 . "LINE"))))
   (setq lsti (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
   (or kc (setq kc 110))
   (setq kc (cond ((getdist (strcat "\nBe rong tuong/dam <" (rtos kc 2 2) ">:"))) (kc)))
   (mapcar '(lambda(ent) (grdraw (vlax-curve-getStartPoint ent) (vlax-curve-getEndPoint ent) 2)) lsti))
  (setq lst (reverse (append (mapcar '(lambda(ent) (list ent kc)) lsti) lst))))
 (foreach n1 lst
  (setq lstg1 nil)
  (foreach n2 lst
   (if (setq giao (car (HA:Giao (vlax-ename->vla-object (car n1)) (vlax-ename->vla-object (car n2)) acExtendNone)))
    (setq lstg1 (cons giao lstg1))))
  (if lstg1 (setq lstg (append lstg1 lstg))))
 (setq lstg (LM:UniqueFuzz (vl-sort lstg '(lambda(p q) (if (equal (car p) (car q) 1E-8) (< (cadr p) (cadr q)) (< (car p) (car q))))) 1E-8))
 (HA:hcn (car lstg) (last lstg) 0)
 (HA:OffsetInOut (entlast) lst "N")
 (setq kcm (* 0.9 (HA:DisMinMax lstg "min")))
 (setq ss (ssadd) ptx (polar (car lstg) 0 kcm))
 (while (< (car ptx) (car (last lstg)))
  (setq pty (polar ptx (/ pi 2) kcm))
  (while (< (cadr pty) (cadr (last lstg)))
   (setq ent (entlast))
   (command "boundary" pty "")
   (if (setq ent (entnext ent)) (setq ss (ssadd ent ss)))
   (setq pty (polar pty (/ pi 2) kcm)))
  (setq ptx (polar ptx 0 kcm)))
 (load "overkillsup.lsp") (acet-overkill2 (list ss 1E-8 nil "N" "N" "N"))
 (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "w" (car lstg) (last lstg) '((0 . "LWPOLYLINE"))))))
  (HA:OffsetInOut ent lst "T"))
 (acet-overkill2 (list (ssget "w" (car lstg) (last lstg) '((0 . "LWPOLYLINE"))) 1E-8 nil "N" "N" "N"))
 (setvar "cmdecho" cmd) (setvar "hpbound" hpb) (command "undo" "e") (redraw) (princ) lst)
;----- Check xem 2 lines ent1 vµ ent2 n»m trªn cïng ®­êng th¼ng kh«ng?
(defun HA:2LineCollinear-p(ent1 ent2)
 (setq p1 (vlax-curve-getStartPoint ent1) p2 (vlax-curve-getEndPoint ent1)
       q1 (vlax-curve-getStartPoint ent2) q2 (vlax-curve-getEndPoint ent2))
 (and
  ((lambda(a b c) (or (equal (+ a b) c 1e-8) (equal (+ b c) a 1e-8) (equal (+ c a) b 1e-8))) (distance p1 p2) (distance p2 q1) (distance q1 p1))
  ((lambda(a b c) (or (equal (+ a b) c 1e-8) (equal (+ b c) a 1e-8) (equal (+ c a) b 1e-8))) (distance p1 p2) (distance p2 q2) (distance q2 p1))))
;----- Check xem ®iÓm p co n»m trong/ngoµi obj kin hay kh«ng?
(defun HA:PointInOut (p obj flag / flag1 obj1 obj2 lon nho)
 (setq obj1 (car (vlax-invoke obj 'Offset 1E-3))
       obj2 (car (vlax-invoke obj 'Offset -1E-3)))
 (if (> (vla-get-area obj1)(vla-get-area obj2))
  (setq lon obj1 nho obj2)
  (setq lon obj2 nho obj1))
 (if (> (distance p (vlax-curve-getClosestPointTo lon p))(distance p (vlax-curve-getClosestPointTo nho p)))
  (if (= flag "T")
   (setq flag1 T)))
 (mapcar 'vla-delete (list lon nho))
 flag1)
;----- Offset ent vµo bªn trong polygon, víi dis mçi c¹nh kh¸c nhau.
(defun HA:OffsetInOut(ent lstx flag / obj0 obj obj1 obj2 i mid objc objl lst lst1 lst2 lst3 lst4)
 (setq obj0 (vlax-ename->vla-object ent))
 (setq lst (mapcar 'cdr (vl-remove-if-not '(lambda(x) (= (car x) 10)) (entget ent))))
 (setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "cp" lst '((0 . "LINE")))))))
 (setq lst1 (append lst lst))
 (setq i 0)
 (repeat (length lst)
  (setq obj (vlax-ename->vla-object (setq ent1 (entmakex (list (cons 0 "LINE") (cons 10 (nth i lst1)) (cons 11 (nth (1+ i) lst1)))))))
  (foreach ent2 entlst
   (if (HA:2LineCollinear-p ent1 ent2) (setq entL ent2)))
  (foreach ent lstx
   (if (equal entL (car ent)) (setq kcx (cadr ent))))
  (setq obj1 (car (vlax-invoke obj 'Offset (/ kcx 2))) obj2 (car (vlax-invoke obj 'Offset (/ kcx -2))))
  (setq mid (mapcar '(lambda(x y) (/ (+ x y) 2)) (vlax-curve-getStartPoint obj1) (vlax-curve-getEndPoint obj1)))
  (if (HA:PointInOut mid obj0 flag)
   (setq objc obj1 objl obj2)
   (setq objc obj2 objl obj1))
  (setq lst2 (cons objc lst2))
  (mapcar 'vla-delete (list objl obj))
  (setq i (1+ i)))
 (setq lst3 (append lst2 lst2))
 (setq i 0)
 (repeat (length lst2)
  (if (setq giao (HA:Giao (nth i lst3) (nth (1+ i) lst3) acExtendBoth))
   (setq lst4 (cons (car giao) lst4)))
  (setq i (1+ i)))
 (LWPoly lst4 1)
 (mapcar 'vla-delete (cons obj0 lst2)))
(defun LWPoly(lst cls)
 (entmakex (append (list 
    (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst)) (cons 70 cls)) (mapcar (function (lambda (p) (cons 10 p))) lst))))
(defun HA:Giao(obj1 obj2 mode / l r)
 (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
 (repeat (/ (length l) 3)
  (setq r (cons (list (car l) (cadr l) (caddr l)) r) l (cdddr l)))
 r)
(defun HA:hcn(p1 p3 kc / p1x p3x)
 (setq p1x (list (+ (min (car p1) (car p3)) kc) (+ (min (cadr p1) (cadr p3)) kc))
       p3x (list (- (max (car p1) (car p3)) kc) (- (max (cadr p1) (cadr p3)) kc)))
 (command "rectang" p1x p3x))
(defun LM:UniqueFuzz(l fz)
 (if l 
  (cons (car l) (LM:UniqueFuzz (vl-remove-if '(lambda(x) (equal x (car l) fz)) (cdr l)) fz))))
(defun HA:DisMinMax(lst func / ghan)
 (if (= (strcase func) "MIN") (setq func min ghan 1E15) (setq func max ghan -1E15))
 (apply 'func (apply 'append (mapcar '(lambda(p) (mapcar '(lambda(q) (if (equal p q 1E-8) ghan (distance p q))) lst)) lst))))

<<

Filename: 235806_ha.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 235820
Tên lệnh: ha
lisp vẽ mặt bằng kết cấu

1). Bổ sung đãng trí quên reverse osnap.

2). Bỏ mấy dòng đãng trí in ra trên screen.

3). Bổ sung xanh đỏ tím vàng lục lam cam chàm tím cho mỗi lần chọn theo y/c của bạn Tien05.

 

;Doan Van Ha - CADViet.com - Ngay 23/05/2013
;Chuc nang: ve luoi dam/tuong theo he truc // XOY, be rong tuy chon, luoi break bat ky nhung o ngoai cung phai la HCN.
(defun C:HA(/ ss lsti lst lstg1 giao lstg kcm ptx pty...
>>

1). Bổ sung đãng trí quên reverse osnap.

2). Bỏ mấy dòng đãng trí in ra trên screen.

3). Bổ sung xanh đỏ tím vàng lục lam cam chàm tím cho mỗi lần chọn theo y/c của bạn Tien05.

 

;Doan Van Ha - CADViet.com - Ngay 23/05/2013
;Chuc nang: ve luoi dam/tuong theo he truc // XOY, be rong tuy chon, luoi break bat ky nhung o ngoai cung phai la HCN.
(defun C:HA(/ ss lsti lst lstg1 giao lstg kcm ptx pty ent col)
 (vl-load-com) (command "undo" "be") (redraw)
 (setq cmd (getvar "cmdecho") osm (getvar "osmode") hpb (getvar "hpbound")) (setvar "cmdecho" 0) (setvar "osmode" 0) (setvar "hpbound" 1)
 (setq col 1)
 (while
  (and
   (princ "\nChon cac Line duong truc...")
   (setq ss (ssget '((0 . "LINE"))))
   (setq lsti (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
   (or kc (setq kc 110))
   (setq kc (cond ((getdist (strcat "\nBe rong tuong/dam <" (rtos kc 2 2) ">:"))) (kc))))
  (mapcar '(lambda(ent) (grdraw (vlax-curve-getStartPoint ent) (vlax-curve-getEndPoint ent) col)) lsti)
  (setq col (1+ col))
  (setq lst (reverse (append (mapcar '(lambda(ent) (list ent kc)) lsti) lst))))
 (foreach n1 lst
  (setq lstg1 nil)
  (foreach n2 lst
   (if (setq giao (car (HA:Giao (vlax-ename->vla-object (car n1)) (vlax-ename->vla-object (car n2)) acExtendNone)))
    (setq lstg1 (cons giao lstg1))))
  (if lstg1 (setq lstg (append lstg1 lstg))))
 (setq lstg (LM:UniqueFuzz (vl-sort lstg '(lambda(p q) (if (equal (car p) (car q) 1E-8) (< (cadr p) (cadr q)) (< (car p) (car q))))) 1E-8))
 (HA:hcn (car lstg) (last lstg) 0)
 (HA:OffsetInOut (entlast) lst "N")
 (setq kcm (* 0.9 (HA:DisMinMax lstg "min")))
 (setq ss (ssadd) ptx (polar (car lstg) 0 kcm))
 (while (< (car ptx) (car (last lstg)))
  (setq pty (polar ptx (/ pi 2) kcm))
  (while (< (cadr pty) (cadr (last lstg)))
   (setq ent (entlast))
   (command "boundary" pty "")
   (if (setq ent (entnext ent)) (setq ss (ssadd ent ss)))
   (setq pty (polar pty (/ pi 2) kcm)))
  (setq ptx (polar ptx 0 kcm)))
 (load "overkillsup.lsp") (acet-overkill2 (list ss 1E-8 nil "N" "N" "N"))
 (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "w" (car lstg) (last lstg) '((0 . "LWPOLYLINE"))))))
  (HA:OffsetInOut ent lst "T"))
 (acet-overkill2 (list (ssget "w" (car lstg) (last lstg) '((0 . "LWPOLYLINE"))) 1E-8 nil "N" "N" "N"))
 (setvar "cmdecho" cmd) (setvar "hpbound" hpb) (setvar "osmode" osm) (command "undo" "e") (redraw) (princ))
;----- Check xem 2 lines ent1 vµ ent2 n»m trªn cïng ®­êng th¼ng kh«ng?
(defun HA:2LineCollinear-p(ent1 ent2)
 (setq p1 (vlax-curve-getStartPoint ent1) p2 (vlax-curve-getEndPoint ent1)
       q1 (vlax-curve-getStartPoint ent2) q2 (vlax-curve-getEndPoint ent2))
 (and
  ((lambda(a b c) (or (equal (+ a b) c 1e-8) (equal (+ b c) a 1e-8) (equal (+ c a) b 1e-8))) (distance p1 p2) (distance p2 q1) (distance q1 p1))
  ((lambda(a b c) (or (equal (+ a b) c 1e-8) (equal (+ b c) a 1e-8) (equal (+ c a) b 1e-8))) (distance p1 p2) (distance p2 q2) (distance q2 p1))))
;----- Check xem ®iÓm p co n»m trong/ngoµi obj kin hay kh«ng?
(defun HA:PointInOut (p obj flag / flag1 obj1 obj2 lon nho)
 (setq obj1 (car (vlax-invoke obj 'Offset 1E-3))
       obj2 (car (vlax-invoke obj 'Offset -1E-3)))
 (if (> (vla-get-area obj1)(vla-get-area obj2))
  (setq lon obj1 nho obj2)
  (setq lon obj2 nho obj1))
 (if (> (distance p (vlax-curve-getClosestPointTo lon p))(distance p (vlax-curve-getClosestPointTo nho p)))
  (if (= flag "T")
   (setq flag1 T)))
 (mapcar 'vla-delete (list lon nho))
 flag1)
;----- Offset ent vµo bªn trong polygon, víi dis mçi c¹nh kh¸c nhau.
(defun HA:OffsetInOut(ent lstx flag / obj0 obj obj1 obj2 i mid objc objl lst lst1 lst2 lst3 lst4)
 (setq obj0 (vlax-ename->vla-object ent))
 (setq lst (mapcar 'cdr (vl-remove-if-not '(lambda(x) (= (car x) 10)) (entget ent))))
 (setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "cp" lst '((0 . "LINE")))))))
 (setq lst1 (append lst lst))
 (setq i 0)
 (repeat (length lst)
  (setq obj (vlax-ename->vla-object (setq ent1 (entmakex (list (cons 0 "LINE") (cons 10 (nth i lst1)) (cons 11 (nth (1+ i) lst1)))))))
  (foreach ent2 entlst
   (if (HA:2LineCollinear-p ent1 ent2) (setq entL ent2)))
  (foreach ent lstx
   (if (equal entL (car ent)) (setq kcx (cadr ent))))
  (setq obj1 (car (vlax-invoke obj 'Offset (/ kcx 2))) obj2 (car (vlax-invoke obj 'Offset (/ kcx -2))))
  (setq mid (mapcar '(lambda(x y) (/ (+ x y) 2)) (vlax-curve-getStartPoint obj1) (vlax-curve-getEndPoint obj1)))
  (if (HA:PointInOut mid obj0 flag)
   (setq objc obj1 objl obj2)
   (setq objc obj2 objl obj1))
  (setq lst2 (cons objc lst2))
  (mapcar 'vla-delete (list objl obj))
  (setq i (1+ i)))
 (setq lst3 (append lst2 lst2))
 (setq i 0)
 (repeat (length lst2)
  (if (setq giao (HA:Giao (nth i lst3) (nth (1+ i) lst3) acExtendBoth))
   (setq lst4 (cons (car giao) lst4)))
  (setq i (1+ i)))
 (LWPoly lst4 1)
 (mapcar 'vla-delete (cons obj0 lst2)))
(defun LWPoly(lst cls)
 (entmakex (append (list 
    (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst)) (cons 70 cls)) (mapcar (function (lambda (p) (cons 10 p))) lst))))
(defun HA:Giao(obj1 obj2 mode / l r)
 (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
 (repeat (/ (length l) 3)
  (setq r (cons (list (car l) (cadr l) (caddr l)) r) l (cdddr l)))
 r)
(defun HA:hcn(p1 p3 kc / p1x p3x)
 (setq p1x (list (+ (min (car p1) (car p3)) kc) (+ (min (cadr p1) (cadr p3)) kc))
       p3x (list (- (max (car p1) (car p3)) kc) (- (max (cadr p1) (cadr p3)) kc)))
 (command "rectang" p1x p3x))
(defun LM:UniqueFuzz(l fz)
 (if l 
  (cons (car l) (LM:UniqueFuzz (vl-remove-if '(lambda(x) (equal x (car l) fz)) (cdr l)) fz))))
(defun HA:DisMinMax(lst func / ghan) ;real_max: 9.7E307
 (if (= (strcase func) "MIN") (setq func min ghan 1E15) (setq func max ghan -1E15))
 (apply 'func (apply 'append (mapcar '(lambda(p) (mapcar '(lambda(q) (if (equal p q 1E-8) ghan (distance p q))) lst)) lst))))

<<

Filename: 235820_ha.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 235827
Tên lệnh: ha
lisp vẽ mặt bằng kết cấu

1). Bổ sung đãng trí quên reverse osnap.

2). Bỏ mấy dòng đãng trí in ra trên screen.

3). Bổ...

>>

1). Bổ sung đãng trí quên reverse osnap.

2). Bỏ mấy dòng đãng trí in ra trên screen.

3). Bổ sung chọn lần sau thay lần trước.

4). Bổ sung xanh đỏ tím vàng lục lam cam chàm tím cho mỗi lần chọn theo y/c của bạn Tien05.

 

;Doan Van Ha - CADViet.com - Ngay 23/05/2013
;Chuc nang: ve luoi dam/tuong theo he truc // XOY, be rong tuy chon, luoi break bat ky nhung o ngoai cung phai la HCN.
(defun C:HA(/ ss lsti lst lstg1 giao lstg kcm ptx pty ent col)
 (vl-load-com) (command "undo" "be") (redraw)
 (setq cmd (getvar "cmdecho") osm (getvar "osmode") hpb (getvar "hpbound")) (setvar "cmdecho" 0) (setvar "osmode" 0) (setvar "hpbound" 1)
 (setq col 1)
 (while
  (and
   (princ "\nChon cac Line duong truc...")
   (setq ss (ssget '((0 . "LINE"))))
   (setq lsti (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
   (or kc (setq kc 110))
   (setq kc (cond ((getdist (strcat "\nBe rong tuong/dam <" (rtos kc 2 2) ">:"))) (kc))))
  (mapcar '(lambda(ent) (grdraw (vlax-curve-getStartPoint ent) (vlax-curve-getEndPoint ent) col)) lsti)
  (setq lst (append (mapcar '(lambda(ent) (list ent kc)) lsti) lst))
  (setq col (1+ col)))
 (setq lst (reverse lst))
 (foreach n1 lst
  (setq lstg1 nil)
  (foreach n2 lst
   (if (setq giao (car (HA:Giao (vlax-ename->vla-object (car n1)) (vlax-ename->vla-object (car n2)) acExtendNone)))
    (setq lstg1 (cons giao lstg1))))
  (if lstg1 (setq lstg (append lstg1 lstg))))
 (setq lstg (LM:UniqueFuzz (vl-sort lstg '(lambda(p q) (if (equal (car p) (car q) 1E-8) (< (cadr p) (cadr q)) (< (car p) (car q))))) 1E-8))
 (HA:hcn (car lstg) (last lstg) 0)
 (HA:OffsetInOut (entlast) lst "N")
 (setq kcm (* 0.9 (HA:DisMinMax lstg "min")))
 (setq ss (ssadd) ptx (polar (car lstg) 0 kcm))
 (while (< (car ptx) (car (last lstg)))
  (setq pty (polar ptx (/ pi 2) kcm))
  (while (< (cadr pty) (cadr (last lstg)))
   (setq ent (entlast))
   (command "boundary" pty "")
   (if (setq ent (entnext ent)) (setq ss (ssadd ent ss)))
   (setq pty (polar pty (/ pi 2) kcm)))
  (setq ptx (polar ptx 0 kcm)))
 (load "overkillsup.lsp") (acet-overkill2 (list ss 1E-8 nil "N" "N" "N"))
 (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "w" (car lstg) (last lstg) '((0 . "LWPOLYLINE"))))))
  (HA:OffsetInOut ent lst "T"))
 (acet-overkill2 (list (ssget "w" (car lstg) (last lstg) '((0 . "LWPOLYLINE"))) 1E-8 nil "N" "N" "N"))
 (setvar "cmdecho" cmd) (setvar "hpbound" hpb) (setvar "osmode" osm) (command "undo" "e") (redraw) (princ))
;----- Check xem 2 lines ent1 vµ ent2 n»m trªn cïng ®­êng th¼ng kh«ng?
(defun HA:2LineCollinear-p(ent1 ent2)
 (setq p1 (vlax-curve-getStartPoint ent1) p2 (vlax-curve-getEndPoint ent1)
       q1 (vlax-curve-getStartPoint ent2) q2 (vlax-curve-getEndPoint ent2))
 (and
  ((lambda(a b c) (or (equal (+ a b) c 1e-8) (equal (+ b c) a 1e-8) (equal (+ c a) b 1e-8))) (distance p1 p2) (distance p2 q1) (distance q1 p1))
  ((lambda(a b c) (or (equal (+ a b) c 1e-8) (equal (+ b c) a 1e-8) (equal (+ c a) b 1e-8))) (distance p1 p2) (distance p2 q2) (distance q2 p1))))
;----- Check xem ®iÓm p co n»m trong/ngoµi obj kin hay kh«ng?
(defun HA:PointInOut (p obj flag / flag1 obj1 obj2 lon nho)
 (setq obj1 (car (vlax-invoke obj 'Offset 1E-3))
       obj2 (car (vlax-invoke obj 'Offset -1E-3)))
 (if (> (vla-get-area obj1)(vla-get-area obj2))
  (setq lon obj1 nho obj2)
  (setq lon obj2 nho obj1))
 (if (> (distance p (vlax-curve-getClosestPointTo lon p))(distance p (vlax-curve-getClosestPointTo nho p)))
  (if (= flag "T")
   (setq flag1 T)))
 (mapcar 'vla-delete (list lon nho))
 flag1)
;----- Offset ent vµo bªn trong polygon, víi dis mçi c¹nh kh¸c nhau.
(defun HA:OffsetInOut(ent lstx flag / obj0 obj obj1 obj2 i mid objc objl lst lst1 lst2 lst3 lst4)
 (setq obj0 (vlax-ename->vla-object ent))
 (setq lst (mapcar 'cdr (vl-remove-if-not '(lambda(x) (= (car x) 10)) (entget ent))))
 (setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "cp" lst '((0 . "LINE")))))))
 (setq lst1 (append lst lst))
 (setq i 0)
 (repeat (length lst)
  (setq obj (vlax-ename->vla-object (setq ent1 (entmakex (list (cons 0 "LINE") (cons 10 (nth i lst1)) (cons 11 (nth (1+ i) lst1)))))))
  (foreach ent2 entlst
   (if (HA:2LineCollinear-p ent1 ent2) (setq entL ent2)))
  (foreach ent lstx
   (if (equal entL (car ent)) (setq kcx (cadr ent))))
  (setq obj1 (car (vlax-invoke obj 'Offset (/ kcx 2))) obj2 (car (vlax-invoke obj 'Offset (/ kcx -2))))
  (setq mid (mapcar '(lambda(x y) (/ (+ x y) 2)) (vlax-curve-getStartPoint obj1) (vlax-curve-getEndPoint obj1)))
  (if (HA:PointInOut mid obj0 flag)
   (setq objc obj1 objl obj2)
   (setq objc obj2 objl obj1))
  (setq lst2 (cons objc lst2))
  (mapcar 'vla-delete (list objl obj))
  (setq i (1+ i)))
 (setq lst3 (append lst2 lst2))
 (setq i 0)
 (repeat (length lst2)
  (if (setq giao (HA:Giao (nth i lst3) (nth (1+ i) lst3) acExtendBoth))
   (setq lst4 (cons (car giao) lst4)))
  (setq i (1+ i)))
 (LWPoly lst4 1)
 (mapcar 'vla-delete (cons obj0 lst2)))
(defun LWPoly(lst cls)
 (entmakex (append (list 
    (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst)) (cons 70 cls)) (mapcar (function (lambda (p) (cons 10 p))) lst))))
(defun HA:Giao(obj1 obj2 mode / l r)
 (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
 (repeat (/ (length l) 3)
  (setq r (cons (list (car l) (cadr l) (caddr l)) r) l (cdddr l)))
 r)
(defun HA:hcn(p1 p3 kc / p1x p3x)
 (setq p1x (list (+ (min (car p1) (car p3)) kc) (+ (min (cadr p1) (cadr p3)) kc))
       p3x (list (- (max (car p1) (car p3)) kc) (- (max (cadr p1) (cadr p3)) kc)))
 (command "rectang" p1x p3x))
(defun LM:UniqueFuzz(l fz)
 (if l 
  (cons (car l) (LM:UniqueFuzz (vl-remove-if '(lambda(x) (equal x (car l) fz)) (cdr l)) fz))))
(defun HA:DisMinMax(lst func / ghan)
 (if (= (strcase func) "MIN") (setq func min ghan 1E15) (setq func max ghan -1E15))
 (apply 'func (apply 'append (mapcar '(lambda(p) (mapcar '(lambda(q) (if (equal p q 1E-8) ghan (distance p q))) lst)) lst))))

<<

Filename: 235827_ha.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 235867
Tên lệnh: hcn
Code lisp như thế nào để hạn chế lỗi cho người dùng?

Chúng ta đang làm việc trên Cad, và chúng ta thấy Cad hầu như ít xãy ra lỗi. Vì sao thì chắc ai cũng biết.

Chúng ta cũng thường sử dụng Lisp trên các forum, và chúng ta thấy ít Lisp viết ra mà không dính lỗi này lỗi nọ. Vì sao vậy?

Vì đa số Lisp được viết chỉ để thỏa mãn nhu cầu trước mắt của người dùng, còn việc bẫy lỗi chưa được quan tâm thỏa đáng.

Với hy vọng...

>>

Chúng ta đang làm việc trên Cad, và chúng ta thấy Cad hầu như ít xãy ra lỗi. Vì sao thì chắc ai cũng biết.

Chúng ta cũng thường sử dụng Lisp trên các forum, và chúng ta thấy ít Lisp viết ra mà không dính lỗi này lỗi nọ. Vì sao vậy?

Vì đa số Lisp được viết chỉ để thỏa mãn nhu cầu trước mắt của người dùng, còn việc bẫy lỗi chưa được quan tâm thỏa đáng.

Với hy vọng code Lisp của mọi người ngày càng được chỉnh chu, phục vụ cộng đồng tốt hơn; xin mạn phép mở topic này để cùng thảo luận.

Các hình thức thảo luận có thể như thế này:

- Hỏi đáp về một hàm/một đoạn lisp ngắn nào đó cần phải sửa hoặc thay đổi như thế nào để tránh lỗi.

- Các lý thuyết về nguyên lý bẫy lỗi.

- Đưa lên một hàm/đoạn lisp mẫu để mọi người tìm xem nó có thể mắc lỗi gì (kiểu câu đố).

- V.v và v.v…

- Nhưng xin đừng đưa lên các lisp dài lê thê để nhờ tìm lỗi.

Từ các ví dụ, các câu hỏi… mọi người sẽ cùng thảo luận để tìm ra phương án khả dĩ tối ưu.

Xin được nổ phát pháo đầu tiên: mời mọi người phân tích xem lisp dưới đây có thể bị những lỗi gì khi sử dụng? Lỗi ở đây bao gồm lỗi nội bộ lisp và lỗi do tàn dư lisp để lại. Rất có thể từ ví dụ rất đơn giản này mà nhiều nguyên lý bẫy lỗi dần được phơi bày!

Lisp vẽ hình chữ nhật qua 2 điểm do người dùng nhập vào.

 

(defun C:HCN()
 (setq p1 (getpoint "\nPick diem 1: "))
 (setq p3 (getcorner p1 "\nPick diem 2: "))
 (command "rectang" p1 p3))

<<

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

Cũng mạn phép bạn tivateo -> sửa lại code của bạn 1 tí nhé :

Filename: 75348_vc.lsp
Tác giả: pucca
Bài viết gốc: 76550
Tên lệnh: %2B
Viết lisp theo yêu cầu [phần 2]

Chào các bạn. Mình đang có 2 lisp: tính tổng 1 loạt text rồi ghi sang 1 text và lisp ánh xạ 1 text sang text khác để tự động cập nhật theo. Giờ mình cần 1 lisp để tính tổng 1 loạt text field và tổng tự động cập nhật theo (sau khi REGEN) sau mỗi thay đổi của 1 trong các text field. Các bạn giúp mình kết hợp 2 lisp này được không. Cảm ơn nhiều
>>
Chào các bạn. Mình đang có 2 lisp: tính tổng 1 loạt text rồi ghi sang 1 text và lisp ánh xạ 1 text sang text khác để tự động cập nhật theo. Giờ mình cần 1 lisp để tính tổng 1 loạt text field và tổng tự động cập nhật theo (sau khi REGEN) sau mỗi thay đổi của 1 trong các text field. Các bạn giúp mình kết hợp 2 lisp này được không. Cảm ơn nhiều :bigsmile: .

Tính tổng:

<<

Filename: 76550_%2B.lsp
Tác giả: hochoaivandot
Bài viết gốc: 236074
Tên lệnh: rdt
Rải đối tượng theo đường dẫn Dynamic
Chức năng rải đối tượng theo đường dẫn thì có nhiều cách, nhiều lisp.
Lisp của bác Duy thì có nhiều chứng năng, đáp ứng đầy đủ yêu cầu người dùng.
hochoaivandot xin post thêm 1 lisp nữa. Lisp này chỉ được cái là nó Dynamic nên vui vui mắt thôi.
Mình không theo dõi diễn đàn nhiều sợ đã có người post lisp như thế này rồi. Nếu trùng lặp thì các mod xoá topic giúp nhé.
 
>>
Chức năng rải đối tượng theo đường dẫn thì có nhiều cách, nhiều lisp.
Lisp của bác Duy thì có nhiều chứng năng, đáp ứng đầy đủ yêu cầu người dùng.
hochoaivandot xin post thêm 1 lisp nữa. Lisp này chỉ được cái là nó Dynamic nên vui vui mắt thôi.
Mình không theo dõi diễn đàn nhiều sợ đã có người post lisp như thế này rồi. Nếu trùng lặp thì các mod xoá topic giúp nhé.
 
Rdt.gif
 

 (defun LM:PolyCentroid ( e / l )
(foreach x (setq e (entget e))
(if (= 10 (car x)) (setq l (cons (cdr x) l)))
)
(
(lambda ( a )
(if (not (equal 0.0 a 1e-8))
(trans
(mapcar '/
(apply 'mapcar
(cons '+
(mapcar
(function
(lambda ( a b )
(
(lambda ( m )
(mapcar
(function
(lambda ( c d ) (* (+ c d) m))
)
a b
)
)
(- (* (car a) (cadr B)) (* (car B) (cadr a)))
)
)
)
l (cons (last l) l)
)
)
)
(list a a)
)
(cdr (assoc 210 e)) 0
)
)
)
(* 3.0
(apply '+
(mapcar
(function
(lambda ( a b )
(- (* (car a) (cadr B)) (* (car B) (cadr a)))
)
)
l (cons (last l) l)
)
)
)
)
)
(defun LM:SSBoundingBox ( ss / i l1 l2 ll ur )
(repeat (setq i (sslength ss))
(vla-getboundingbox (vlax-ename->vla-object (ssname ss (setq i (1- i)))) 'll 'ur)
(setq l1 (cons (vlax-safearray->list ll) l1)
l2 (cons (vlax-safearray->list ur) l2)
)
)
(mapcar '(lambda ( a b ) (apply 'mapcar (cons a B))) '(min max) (list l1 l2))
)
(defun GetCenterSs (ss / bb e kq)
(setq bb (LM:SSBoundingBox ss))
(setq e (entmakex
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 4)
(cons 70 1)
(list 10 (caar bb) (cadar bb))
(list 10 (caadr bb) (cadar bb))
(list 10 (caadr bb) (cadadr bb))
(list 10 (caar bb) (cadadr bb))
)
))
(if e (setq kq (LM:PolyCentroid e)))
(entdel e)
kq
)
(defun ss-union ( s1 s2 / si )
(cond
( (null s1) s2)
( (null s2) s1)
( t
(repeat (setq si (sslength s1))
(ssadd (ssname s1 (setq si (1- si))) s2)
)
s2
)
)
)
(defun dxf (code e) (cdr (assoc code (entget e))))
(defun ss2ent(ss / sodt index lstent ent)
(setq
sodt (if ss (sslength ss) 0)
index 0
)
(repeat sodt
(setq
ent (ssname ss index)
index (1+ index)
lstent (cons ent lstent)
)
)
(reverse lstent)
)
(defun MakeLine (PT1 PT2 Layer Color)
(entmakex (list '(0 . "LINE")
(cons 8 (if Layer Layer (getvar "Clayer")))
(cons 62 (if Color Color 256))
(cons 10 PT1) (cons 11 PT2))))
(defun InsertObjTanCurve(en ss_Obj pt_iso pt / obj_en pt_iso_vla pt_vla att ss e obj newobj)
(setq
obj_en (vlax-ename->vla-object en)
pt_iso_vla (vlax-3D-point pt_iso)
pt_vla (vlax-3D-point pt)
)
(setq att (angle pt (polar pt (angle '(0 0 0) (vlax-curve-getFirstDeriv obj_en (vlax-curve-getParamAtPoint obj_en pt))) 2)))
(setq ss (ssadd))
(repeat (setq n (sslength ss_Obj))
(setq e (ssname ss_Obj (setq n (1- n))))
(setq obj (vlax-ename->vla-object e))
(setq newobj (vla-copy obj))
(vla-move newobj pt_iso_vla pt_vla)
(vla-rotate newobj pt_vla att)
(setq ss (ssadd (vlax-vla-object->ename newobj) ss))
)
ss
)
(defun GetDir (en pt1 pt2 / dis1 dis2 dis)
(setq
dis1 (vlax-curve-getDistAtPoint en pt1)
dis2 (vlax-curve-getDistAtPoint en pt2)
dis (- dis2 dis1)
)
(if (/= dis 0) (/ dis (abs dis)) 1)
)
(defun MeDyn (en ss_Obj ptiso pt1 dis ptcuoi / ss dis1 disn sumdis dir time i pt obj1 obj_en ss_obj1)
(setvar "osmode" 0)
(setq
ss (ssadd)
obj_en (vlax-ename->vla-object en)
dis1 (vlax-curve-getDistAtPoint obj_en pt1)
disn (vlax-curve-getDistAtPoint obj_en ptcuoi)
sumdis (- disn dis1)
dir (if (/= sumdis 0) (/ sumdis (abs sumdis)) 1)
time (if (/= sumdis 0) (1+ (fix (/ (abs sumdis) dis))) 1)
i 0
)
(repeat time
(setq
pt (vlax-curve-getPointAtDist obj_en (+ dis1 (* i dis dir)))
ss_obj1 (InsertObjTanCurve en ss_Obj ptiso pt)
)
(setq ss (ss-union ss ss_obj1))
(setq i (1+ i))
)
ss
)
(defun ST:SS->List-Vla (ss / n e l)
(setq n (sslength ss))
(while (setq e (ssname ss (setq n (1- n))))
(setq l (cons (vlax-ename->vla-object e) l))
)
)
(defun ST:Ss-Delete (ss / i)
(mapcar 'vla-delete (ST:SS->List-Vla ss))
)
(defun GetMid (pt1 pt2) (polar pt1 (angle pt1 pt2) (* 0.5 (distance pt1 pt2))))
(defun C:rdt(/ en obj_en ss_Obj ptiso data dir dis dis1 dis2 e err gr gr_fl n nmax nx oldos pt1 pt2 ptcuoi ptisodef ss1 temperr txt)
(defun Bdraw()
(setq OldOs (getvar "osmode"))
(setvar "osmode" 15359)
(setvar "cmdecho" 0)
(setvar "INSUNITS" 0)
(setq temperr *error*)
(setq *error* err)
)
(defun Edraw()
(setvar "cmdecho" 1)
(if OldOs (setvar "osmode" OldOs))
(if temperr (setq *error* temperr))
(princ)
)
(defun err (msg)
(if OldOs (setvar "osmode" OldOs))
(setvar "cmdecho" 1)
(if ss1 (ST:ss-delete ss1))
(if temperr (setq *error* temperr))
)
(Bdraw)
(setq en (car (entsel "\nTim")))
(setq obj_en (vlax-ename->vla-object en))
(setq ss_Obj (ssget) n (sslength ss_Obj))
(cond
((and (= n 1) (= (dxf 0 (setq e (ssname ss_Obj 0))) "INSERT")) (setq ptisoDef (dxf 10 e) txt "<Diem chen Block>"))
((and (= n 1) (= (dxf 0 (setq e (ssname ss_Obj 0))) "*TEXT")) (setq ptisoDef (dxf 10 e) txt "<Diem chen Text>"))
((and (= n 1) (= (dxf 0 (setq e (ssname ss_Obj 0))) "LINE")) (setq ptisoDef (GetMid (dxf 10 e) (dxf 11 e)) txt "<Diem giua Line>"))
(t (setq ptisoDef (GetCenterSs ss_Obj) txt "<Tam cua doi tuong>"))
)
(setq ptiso (getpoint (strcat "\nBase point" txt)))
(if (not ptiso) (setq ptiso ptisoDef))
(setq
ss1 nil
pt1 (vlax-curve-getClosestPointTo en (getpoint "Diem goc"))
pt2 (vlax-curve-getClosestPointTo en (getpoint pt1 "diem tiep"))
dis1 (vlax-curve-getDistAtPoint en pt1)
dis2 (vlax-curve-getDistAtPoint en pt2)
dis (abs (- dis1 dis2))
)
(prompt "\nPick \U+0111i\U+1EC3m cu\U+1ED1i:")
(while
(progn
(setq
gr (grread t 15 0)
gr_fl (car gr)
data (cadr gr)
)
(cond
((and (= 5 gr_fl) (listp data))
(progn
(if ss1 (ST:Ss-Delete ss1))
(setq ss1 (MeDyn en ss_Obj ptiso pt1 dis (vlax-curve-getClosestPointTo en data)))
)
t
)
((= 2 gr_fl)
(cond
((vl-position data '(78 110)) ; C/c Curve Aligned
(progn

(if ss1 (ST:Ss-Delete ss1))
(if (not dir) (setq dir (GetDir en pt1 pt2)))
(setq
nmax (fix (abs (/ (- (abs (- (vlax-curve-getDistAtParam en (vlax-curve-getStartParam en)) (vlax-curve-getDistAtParam en (vlax-curve-getEndParam en)))) dis1) dis dir)))
nx (getint (strcat "Copy m\U+1EA5y l\U+1EA7n <Max:" (itoa nmax) ">:"))
)
(if (not nx) (setq nx nmax))
(setq ptcuoi (vlax-curve-getPointAtDist en (+ dis1 (* nx dis dir))))
(MeDyn en ss_Obj ptiso pt1 dis ptcuoi)
)
))
nil
)
((and (= 3 gr_fl) (listp data))
(progn
(if ss1 (ST:Ss-Delete ss1))
(setq ss1 (MeDyn en ss_Obj ptiso pt1 dis (vlax-curve-getClosestPointTo en data)))
)
nil
)
)
)
)
(Edraw)
)

 
P/S:
- Lisp này là sản phẩm chôm sửa từ lisp array dynamic của ketxu.
- Lisp sử dụng nhiều hàm con của ketxu và Lee-mac.
- Cad đời cao thì cũng có dynamic nhưng mình cứ upload để dùng cho cad đời thấp.
- Định post thêm vaod trong topic của bác Duy, nhưng thấy topic có nhiều lisp quá sợ khó cho quá trình tìm kiếm của cadviet.com
Similar topics from web:
Phần mềm thống kê thép Dựa vào bản vẽ cad?
Ứng dụng CNTT trong Xây Dựng
Tài liệu DVD phần mềm kỹ thuật các loại uy tín! | Tư vấn kỹ thuật ...
ketxu
<<

Filename: 236074_rdt.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 236083
Tên lệnh: ha
Lisp đổi tên hàng loạt Layouts!

Lisp đổi tên tất cả layout thành các số nguyên từ 1 đến n.

 

;Doan Van Ha - CADViet.com - Ngay 25/5/2013
;Chuc nang: Thay doi ten tat ca layout, tu 1->2->3...n
(defun C:HA ( / i)
 (setq i 0)
 (vlax-for obj (vla-get-layouts (vla-get-ActiveDocument (vlax-get-acad-object)))
  (if (not (eq (vla-get-name obj) "Model")) (vla-put-name obj (itoa (setq i (1+ i)))))
 ...
>>

Lisp đổi tên tất cả layout thành các số nguyên từ 1 đến n.

 

;Doan Van Ha - CADViet.com - Ngay 25/5/2013
;Chuc nang: Thay doi ten tat ca layout, tu 1->2->3...n
(defun C:HA ( / i)
 (setq i 0)
 (vlax-for obj (vla-get-layouts (vla-get-ActiveDocument (vlax-get-acad-object)))
  (if (not (eq (vla-get-name obj) "Model")) (vla-put-name obj (itoa (setq i (1+ i)))))
  (vlax-release-object obj))
 (princ))

<<

Filename: 236083_ha.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 236067
Tên lệnh: ha
lisp vẽ mặt bằng kết cấu

1). Bạn kiểm tra và xoá 1 line trùng trong hình của bạn đi nhé.

2). Mình bổ sung thêm tí xíu cho lisp chạy nhanh hơn. Mình không ngờ khi zoom bé thì lisp chạy cực chậm như bản vẽ của bạn.

 

;Doan Van Ha - CADViet.com - Ngay 25/05/2013
;Chuc nang: ve luoi dam/tuong theo he truc // XOY, be rong tuy chon, luoi break bat ky nhung o ngoai cung phai la HCN.
(defun C:HA(/ ss lsti lst lstg1 giao lstg...
>>

1). Bạn kiểm tra và xoá 1 line trùng trong hình của bạn đi nhé.

2). Mình bổ sung thêm tí xíu cho lisp chạy nhanh hơn. Mình không ngờ khi zoom bé thì lisp chạy cực chậm như bản vẽ của bạn.

 

;Doan Van Ha - CADViet.com - Ngay 25/05/2013
;Chuc nang: ve luoi dam/tuong theo he truc // XOY, be rong tuy chon, luoi break bat ky nhung o ngoai cung phai la HCN.
(defun C:HA(/ ss lsti lst lstg1 giao lstg kcm ptx pty ent col lstb)
 (vl-load-com) (command "undo" "be") (redraw)
 (setq cmd (getvar "cmdecho") osm (getvar "osmode") hpb (getvar "hpbound")) (setvar "cmdecho" 0) (setvar "osmode" 0) (setvar "hpbound" 1)
 (setq col 1)
 (while
  (and
   (princ "\nChon cac Line duong truc...")
   (setq ss (ssget '((0 . "LINE"))))
   (setq lsti (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
   (or kc (setq kc 110))
   (setq kc (cond ((getdist (strcat "\nBe rong tuong/dam <" (rtos kc 2 2) ">:"))) (kc))))
  (mapcar '(lambda(ent) (grdraw (vlax-curve-getStartPoint ent) (vlax-curve-getEndPoint ent) col)) lsti)
  (setq lst (append (mapcar '(lambda(ent) (list ent kc)) lsti) lst))
  (setq lstb (append lsti lstb))
  (setq col (1+ col)))
 (command "zoom" "w" (car (setq c (LM:ListBoundingBox lstb))) (cadr c))
 (setq lst (reverse lst))
 (foreach n1 lst
  (setq lstg1 nil)
  (foreach n2 lst
   (if (setq giao (car (HA:Giao (vlax-ename->vla-object (car n1)) (vlax-ename->vla-object (car n2)) acExtendNone)))
    (setq lstg1 (cons giao lstg1))))
  (if lstg1 (setq lstg (append lstg1 lstg))))
 (setq lstg (LM:UniqueFuzz (vl-sort lstg '(lambda(p q) (if (equal (car p) (car q) 1E-3) (< (cadr p) (cadr q)) (< (car p) (car q))))) 1E-3))
 (HA:hcn (car lstg) (last lstg) 0)
 (setq a lstg)
 (HA:OffsetInOut (entlast) lst "N")
 (setq kcm (* 0.9 (HA:DisMinMax lstg "min")))
 (setq ss (ssadd) ptx (polar (car lstg) 0 kcm))
 (while (< (car ptx) (car (last lstg)))
  (setq pty (polar ptx (/ pi 2) kcm))
  (while (< (cadr pty) (cadr (last lstg)))
   (setq ent (entlast))
   (command "boundary" pty "")
   (if (setq ent (entnext ent)) (setq ss (ssadd ent ss)))
   (setq pty (polar pty (/ pi 2) kcm)))
  (setq ptx (polar ptx 0 kcm)))
 (load "overkillsup.lsp") (acet-overkill2 (list ss 1E-3 nil "N" "N" "N"))
 (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "w" (car lstg) (last lstg) '((0 . "LWPOLYLINE"))))))
  (HA:OffsetInOut ent lst "T"))
 (acet-overkill2 (list (ssget "w" (car lstg) (last lstg) '((0 . "LWPOLYLINE"))) 1E-3 nil "N" "N" "N"))
 (setvar "cmdecho" cmd) (setvar "hpbound" hpb) (setvar "osmode" osm) (command "undo" "e") (redraw) (princ))
;-----
(defun LM:ListBoundingBox ( entlst / l1 l2 ll ur )
 (foreach ent entlst
  (setq obj (vlax-ename->vla-object ent))
  (vla-getboundingbox obj 'll 'ur)
  (setq l1 (cons (vlax-safearray->list ll) l1) l2 (cons (vlax-safearray->list ur) l2)))
  (mapcar (function (lambda (a b) (apply 'mapcar (cons a b)))) '(min max) (list l1 l2)))
;----- Check xem 2 lines ent1 vµ ent2 n»m trªn cïng ®­êng th¼ng kh«ng?
(defun HA:2LineCollinear-p(ent1 ent2)
 (setq p1 (vlax-curve-getStartPoint ent1) p2 (vlax-curve-getEndPoint ent1)
       q1 (vlax-curve-getStartPoint ent2) q2 (vlax-curve-getEndPoint ent2))
 (and
  ((lambda(a b c) (or (equal (+ a b) c 1E-3) (equal (+ b c) a 1E-3) (equal (+ c a) b 1E-3))) (distance p1 p2) (distance p2 q1) (distance q1 p1))
  ((lambda(a b c) (or (equal (+ a b) c 1E-3) (equal (+ b c) a 1E-3) (equal (+ c a) b 1E-3))) (distance p1 p2) (distance p2 q2) (distance q2 p1))))
;----- Check xem ®iÓm p co n»m trong/ngoµi obj kin hay kh«ng?
(defun HA:PointInOut (p obj flag / flag1 obj1 obj2 lon nho)
 (setq obj1 (car (vlax-invoke obj 'Offset 1E-3))
       obj2 (car (vlax-invoke obj 'Offset -1E-3)))
 (if (> (vla-get-area obj1)(vla-get-area obj2))
  (setq lon obj1 nho obj2)
  (setq lon obj2 nho obj1))
 (if (> (distance p (vlax-curve-getClosestPointTo lon p))(distance p (vlax-curve-getClosestPointTo nho p)))
  (if (= flag "T")
   (setq flag1 T)))
 (mapcar 'vla-delete (list lon nho))
 flag1)
;----- Offset ent vµo bªn trong polygon, víi dis mçi c¹nh kh¸c nhau.
(defun HA:OffsetInOut(ent lstx flag / obj0 obj obj1 obj2 i mid objc objl lst lst1 lst2 lst3 lst4)
 (setq obj0 (vlax-ename->vla-object ent))
 (setq lst (mapcar 'cdr (vl-remove-if-not '(lambda(x) (= (car x) 10)) (entget ent))))
 (setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "cp" lst '((0 . "LINE")))))))
 (setq lst1 (append lst lst))
 (setq i 0)
 (repeat (length lst)
  (setq obj (vlax-ename->vla-object (setq ent1 (entmakex (list (cons 0 "LINE") (cons 10 (nth i lst1)) (cons 11 (nth (1+ i) lst1)))))))
  (foreach ent2 entlst
   (if (HA:2LineCollinear-p ent1 ent2) (setq entL ent2)))
  (foreach ent lstx
   (if (equal entL (car ent)) (setq kcx (cadr ent))))
  (setq obj1 (car (vlax-invoke obj 'Offset (/ kcx 2))) obj2 (car (vlax-invoke obj 'Offset (/ kcx -2))))
  (setq mid (mapcar '(lambda(x y) (/ (+ x y) 2)) (vlax-curve-getStartPoint obj1) (vlax-curve-getEndPoint obj1)))
  (if (HA:PointInOut mid obj0 flag)
   (setq objc obj1 objl obj2)
   (setq objc obj2 objl obj1))
  (setq lst2 (cons objc lst2))
  (mapcar 'vla-delete (list objl obj))
  (setq i (1+ i)))
 (setq lst3 (append lst2 lst2))
 (setq i 0)
 (repeat (length lst2)
  (if (setq giao (HA:Giao (nth i lst3) (nth (1+ i) lst3) acExtendBoth))
   (setq lst4 (cons (car giao) lst4)))
  (setq i (1+ i)))
 (LWPoly lst4 1)
 (mapcar 'vla-delete (cons obj0 lst2)))
(defun LWPoly(lst cls)
 (entmakex (append (list 
    (cons 0 "LWPOLYLINE") (cons 100 "AcDbEntity") (cons 100 "AcDbPolyline") (cons 90 (length lst)) (cons 70 cls)) (mapcar (function (lambda (p) (cons 10 p))) lst))))
(defun HA:Giao(obj1 obj2 mode / l r)
 (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
 (repeat (/ (length l) 3)
  (setq r (cons (list (car l) (cadr l) (caddr l)) r) l (cdddr l)))
 r)
(defun HA:hcn(p1 p3 kc / p1x p3x)
 (setq p1x (list (+ (min (car p1) (car p3)) kc) (+ (min (cadr p1) (cadr p3)) kc))
       p3x (list (- (max (car p1) (car p3)) kc) (- (max (cadr p1) (cadr p3)) kc)))
 (command "rectang" p1x p3x))
(defun LM:UniqueFuzz(l fz)
 (if l 
  (cons (car l) (LM:UniqueFuzz (vl-remove-if '(lambda(x) (equal x (car l) fz)) (cdr l)) fz))))
(defun HA:DisMinMax(lst func / ghan)
 (if (= (strcase func) "MIN") (setq func min ghan 1E15) (setq func max ghan -1E15))
 (apply 'func (apply 'append (mapcar '(lambda(p) (mapcar '(lambda(q) (if (equal p q 1E-3) ghan (distance p q))) lst)) lst))))

<<

Filename: 236067_ha.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 236119
Tên lệnh: ha
Lisp đổi tên hàng loạt Layouts!

Sửa lại 2 lỗi trên đây!

 

(defun C:HA(/ acdoc aclay actab i)
 (vl-load-com)
 (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))
       actab (strcase (getvar 'CTAB)))
 (vlax-for l (vla-get-layouts acdoc)
  (if (not (eq actab (strcase (vla-get-name l))))
   (setq aclay (cons (cons (vla-get-name l) l) aclay))))
 (setq aclay (vl-sort aclay (function (lambda(a b)...
>>

Sửa lại 2 lỗi trên đây!

 

(defun C:HA(/ acdoc aclay actab i)
 (vl-load-com)
 (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))
       actab (strcase (getvar 'CTAB)))
 (vlax-for l (vla-get-layouts acdoc)
  (if (not (eq actab (strcase (vla-get-name l))))
   (setq aclay (cons (cons (vla-get-name l) l) aclay))))
 (setq aclay (vl-sort aclay (function (lambda(a b) (< (vla-get-taborder (cdr a)) (vla-get-taborder (cdr b)))))))
 (setq i 100000000)
 (foreach n aclay
  (vla-put-name (cdr n) (itoa (setq i (1+ i))))
  (vlax-release-object (cdr n)))
 (setq aclay nil)
 (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))
       actab (strcase (getvar 'CTAB)))
 (vlax-for l (vla-get-layouts acdoc)
  (if (not (eq actab (strcase (vla-get-name l))))
   (setq aclay (cons (cons (vla-get-name l) l) aclay))))
 (setq aclay (vl-sort aclay (function (lambda(a b) (< (vla-get-taborder (cdr a)) (vla-get-taborder (cdr b)))))))
 (setq i 0)
 (foreach n aclay
  (vla-put-name (cdr n) (itoa (setq i (1+ i))))
  (vlax-release-object (cdr n))))

<<

Filename: 236119_ha.lsp
Tác giả: nataca
Bài viết gốc: 236126
Tên lệnh: trt
Lệnh Trim CAD đặc biệt- làm thế nào để ấn phần dài cắt phần ngắn?

Có phải ý bạn là thế này? 

TRT.gif

 

(defun C:TRT (/ DTCAT ENT P P1 P2 PG ENT1 LENT PD) ;;;Trim Trai chieu
	(prompt "\nChon doi tuong cat")
	(setq dtcat (ssget))
	(prompt "\nChon doi tuong bi cat")
	(setq	p			(getpoint)
				Lent	(C_S2L (ssget "C" p (getcorner p)))
	)
	(foreach ent Lent
		(setq pg		(car (INTS_2ENT (ssname dtcat 0) ent)))
		(if (eq (DXF 0 ent)...
>>

Có phải ý bạn là thế này? 

TRT.gif

 

(defun C:TRT (/ DTCAT ENT P P1 P2 PG ENT1 LENT PD) ;;;Trim Trai chieu
	(prompt "\nChon doi tuong cat")
	(setq dtcat (ssget))
	(prompt "\nChon doi tuong bi cat")
	(setq	p			(getpoint)
				Lent	(C_S2L (ssget "C" p (getcorner p)))
	)
	(foreach ent Lent
		(setq pg		(car (INTS_2ENT (ssname dtcat 0) ent)))
		(if (eq (DXF 0 ent) "LINE")
			(progn
				(setq ent1 	(MK_PLINE1 (list (DXF 10 ent) (DXF 11 ent)))
							p1 		(car (P_VPL ent1))
							p2		(last (P_VPL ent1))
							pd		(vlax-curve-getClosestPointTo ent1 p)
				)
				(entdel ent1)
			)
			(setq p1 		(car (P_VPL ent))
						p2		(last (P_VPL ent))
						pd			(vlax-curve-getClosestPointTo ent p)
			)
		)
		(if (equal (AG_3P pg pd p1) 0 0.0001)
			(setq pd p2)
			(setq pd p1)
		)
		(if (eq (DXF 0 ent) "LINE")
			(vl-cmdf "trim" dtcat "" pd  "")
			(entmod (subst (cons 10 pg) (cons 10 pd) (entget ent)))
		)
	)
)
(defun INTS_2ENT (ent1 ent2 / ob1 ob2 g kq sd)
	(setq	ob1	(vlax-ename->vla-object ent1)
				ob2	(vlax-ename->vla-object ent2)
	)
	(setq	g	(vlax-variant-value
						(vla-IntersectWith ob1 ob2 acExtendNone)
					)
	)
	(if	(/= (vlax-safearray-get-u-bound g 1) -1)
		(setq g (vlax-safearray->list g))
		(setq g nil)
	)
	(if	g
		(progn
			(setq	kq nil
						sd (fix (/ (length g) 3))
			)
			(repeat	sd
				(setq	kq (append kq (list (list (car g) (cadr g) (caddr g))))
							g	 (cdddr g)
				)
			)
			kq
		)
		nil
	)
)
(defun MK_PLINE1 (Vpl)
	(vl-cmdf "Pline")
	(foreach v Vpl
		(vl-cmdf v)
	)
	(vl-cmdf "")
	(entlast)
)
(defun DXF (Id Obj)
	(cdr (assoc Id (entget Obj)))
)
(defun C_S2L (ss)
	(if	ss
		(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
		nil
	)
)
(defun P_VPL (Pline)
	(if Pline
		(mapcar	'cdr
						(vl-remove-if-not
							'(lambda (x) (= 10 (car x)))
							(entget Pline)
						)
		)
		nil
	)
)
(defun AG_3P (Pt0 pt1 pt2 / goc goc1 goc2)
	(setq	goc1 (angle Pt0 Pt1)
				goc2 (angle Pt0 Pt2)
				goc	 (if (> (abs (- goc1 goc2)) pi)
							 (- (* 2 pi) (abs (- goc1 goc2)))
							 (abs (- goc1 goc2))
						 )
	)
	goc
)

<<

Filename: 236126_trt.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 236232
Tên lệnh: ha
Lệnh Trim mở rộng

Xuất phát từ nhu cầu Trim cần có nhiều lựa chọn hơn nữa so với lệnh Trim gốc của Cad, tôi viết lisp này để phục vụ bà con lối xóm.

Trên forum đã có vài topic nói về Trim mở rộng, nhưng theo những nhu cầu khác nhau, nằm lẻ tẻ, và hầu như cũng chưa hoàn thiện lắm.

Lệnh Trim mở rộng này có 3 tùy chọn: Trim theo từng phía + Trim đoạn ngắn + Trim đoạn dài.

Đối tượng Trim:...

>>

Xuất phát từ nhu cầu Trim cần có nhiều lựa chọn hơn nữa so với lệnh Trim gốc của Cad, tôi viết lisp này để phục vụ bà con lối xóm.

Trên forum đã có vài topic nói về Trim mở rộng, nhưng theo những nhu cầu khác nhau, nằm lẻ tẻ, và hầu như cũng chưa hoàn thiện lắm.

Lệnh Trim mở rộng này có 3 tùy chọn: Trim theo từng phía + Trim đoạn ngắn + Trim đoạn dài.

Đối tượng Trim: Line, Polyline, Lwpolyline, Spline, Arc.

Ai tải về dùng tốt thì nhớ like. Ai thấy chưa ưng bụng thì góp ý để sửa, đừng ném đá.

Hình để xem:

67029_trim_mo_rong.png

File Cad để test:

http://www.cadviet.com/upfiles/3/67029_trim_nguoc.dwg

File Lsp để dùng:

;Co 3 kieu Trim:
;1). Trim theo Phia: pick diem phia nao thi Trim phia do (tuong tu offset).
;2). Trim doan Ngan: Trim phan ngan.
;3). Trim doan Dai: Trim phan dai.
;Khong Trim cac truong hop: doi tuong la duong kin; giao nhau tai hon 1 diem; giao nhau bieu kien.
(defun C:HA( / ent0 ent ent2 ss typ p ento lstg len1 len2)
 (vl-load-com) (command "undo" "be") (setq cmd (getvar "cmdecho")) (setvar "cmdecho" 0)
 (if
  (and
   (setq ent0 (car (entsel "\nChon 1 doi tuong dao cat: ")))
   (princ "\nChon cac doi tuong bi cat...")
   (setq ss (ssget '((0 . "Line,Polyline,Lwpolyline,Spline,Arc")))))
  (progn
   (initget "P N D")
   (setq typ (getkword "\nChon kieu Trim <P>: "))
   (if (not typ) (setq typ "P"))
   (if (= typ "P")
    (progn
(initget 65)
     (setq p (getdist (GetP (vlax-curve-getStartPoint ent0) (vlax-curve-getEndPoint ent0) (/ (HA:LenCur ent0) 2) ent0) "\nPick chon phia can Trim: "))
     (command "offset" 1E-3 ent0 p "")
     (setq ento (entlast))))
   (foreach ent1 (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    (setq lstg (HA:Giao (vlax-ename->vla-object ent0) (vlax-ename->vla-object ent1) acExtendNone))
    (if (and (= (length lstg) 1) (not (equal (car lstg) (vlax-curve-getStartPoint ent1) 1E-3)) (not (equal (car lstg) (vlax-curve-getEndPoint ent1) 1E-3)))
     (progn
      (setq ent (entlast))
      (command ".break" ent1 "_non" (car lstg) "_non" (car lstg))
      (setq ent2 (car (HA:GetNewEnts ent)))
      (setq len1 (HA:LenCur ent1) len2 (HA:LenCur ent2))
      (cond
       ((or (and (= typ "N") (> len1 len2)) (and (= typ "D") (< len1 len2))) (entdel ent2))
  ((or (and (= typ "N") (< len1 len2)) (and (= typ "D") (> len1 len2))) (entdel ent1))
       ((= typ "P")
        (if (HA:Giao (vlax-ename->vla-object ento) (vlax-ename->vla-object ent1) acExtendNone)
    (entdel ent1)
    (entdel ent2)))))))
   (if ento (entdel ento))))
 (command "undo" "e") (setvar "cmdecho" cmd) (princ))
(defun GetP (pg ph kc cur / dg dh dp)
 (setq dg (vlax-curve-getDistAtPoint cur pg))
 (setq dh (vlax-curve-getDistAtPoint cur ph))
 (if (> dh dg)
  (setq dp (+ dg kc))
  (setq dp (- dg kc)))
 (vlax-curve-getPointAtDist cur dp))
(defun HA:GetNewEnts (ename / new) (while (setq ename (entnext ename)) (if (entget ename) (setq new (cons ename new)))) new)
(defun HA:LenCur(ent)
 (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)))
(defun HA:Giao(obj1 obj2 mode / l r)
 (setq l (vlax-invoke obj1 'intersectwith obj2 mode))
 (repeat (/ (length l) 3)
  (setq r (cons (list (car l) (cadr l) (caddr l)) r) l (cdddr l)))
 r)
 


<<

Filename: 236232_ha.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 53683
Tên lệnh: nl
Viết Lisp theo yêu cầu

Chào bạn ngocthinh84,
Nếu chỉ để xóa các đường line đó thì đơn giản, nhưng việc vẽ lại các đường line đó mới làm mình đau đầu do các line của bạn sắp xếp lung tung quá, không theo quy luật gì. Việc nối các line thì chỉ có thể chuyển thành pline mới nối được bạn ạ.
Nếu bạn chấp nhận vẽ lại các đường đó bằng tay thì cái líp xóa các line đó đây bạn ạ.
>>

Chào bạn ngocthinh84,
Nếu chỉ để xóa các đường line đó thì đơn giản, nhưng việc vẽ lại các đường line đó mới làm mình đau đầu do các line của bạn sắp xếp lung tung quá, không theo quy luật gì. Việc nối các line thì chỉ có thể chuyển thành pline mới nối được bạn ạ.
Nếu bạn chấp nhận vẽ lại các đường đó bằng tay thì cái líp xóa các line đó đây bạn ạ.


Mình đang cố nghĩ cách giải quyết hoàn chỉnh vấn đề của bạn mà chưa được. Mong bạn thông cảm.
<<

Filename: 53683_nl.lsp
Tác giả: gia_bach
Bài viết gốc: 236205
Tên lệnh: cut
Lệnh Trim CAD đặc biệt- làm thế nào để ấn phần dài cắt phần ngắn?

........

Tiện đây nhờ các bác viết lisp minh họa bằng hình ảnh sau:114276_%C3%A0af70.png

Hy vọng Lisp này đáp ứng được yêu cầu của "em" Hoằn.

(Chỉ sử dụng với Line và Arc)

(defun C:cut(/ ent...
>>

........

Tiện đây nhờ các bác viết lisp minh họa bằng hình ảnh sau:114276_%C3%A0af70.png

Hy vọng Lisp này đáp ứng được yêu cầu của "em" Hoằn.

(Chỉ sử dụng với Line và Arc)

(defun C:cut(/ ent ss e pt1 pt2 iPts)
  (command "undo" "be")
  (while
    (not
      (and
	(setq ent (car (entsel "Duong chuan :")))
	(if ent (wcmatch (cdr (assoc 0 (entget ent))) "LINE,ARC,RAY,XLINE" ) ) ) )
    (princ "\nSelect Again: ")    )
  (setq ent (vlax-ename->vla-object ent))
  (princ "\nVat bi cat...")
  (if(setq ss (ssget "_:L" (list (cons 0 "LINE,ARC"))))
    (foreach e (mapcar 'vlax-ename->vla-Object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
      (setq iPts (vlax-Invoke ent "IntersectWith" e 2)
	    ObjName (vla-get-ObjectName e)
	    pt1 (vlax-curve-getStartPoint e)
	    pt2 (vlax-curve-getEndPoint e))
      (if (and iPts (= 3(length iPts) ))
	(cond
	  ((eq ObjName "AcDbLine") ;LINE
	   (if (> (distance iPts pt1)(distance iPts pt2))
	     (vla-put-EndPoint e (vlax-3d-point iPts))
	     (vla-put-StartPoint e (vlax-3d-point iPts)) ) )
	  ((eq ObjName "AcDbArc") ;ARC
	   (setq center (vlax-safearray->list (variant-value (vla-get-Center e))))
	   (if (> (distance iPts pt1)(distance iPts pt2))
	     (vla-put-EndAngle e (vlax-make-variant(angle center iPts)) )
	     (vla-put-StartAngle e (vlax-make-variant(angle center iPts))) ) )   ))))
  (command "undo" "e")(princ)  )

<<

Filename: 236205_cut.lsp

Trang 131/330

131