Chuyển đến nội dung
Diễn đàn CADViet
  • Thông báo

    • Nguyen Hoanh

      CADViet đã hoàn tất nâng cấp   14/09/2017

      Chào các bạn, CADViet đã hoàn tất việc nâng cấp lên phiên bản mới. Tất cả các chức năng đã hoạt động theo kỳ vọng của ban quản trị. Nếu có vấn đề gì cần phản hồi, các bản post ở đây nhé: Trân trọng, Nguyễn Hoành.
dizangu

[Yêu cầu]Kính gửi các chuyên gia về lisp

Các bài được khuyến nghị

dizangu    5

- Vấn đề của em đặt ra thế này

em muốn 1 lisp mà khi ta quét chuột vào các đối tượng cad hiện có trên bản vẽ thì lisp nhận dạng đối tượng cad đó và vẽ ra 1 vị trí khác đúng như thế

về sau có thể thêm thắt 1 số chi tiết nhỏ bổ sung vào

- Kính mong các chuyên gia về lisp chỉ giao cho em vấn đề này

  • Vote giảm 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
dizangu    5

ý của mình là như này. Mình có 1 cái nút giao trong 1 khu đô thị mình muốn tách nó ra vị trí khác copy ra rồi cắt bỏ chỗ thừa thì rất lâu. Mình muốn quét chuột 1 hình vuông quanh cái nút đó bốc ra vị trí khác vẽ luôn các đối tượng cad trong phạm vi mình vừa quét rồi thiết kế nút đó.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
gia_bach    1.442

- Vấn đề của em đặt ra thế này

em muốn 1 lisp mà khi ta quét chuột vào các đối tượng cad hiện có trên bản vẽ thì lisp nhận dạng đối tượng cad đó và vẽ ra 1 vị trí khác đúng như thế

.......

Tham khảo : Lisp chọn đối tuợng với đuờng bao link hay other

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
cd2k44    121

- Các bác không hiểu ý của em rồi kính mong các bác bỏ chút thời gian xem bản vẽ này của mình . mình lập cả sơ đồ mong mọi người giúp

http://www.mediafire...dr4bf40i9tle3p4

Mình thực hiện trên file của bạn luôn nhé.Lisp này của bác thiệp mà bác thanhduan đã nói.Thực hiện được ý đồ của bạn rồi đó.Bạn xem video nhé

Mình muốn xin bộ lisp về thiết kế nút của bạn được không.Bạn có thể gửi lên đây hoặc gửi mail cho mình:anhtuan011185@gmail.com.Cảm ơn bạn rất nhiều vì mình cũng đang cần tiện ích này

;;;-----------------------
(defun SS-enlst (ss / c L)
 (setq c -1)
 (repeat (sslength ss)
(setq L (cons (ssname ss (setq c (1+ c))) L))
 )
 (reverse L)
)
;;;---------------------- -
(defun Text (model str po h ang / obj)
 (setq obj (vla-AddText
  	*Model*
  	str
  	(vlax-3d-point po)
  	h
	)
 )
 (vla-put-Alignment obj acAlignmentTopCenter)
 (vla-put-TextAlignmentPoint obj (vlax-3d-point po))
)
;;;====================================================================
(defun break_with (Lstent enL / lst masterlist ss oc break_obj intpts)
 (princ "\nCalculating Break Points, Please Wait.\n")

 ;;========================================
 ;; Break entity at break points in list
 ;;========================================
 (defun break_obj (ent brkptlst   /   	brkobjlst  en
  enttype	maxparam   closedobj  minparam
  obj	obj2break  p1param  p2param
  brkpt2	dlst   	idx  brkptS
  brkptE	brkpt  	result  result
  ignore	dist   	tmppt  #ofpts
  enddist	lastent	obj2break  stdist
    	)
	(setq obj2break ent
brkobjlst (list ent)
enttype   (dxf 0 ent)
	)
(if (not (or (eq (dxf 0 obj2break) "TEXT")
  (eq (dxf 0 obj2break) "MTEXT")
 	)
)
 	(setq closedobj (vlax-curve-isclosed obj2break))
)
(setq spt	(vlax-curve-getstartpoint ent)
  ept	(vlax-curve-getendpoint ent)
  brkptlst (vl-remove-if
  	'(lambda (x)
  (or (< (distance x spt) 0.0001)
  	(< (distance x ept) 0.0001)
  )
   	)
  	brkptlst
	)
)
;)
(if (and brkptlst
 	(not (or (eq (dxf 0 obj2break) "TEXT")
   	(eq (dxf 0 obj2break) "MTEXT")
)
 	)
)
 	(progn
(setq brkptlst
   	(mapcar
  '(lambda (x)
 	(list
   	x
   	(vlax-curve-getdistatparam
  obj2break
  (cond
	((vlax-curve-getparamatpoint obj2break x)
	)
	((vlax-curve-getparamatpoint
   	obj2break
   	(vlax-curve-getclosestpointto
     	obj2break
     	x
   	)
 	)
	)
  )
   	)
 	)
)
  brkptlst
   	)
)
(setq
  brkptlst (vl-sort brkptlst
  	'(lambda (a1 a2) (< (cadr a1) (cadr a2)))
	)
)
(foreach brkpt (reverse brkptlst)
	(setq brkptS (car brkpt)
brkptE brkptS
	)
  ;; get last entity created via break in case multiple breaks
  (if brkobjlst
	(progn
  	(setq tmppt brkptS) ; use only one of the pair of breakpoints
  	;; if pt not on object x, switch objects
  	(if (not (numberp (vl-catch-all-apply
 	'vlax-curve-getdistatpoint
 	(list obj2break tmppt)
)
    	)
)
 (progn   ; find the one that pt is on
(setq idx (length brkobjlst))
(while
 	(and (not (minusp (setq idx (1- idx))))
(setq obj (nth idx brkobjlst))
(if (numberp (vl-catch-all-apply
	'vlax-curve-getdistatpoint
	(list obj tmppt)
     	)
   	)
 	(null (setq obj2break obj))
	; switch objects, null causes exit
 	t
)
 	)
)
 )
  	)
	)
  ); end (if brkobjlst

  ;;; Handle any objects that can not be used with the Break Command
  ;;; using one point, gap of 0.000001 is used
  (if (not (or (eq (dxf 0 obj2break) "TEXT")
    	(eq (dxf 0 obj2break) "MTEXT")
	)
  	)
	(setq closedobj (vlax-curve-isclosed obj2break))
  )
;;; single breakpoint ----------------------------------------------------
	(if
  	(and closedobj
	(not (setq
	brkptE (vlax-curve-getPointAtDist
  	obj2break
  	(+ (vlax-curve-getdistatparam
	obj2break
	(cond
  	((vlax-curve-getparamatpoint
     	obj2break
     	brkpts
   	)
  	)
  	((vlax-curve-getparamatpoint
     	obj2break
     	(vlax-curve-getclosestpointto
       	obj2break
       	brkpts
     	)
   	)
  	)
	)
     	)
     	0.00001
  	)
	)
  )
	)
  	)
   	(setq
  brkptE (vlax-curve-getPointAtDist
	obj2break
	(- (vlax-curve-getdistatparam
     	obj2break
     	(cond ((vlax-curve-getparamatpoint
	obj2break
	brkpts
     	)
    	)
    	((vlax-curve-getparamatpoint
	obj2break
	(vlax-curve-getclosestpointto
  	obj2break
  	brkpts
	)
     	)
    	)
     	)
   	)
   	0.00001
	)
  )
   	); end setq brkptE
	); end fi (and closedobj
  ;; (if (null brkptE) (princ)) ; debug
  (setq LastEnt (GetLastEnt))
  (if (not (or (eq (dxf 0 obj2break) "TEXT")
    	(eq (dxf 0 obj2break) "MTEXT")
	)
  	)
	(command "._break"
  	obj2break
  	"_non"
  	(trans brkptS 0 1)
  	"_non"
  	(trans brkptE 0 1)
	)
  )
  (and (= "CIRCLE" enttype) (setq enttype "ARC"))
  (if (and (not closedobj) ; new object was created
	(not (equal LastEnt (entlast)))
  	)
	(setq brkobjlst (cons (entlast) brkobjlst))
  ); end (if (and
); end (foreach brkpt
 	);end progn brkptlst
); end if brkptlst
 ); defun break_obj
 ;;====================================
 ;; CAB - get last entity in datatbase
 (defun GetLastEnt (/ ename result)
(if (setq result (entlast))
 	(while (setq ename (entnext result))
(setq result ename)
 	)
)
result
 )
 ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 ;; S T A R T          	S U B R O U T I N E         	H E R E
 ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(if (and Lstent enL)
(progn
 	;; CREATE a list of entity & it's break points
 	(foreach en Lstent
	; check each object in Lstent
(if (not (acet-layer-locked (dxf 8 en)))
  (progn
	(setq lst nil)
	;; check for break pts with other objects in Lstentwith
	(if (and (not (equal en enint))
  	(setq intpts (acet-geom-intersectwith en enL 0))
 )
  	(setq lst (append intpts lst))
	; entity w/ break points
	)
	(if lst
  	(setq masterlist
  	(cons (cons en lst) masterlist)
  	)
	)
  )
)
 	)
 	(princ "\nBreaking Objects.\n")
 	(if masterlist
(progn
  (acet-ui-progress "hoan thanh %" (length masterlist))
  (foreach obj2brk masterlist
	(break_obj (car obj2brk) (cdr obj2brk))
	(acet-ui-progress -1)
  )
  (acet-ui-progress)
)
 	)
)
 )
);end break_with
;;===========================================================================
;; get all objects touching entities in the sscross
;; limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
;; returns a list of enames
;;===========================================================================
(defun gettouching (en / ss lst lstb lstc objl)
 (and
(setq objl (vlax-ename->vla-object en))
(setq
 	ss
  	(ssget
 "_A"
 (list
(cons 0
  "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
)
(cons 410 (getvar "ctab"))
 )
  	)
)
(setq lst (SS-enlst ss)
	lst (mapcar 'vlax-ename->vla-object lst))
(mapcar
 	'(lambda (x)
 (if (not
   	(vl-catch-all-error-p
  (vl-catch-all-apply
	'(lambda ()
   	(vlax-safearray->list
  (vlax-variant-value
	(vla-intersectwith objl x acextendnone)
  )
   	)
 	)
  )
   	)
 	)
(setq lstc (cons (vlax-vla-object->ename x) lstc))
 )
  	)
 	lst
)
 )
 lstc
)
;;;------------------------------------------------
(defun LWP (Lpoint *Model* / PntArr)
 (setq PntArr (vlax-make-safearray
  vlax-vbDouble
  (cons 0 (1- (length Lpoint)))
   	)
 )
 (vlax-safearray-fill PntArr Lpoint)
 (vla-AddLightWeightPolyline *Model* PntArr)
)
;;;------------------------------------------------
(defun DXF (code en) (cdr (assoc code (entget en))))
;;;============================================================
;;;=======================MAIN LISP============================
;;;============================================================
(defun c:trichBD (/ ActDoc *Model* ss encur lsten p1 p2 p3 LenssBR lstp objCE)
 (setq ActDoc (vla-get-ActiveDocument (vlax-get-acad-object))
*Model* (vla-get-ModelSpace ActDoc)
 )
 (setq bit1 (cond (bit1)
("Rectangle")
	)
 )
 (initget "Square Rectangle Circle Ellipse Different")
 (setq tmp (strcat "\nChon duong bao: [square/Rectangle/Circle/Ellipse/Different] <" bit1 ">: ")
bit1	(cond ((getkword tmp))
  	(bit1)
   	)
 )
 (vla-StartUndoMark ActDoc)
 (setvar "cecolor" "104")
 (setq p1 (list (car (getvar "extmin")) (cadr (getvar "extmin"))))
 (cond ((eq bit1 "Square")
 (setq a (cond (a)
    	(50)
  )
 )
 (setq olda a)
 (setq a (getreal (strcat "\nChon kich thuoc canh Square <"
 	(rtos olda 2 1)
 	"> : "
	)
  )
 )
 (if (null a)
(setq a olda)
 )
 (setq lstp (list (list (car p1) (cadr p1) 0)
	(list (+ (car p1) a) (cadr p1) 0)
	(list (+ (car p1) a) (+ (cadr p1) a) 0)
	(list (car p1) (+ (cadr p1) a) 0)
	(list (car p1) (cadr p1) 0)
 	)
 )
)
((eq bit1 "Rectangle")
 (setq a (cond (a)
    	(50)
  )
 )
 (setq olda a)
 (setq a (getreal (strcat "\nChon chieu dai Rectangle <"
 	(rtos olda 2 1)
 	"> : "
	)
  )
 )
 (if (null a)
(setq a olda)
 )
 (setq b (cond (B)
    	(50)
  )
 )
 (setq oldb B)
 (setq b (getreal (strcat "\nChon chieu rong Rectangle <"
 	(rtos oldb 2 1)
 	"> : "
	)
  )
 )
 (if (null B)
(setq b oldb)
 )
 (setq lstp (list (list (car p1) (cadr p1) 0)
	(list (+ (car p1) a) (cadr p1) 0)
	(list (+ (car p1) a) (+ (cadr p1) B) 0)
	(list (car p1) (+ (cadr p1) B) 0)
	(list (car p1) (cadr p1) 0)
 	)
 )
)
((eq bit1 "Circle")
 (setq a (cond (a)
    	(50)
  )
 )
 (setq olda a)
 (setq a (getreal (strcat "\nChon ban kinh Circle <"
 	(rtos olda 2 1)
 	"> : "
	)
  )
 )
 (if (null a)
(setq a olda)
 )
 (setq objCE (vla-addCircle *Model* (vlax-3d-point p1) a))
 (setq cir (entlast))
 (setq cv   (* a 2 pi)
   	lstp (list (vlax-curve-getStartPoint cir))
   	d	(/ cv 160)
   	l	0.0
 )
 (repeat 160
(setq l	(+ l d)
  p	(vlax-curve-getPointAtDist cir l)
  lstp (append lstp (List p))
)
 )
);end bit1 "Circle"

;;; ((eq bit1 "Ellipse")
;;;  (setq a (getpoint p1 "\nPick diem ban kinh lon cua Ellipse"))
;;;  (vl-cmdf ".Ellipse" pause pause pause); erro ttuc
;;;  (setq objCE (entlast)
;;;  p1 (vlax-curve-getStartPoint objCE))
;;;  (command ".LENGTHEN" objCE "")
;;;  (setq cv   (getvar "perimeter")
;;;    	lstp (list p1)
;;;    	d	(/ cv 160)
;;;    	l	0.0
;;;  )
;;;  (repeat 160
;;;	(setq l	(+ l d)
;;;   p	(vlax-curve-getPointAtDist objCE l)
;;;   lstp (append lstp (List p))
;;;	)
;;;  )
;;; );end bit1 "Ellipse"
;;; ((eq bit1 "Different")
;;;  (prompt "\nchon 1 curve kin:")
;;;  (setq ss (ssget)
;;;    	encur (ssname ss 0)
;;;    	objCE (vlax-ename->vla-object encur)
;;;    	p1 (vlax-curve-getStartPoint encur))
;;;  (if (or (eq (dxf 0 encur) "LWPOLYLINE")
;;;   (eq (dxf 0 encur) "POLYLINE")
;;;  	)
;;;	(setq lstp (acet-geom-VERTEX-LIST encur))
;;;	(progn
;;;  	(command ".LENGTHEN" encur "")
;;;  	(setq cv (getvar "perimeter")
;;; 	lstp (list p1)
;;; 	d (/ cv 160)
;;; 	l 0.0
;;;  	)
;;;  	(repeat 160
;;;    	(setq l   (+ l d)
;;;   	p   (vlax-curve-getPointAtDist encur l)
;;;   	lstp (append lstp (List p))
;;;    	)
;;;  	)
;;;	)
;;;  )
;;;  )
 );end cond
 (vla-ZoomExtents (vlax-get-acad-object))
 (ACET-LWPLINE-MAKE (list lstp))
 (setq ss (ssadd (entlast) (ssadd)))
 (setq p2 (ACET-SS-DRAG-MOVE
 	ss
 	(list (car p1) (cadr p1))
 	"Chon vi tri bat dau trich thua: "
)
 )
 (command ".move" ss "" p1 p2)
 (setq encur (entlast)
lstp (acet-geom-VERTEX-LIST encur))
 (setq ss (ssdel encur (ssget "_CP" lstp)))
 (command ".copy" ss "" p2 p2)
 (setq p3 (ACET-SS-DRAG-MOVE
 	(ssadd encur ss)
 	p2
 	"Chon vi tri dat ban do trich thua: "
)
 )
 (command ".move" ss encur "" p2 p3)
 (setvar "cecolor" "0")
 (setq lsten (vl-remove encur (gettouching encur)))
 (break_with  lsten encur)
 (vlax-invoke-method ActDoc 'Regen acActiveViewport)
 (vla-offset (vlax-ename->vla-object encur) (* (getvar "viewsize") 0.0001))
 (setq lstp (acet-geom-vertex-list (entlast)))
 (entdel (entlast))
 (if (equal (vlax-curve-getEndParam encur) 160 1) (entdel encur))
 (setq LenssBR (SS-enlst (ssget "F" lstp)))
 (mapcar '(lambda (x)
 	(if (or (not (eq (dxf 0 x) "TEXT"))
  	(not (eq (dxf 0 x) "MTEXT"))
  )
   	(entdel x)
 	)
)
  LenssBR
 )
 (if objCE (vla-move objCE (vlax-3d-point p1) (vlax-3d-point p3)))
 (vla-EndUndoMark ActDoc)
 (princ "\nChuc cac ban gat hai nhieu thanh cong. Thiep")
 (princ)
)

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
dizangu    5

- cảm ơn bạn rất nhiều. Mình không có điều kiên như bộ lisp bac Lecuong533. nhưng mình nghĩ kết hợp 1 số lisp hay lại cũng giảm được thời gian làm việc

- Thiết kế nút giao của bác ý trong vòng vài phút thật là khâm phục

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Mình thực hiện trên file của bạn luôn nhé.Lisp này của bác thiệp mà bác thanhduan đã nói.Thực hiện được ý đồ của bạn rồi đó.Bạn xem video nhé

http://www.youtube.com/watch?v=UnQZYP3eAtU

Mình muốn xin bộ lisp về thiết kế nút của bạn được không.Bạn có thể gửi lên đây hoặc gửi mail cho mình:anhtuan011185@gmail.com.Cảm ơn bạn rất nhiều vì mình cũng đang cần tiện ích này

;;;-----------------------
(defun SS-enlst (ss / c L)
  (setq c -1)
  (repeat (sslength ss)
	(setq L (cons (ssname ss (setq c (1+ c))) L))
  )
  (reverse L)
)
;;;---------------------- -
(defun Text (model str po h ang / obj)
  (setq obj (vla-AddText
   	*Model*
   	str
   	(vlax-3d-point po)
   	h
 	)
  )
  (vla-put-Alignment obj acAlignmentTopCenter)
  (vla-put-TextAlignmentPoint obj (vlax-3d-point po))
)
;;;====================================================================
(defun break_with (Lstent enL / lst masterlist ss oc break_obj intpts)
  (princ "\nCalculating Break Points, Please Wait.\n")
 
  ;;========================================
  ;; Break entity at break points in list
  ;;========================================
  (defun break_obj (ent brkptlst   /   	brkobjlst  en
   enttype	maxparam   closedobj  minparam
   obj	obj2break  p1param  p2param
   brkpt2	dlst   	idx  brkptS
   brkptE	brkpt  	result  result
   ignore	dist   	tmppt  #ofpts
   enddist	lastent	obj2break  stdist
     	)
 	(setq obj2break ent
	brkobjlst (list ent)
	enttype   (dxf 0 ent)
 	)
	(if (not (or (eq (dxf 0 obj2break) "TEXT")
   (eq (dxf 0 obj2break) "MTEXT")
  	)
)
  	(setq closedobj (vlax-curve-isclosed obj2break))
	)
	(setq spt	(vlax-curve-getstartpoint ent)
   ept	(vlax-curve-getendpoint ent)
   brkptlst (vl-remove-if
   	'(lambda (x)
   (or (< (distance x spt) 0.0001)
   	(< (distance x ept) 0.0001)
   )
    	)
   	brkptlst
 	)
	)
	<img src='http://www.cadviet.com/forum/public/style_emoticons/<#EMO_DIR#>/wink.png' class='bbc_emoticon' alt=';)' />
	(if (and brkptlst
  	(not (or (eq (dxf 0 obj2break) "TEXT")
    	(eq (dxf 0 obj2break) "MTEXT")
	)
  	)
)
  	(progn
(setq brkptlst
    	(mapcar
   '(lambda (x)
  	(list
    	x
    	(vlax-curve-getdistatparam
   obj2break
   (cond
 	((vlax-curve-getparamatpoint obj2break x)
 	)
 	((vlax-curve-getparamatpoint
    	obj2break
    	(vlax-curve-getclosestpointto
      	obj2break
      	x
    	)
  	)
 	)
   )
    	)
  	)
	)
   brkptlst
    	)
)
(setq
   brkptlst (vl-sort brkptlst
   	'(lambda (a1 a2) (< (cadr a1) (cadr a2)))
 	)
)
(foreach brkpt (reverse brkptlst)
 	(setq brkptS (car brkpt)
	brkptE brkptS
 	)
   ;; get last entity created via break in case multiple breaks
   (if brkobjlst
 	(progn
   	(setq tmppt brkptS) ; use only one of the pair of breakpoints
   	;; if pt not on object x, switch objects
   	(if (not (numberp (vl-catch-all-apply
  	'vlax-curve-getdistatpoint
  	(list obj2break tmppt)
	)
     	)
	)
  (progn   ; find the one that pt is on
	(setq idx (length brkobjlst))
	(while
  	(and (not (minusp (setq idx (1- idx))))
	(setq obj (nth idx brkobjlst))
	(if (numberp (vl-catch-all-apply
 	'vlax-curve-getdistatpoint
 	(list obj tmppt)
      	)
    	)
  	(null (setq obj2break obj))
 	; switch objects, null causes exit
  	t
	)
  	)
	)
  )
   	)
 	)
   ); end (if brkobjlst
  
   ;;; Handle any objects that can not be used with the Break Command
   ;;; using one point, gap of 0.000001 is used
   (if (not (or (eq (dxf 0 obj2break) "TEXT")
     	(eq (dxf 0 obj2break) "MTEXT")
 	)
   	)
 	(setq closedobj (vlax-curve-isclosed obj2break))
   )
;;; single breakpoint ----------------------------------------------------
 	(if
   	(and closedobj
 	(not (setq
 	brkptE (vlax-curve-getPointAtDist
   	obj2break
   	(+ (vlax-curve-getdistatparam
 	obj2break
 	(cond
   	((vlax-curve-getparamatpoint
      	obj2break
      	brkpts
    	)
   	)
   	((vlax-curve-getparamatpoint
      	obj2break
      	(vlax-curve-getclosestpointto
        	obj2break
        	brkpts
      	)
    	)
   	)
 	)
      	)
      	0.00001
   	)
 	)
   )
 	)
   	)
    	(setq
   brkptE (vlax-curve-getPointAtDist
 	obj2break
 	(- (vlax-curve-getdistatparam
      	obj2break
      	(cond ((vlax-curve-getparamatpoint
 	obj2break
 	brkpts
      	)
     	)
     	((vlax-curve-getparamatpoint
 	obj2break
 	(vlax-curve-getclosestpointto
   	obj2break
   	brkpts
 	)
      	)
     	)
      	)
    	)
    	0.00001
 	)
   )
    	); end setq brkptE
 	); end fi (and closedobj
   ;; (if (null brkptE) (princ)) ; debug
   (setq LastEnt (GetLastEnt))
   (if (not (or (eq (dxf 0 obj2break) "TEXT")
     	(eq (dxf 0 obj2break) "MTEXT")
 	)
   	)
 	(command "._break"
   	obj2break
   	"_non"
   	(trans brkptS 0 1)
   	"_non"
   	(trans brkptE 0 1)
 	)
   )
   (and (= "CIRCLE" enttype) (setq enttype "ARC"))
   (if (and (not closedobj) ; new object was created
 	(not (equal LastEnt (entlast)))
   	)
 	(setq brkobjlst (cons (entlast) brkobjlst))
   ); end (if (and
); end (foreach brkpt
  	);end progn brkptlst
	); end if brkptlst
  ); defun break_obj
  ;;====================================
  ;; CAB - get last entity in datatbase
  (defun GetLastEnt (/ ename result)
	(if (setq result (entlast))
  	(while (setq ename (entnext result))
(setq result ename)
  	)
	)
	result
  )
  ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  ;; S T A R T          	S U B R O U T I N E         	H E R E
  ;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(if (and Lstent enL)
	(progn
  	;; CREATE a list of entity & it's break points
  	(foreach en Lstent
 	; check each object in Lstent
(if (not (acet-layer-locked (dxf 8 en)))
   (progn
 	(setq lst nil)
 	;; check for break pts with other objects in Lstentwith
 	(if (and (not (equal en enint))
   	(setq intpts (acet-geom-intersectwith en enL 0))
  )
   	(setq lst (append intpts lst))
 	; entity w/ break points
 	)
 	(if lst
   	(setq masterlist
   	(cons (cons en lst) masterlist)
   	)
 	)
   )
)
  	)
  	(princ "\nBreaking Objects.\n")
  	(if masterlist
(progn
   (acet-ui-progress "hoan thanh %" (length masterlist))
   (foreach obj2brk masterlist
 	(break_obj (car obj2brk) (cdr obj2brk))
 	(acet-ui-progress -1)
   )
   (acet-ui-progress)
)
  	)
	)
  )
);end break_with
;;===========================================================================
;; get all objects touching entities in the sscross
;; limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
;; returns a list of enames
;;===========================================================================
(defun gettouching (en / ss lst lstb lstc objl)
  (and
	(setq objl (vlax-ename->vla-object en))
	(setq
  	ss
   	(ssget
  "_A"
  (list
	(cons 0
   "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
	)
	(cons 410 (getvar "ctab"))
  )
   	)
	)
	(setq lst (SS-enlst ss)
 	lst (mapcar 'vlax-ename->vla-object lst))
	(mapcar
  	'(lambda (x)
  (if (not
    	(vl-catch-all-error-p
   (vl-catch-all-apply
 	'(lambda ()
    	(vlax-safearray->list
   (vlax-variant-value
 	(vla-intersectwith objl x acextendnone)
   )
    	)
  	)
   )
    	)
  	)
	(setq lstc (cons (vlax-vla-object->ename x) lstc))
  )
   	)
  	lst
	)
  )
  lstc
)
;;;------------------------------------------------
(defun LWP (Lpoint *Model* / PntArr)
  (setq PntArr (vlax-make-safearray
   vlax-vbDouble
   (cons 0 (1- (length Lpoint)))
    	)
  )
  (vlax-safearray-fill PntArr Lpoint)
  (vla-AddLightWeightPolyline *Model* PntArr)
)
;;;------------------------------------------------
(defun DXF (code en) (cdr (assoc code (entget en))))
;;;============================================================
;;;=======================MAIN LISP============================
;;;============================================================
(defun c:trichBD (/ ActDoc *Model* ss encur lsten p1 p2 p3 LenssBR lstp objCE)
  (setq ActDoc (vla-get-ActiveDocument (vlax-get-acad-object))
*Model* (vla-get-ModelSpace ActDoc)
  )
  (setq bit1 (cond (bit1)
	("Rectangle")
 	)
  )
  (initget "Square Rectangle Circle Ellipse Different")
  (setq tmp (strcat "\nChon duong bao: [square/Rectangle/Circle/Ellipse/Different] <" bit1 ">: ")
bit1	(cond ((getkword tmp))
   	(bit1)
    	)
  )
  (vla-StartUndoMark ActDoc)
  (setvar "cecolor" "104")
  (setq p1 (list (car (getvar "extmin")) (cadr (getvar "extmin"))))
  (cond ((eq bit1 "Square")
  (setq a (cond (a)
     	(50)
   )
  )
  (setq olda a)
  (setq a (getreal (strcat "\nChon kich thuoc canh Square <"
  	(rtos olda 2 1)
  	"> : "
 	)
   )
  )
  (if (null a)
	(setq a olda)
  )
  (setq lstp (list (list (car p1) (cadr p1) 0)
 	(list (+ (car p1) a) (cadr p1) 0)
 	(list (+ (car p1) a) (+ (cadr p1) a) 0)
 	(list (car p1) (+ (cadr p1) a) 0)
 	(list (car p1) (cadr p1) 0)
  	)
  )
)
((eq bit1 "Rectangle")
  (setq a (cond (a)
     	(50)
   )
  )
  (setq olda a)
  (setq a (getreal (strcat "\nChon chieu dai Rectangle <"
  	(rtos olda 2 1)
  	"> : "
 	)
   )
  )
  (if (null a)
	(setq a olda)
  )
  (setq b (cond (<img src='http://www.cadviet.com/forum/public/style_emoticons/<#EMO_DIR#>/cool.png' class='bbc_emoticon' alt='B)' />
     	(50)
   )
  )
  (setq oldb <img src='http://www.cadviet.com/forum/public/style_emoticons/<#EMO_DIR#>/cool.png' class='bbc_emoticon' alt='B)' />
  (setq b (getreal (strcat "\nChon chieu rong Rectangle <"
  	(rtos oldb 2 1)
  	"> : "
 	)
   )
  )
  (if (null <img src='http://www.cadviet.com/forum/public/style_emoticons/<#EMO_DIR#>/cool.png' class='bbc_emoticon' alt='B)' />
	(setq b oldb)
  )
  (setq lstp (list (list (car p1) (cadr p1) 0)
 	(list (+ (car p1) a) (cadr p1) 0)
 	(list (+ (car p1) a) (+ (cadr p1) <img src='http://www.cadviet.com/forum/public/style_emoticons/<#EMO_DIR#>/cool.png' class='bbc_emoticon' alt='B)' /> 0)
 	(list (car p1) (+ (cadr p1) <img src='http://www.cadviet.com/forum/public/style_emoticons/<#EMO_DIR#>/cool.png' class='bbc_emoticon' alt='B)' /> 0)
 	(list (car p1) (cadr p1) 0)
  	)
  )
)
((eq bit1 "Circle")
  (setq a (cond (a)
     	(50)
   )
  )
  (setq olda a)
  (setq a (getreal (strcat "\nChon ban kinh Circle <"
  	(rtos olda 2 1)
  	"> : "
 	)
   )
  )
  (if (null a)
	(setq a olda)
  )
  (setq objCE (vla-addCircle *Model* (vlax-3d-point p1) a))
  (setq cir (entlast))
  (setq cv   (* a 2 pi)
    	lstp (list (vlax-curve-getStartPoint cir))
    	d	(/ cv 160)
    	l	0.0
  )
  (repeat 160
	(setq l	(+ l d)
   p	(vlax-curve-getPointAtDist cir l)
   lstp (append lstp (List p))
	)
  )
);end bit1 "Circle"

;;; ((eq bit1 "Ellipse")
;;;  (setq a (getpoint p1 "\nPick diem ban kinh lon cua Ellipse"))
;;;  (vl-cmdf ".Ellipse" pause pause pause); erro ttuc
;;;  (setq objCE (entlast)
;;;  p1 (vlax-curve-getStartPoint objCE))
;;;  (command ".LENGTHEN" objCE "")
;;;  (setq cv   (getvar "perimeter")
;;;    	lstp (list p1)
;;;    	d	(/ cv 160)
;;;    	l	0.0
;;;  )
;;;  (repeat 160
;;;	(setq l	(+ l d)
;;;   p	(vlax-curve-getPointAtDist objCE l)
;;;   lstp (append lstp (List p))
;;;	)
;;;  )
;;; );end bit1 "Ellipse"
;;; ((eq bit1 "Different")
;;;  (prompt "\nchon 1 curve kin:")
;;;  (setq ss (ssget)
;;;    	encur (ssname ss 0)
;;;    	objCE (vlax-ename->vla-object encur)
;;;    	p1 (vlax-curve-getStartPoint encur))
;;;  (if (or (eq (dxf 0 encur) "LWPOLYLINE")
;;;   (eq (dxf 0 encur) "POLYLINE")
;;;  	)
;;;	(setq lstp (acet-geom-VERTEX-LIST encur))
;;;	(progn
;;;  	(command ".LENGTHEN" encur "")
;;;  	(setq cv (getvar "perimeter")
;;; 	lstp (list p1)
;;; 	d (/ cv 160)
;;; 	l 0.0
;;;  	)
;;;  	(repeat 160
;;;    	(setq l   (+ l d)
;;;   	p   (vlax-curve-getPointAtDist encur l)
;;;   	lstp (append lstp (List p))
;;;    	)
;;;  	)
;;;	)
;;;  )
;;;  )
  );end cond
  (vla-ZoomExtents (vlax-get-acad-object))
  (ACET-LWPLINE-MAKE (list lstp))
  (setq ss (ssadd (entlast) (ssadd)))
  (setq p2 (ACET-SS-DRAG-MOVE
  	ss
  	(list (car p1) (cadr p1))
  	"Chon vi tri bat dau trich thua: "
	)
  )
  (command ".move" ss "" p1 p2)
  (setq encur (entlast)
lstp (acet-geom-VERTEX-LIST encur))
  (setq ss (ssdel encur (ssget "_CP" lstp)))
  (command ".copy" ss "" p2 p2)
  (setq p3 (ACET-SS-DRAG-MOVE
  	(ssadd encur ss)
  	p2
  	"Chon vi tri dat ban do trich thua: "
	)
  )
  (command ".move" ss encur "" p2 p3)
  (setvar "cecolor" "0")
  (setq lsten (vl-remove encur (gettouching encur)))
  (break_with  lsten encur)
  (vlax-invoke-method ActDoc 'Regen acActiveViewport)
  (vla-offset (vlax-ename->vla-object encur) (* (getvar "viewsize") 0.0001))
  (setq lstp (acet-geom-vertex-list (entlast)))
  (entdel (entlast))
  (if (equal (vlax-curve-getEndParam encur) 160 1) (entdel encur))
  (setq LenssBR (SS-enlst (ssget "F" lstp)))
  (mapcar '(lambda (x)
  	(if (or (not (eq (dxf 0 x) "TEXT"))
   	(not (eq (dxf 0 x) "MTEXT"))
   )
    	(entdel x)
  	)
	)
   LenssBR
  )
  (if objCE (vla-move objCE (vlax-3d-point p1) (vlax-3d-point p3)))
  (vla-EndUndoMark ActDoc)
  (princ "\nChuc cac ban gat hai nhieu thanh cong. Thiep")
  (princ)
)

Anh cd2k44 ơi cho em hỏi chút, cái lisp này lệnh là trichbd phải ko ạ? em laod về, ap vô cad mà nó unknown. giúp em với ạ

thanks anh

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
VUVUZELA    98

Bạn có thể download chương trình này về dùng thử

http://www.mediafire.com/download/n4647119m77nd31/Nutgiaothong+V3.1+%28DEMO%29.rar

Chạy setup, đánh pass : LECUONG

Vào Autocad load file *.VLX ở thư mục cài đặt lên thì sẽ có MENU load tự động trên nền AUtocad

Version mới này có cập nhật thêm tính năng vẽ đường đồng mức trong nút và giả lập Nova trên các phần mềm khác như ADS, Addesign ...

Có thể xem file hướng dẫn sử dụng PDF ở thư mục cài đặt nhé

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay


×