Đến nội dung


Hình ảnh
- - - - -

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


  • Please log in to reply
10 replies to this topic

#1 dizangu

dizangu

    biết vẽ line

  • Members
  • PipPip
  • 25 Bài viết
Điểm đánh giá: 5 (bình thường)

Đã gửi 09 September 2011 - 08:17 AM

- 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
  • -1

#2 cd2k44

cd2k44

    Edu level: li5

  • Members
  • PipPipPipPipPipPipPip
  • 648 Bài viết
Điểm đánh giá: 121 (tàm tạm)

Đã gửi 09 September 2011 - 10:00 AM

nếu chỉ vậy thì bạn dùng lệnh copy cũng được cơ mà
  • 0

#3 dizangu

dizangu

    biết vẽ line

  • Members
  • PipPip
  • 25 Bài viết
Điểm đánh giá: 5 (bình thường)

Đã gửi 09 September 2011 - 11:12 AM

ý 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 đó.
  • 0

#4 dizangu

dizangu

    biết vẽ line

  • Members
  • PipPip
  • 25 Bài viết
Điểm đánh giá: 5 (bình thường)

Đã gửi 09 September 2011 - 12:14 PM

- Ý tưởng của mình là sau đó lisp gán luôn các mũi tên hương đường
- lisp thông số nút mình đã có để tk nút. như hình vẽ. rất mong các anh em giúp đỡ ( cám ơn cd2k44 đã quan tâm )
http://www.mediafire...sgh4nas1yjlovmb
  • 0

#5 gia_bach

gia_bach

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 1435 Bài viết
Điểm đánh giá: 1426 (rất tốt)

Đã gửi 09 September 2011 - 12:27 PM

- 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
  • 1

#6 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 993 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 09 September 2011 - 01:07 PM

bạn có thể tìm kiếm với lisp trichthua.lsp của bác Thiep. Lisp đó kết hợp giữa copy và extrim. Bạn tìm thử xem
  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#7 dizangu

dizangu

    biết vẽ line

  • Members
  • PipPip
  • 25 Bài viết
Điểm đánh giá: 5 (bình thường)

Đã gửi 09 September 2011 - 02:51 PM

- 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
  • 0

#8 cd2k44

cd2k44

    Edu level: li5

  • Members
  • PipPipPipPipPipPipPip
  • 648 Bài viết
Điểm đánh giá: 121 (tàm tạm)

Đã gửi 09 September 2011 - 03:07 PM

- 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)
)

  • 0

#9 dizangu

dizangu

    biết vẽ line

  • Members
  • PipPip
  • 25 Bài viết
Điểm đánh giá: 5 (bình thường)

Đã gửi 09 September 2011 - 03:46 PM

- 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
  • 0

#10 minhhieuthanh

minhhieuthanh

    biết zoom

  • Members
  • Pip
  • 13 Bài viết
Điểm đánh giá: -1 (bình thường)

Đã gửi 30 June 2014 - 10:35 AM

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.c...h?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


  • 0

#11 VUVUZELA

VUVUZELA

    biết lệnh chamfer

  • Members
  • PipPipPipPip
  • 210 Bài viết
Điểm đánh giá: 97 (tàm tạm)

Đã gửi 30 June 2014 - 10:54 AM

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

http://www.mediafire...V3.1 (DEMO).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é


  • 0

Hệ thống Liên Kết, Thiết Kế Tự Động

ttps://www.facebook...etThietKeTuDong