Jump to content
InfoFile
Tác giả: DaiBang
Bài viết gốc: 2
Tên lệnh: fixtext
Chuyển text từ mã font %% sang text thường

Một vài file CAD có định dạng Text trong file được tạo nên từ các ký tự Ascii có cấu trúc %%xxx. Chính vì vậy hiển thị trong CAD vẫn ngon lành, tuy nhiên nội dung của text là lộn xộn. Lisp này giúp bạn sửa lỗi text trên

Filename: 2_fixtext.lsp
Tác giả: cd2k44
Bài viết gốc: 168488
Tên lệnh: trichbd
Lisp Copy đường Bình đồ Từ Tim Tuyến

Bạn ketxu có thời gian thì chỉnh lại lisp trích thửa của bác thiệp thì sẽ thực hiện được yêu cầu của bạn này.Lisp của bác thiệp làm được việc bạn muốn chỉ có điều đường bao mà bạn mong muốn thì bác thiệp đã cố định nó là khung chữ nhật hoặc elisp... chứ không có chức năng chọn đường bao như bạn yêu cầu.Mình post lisp đó lên bạn có thể nhờ chính tác giả hoặc các anh...
>>

Bạn ketxu có thời gian thì chỉnh lại lisp trích thửa của bác thiệp thì sẽ thực hiện được yêu cầu của bạn này.Lisp của bác thiệp làm được việc bạn muốn chỉ có điều đường bao mà bạn mong muốn thì bác thiệp đã cố định nó là khung chữ nhật hoặc elisp... chứ không có chức năng chọn đường bao như bạn yêu cầu.Mình post lisp đó lên bạn có thể nhờ chính tác giả hoặc các anh trong diễn đàn chỉnh sửa lisp này cho phù hợp yêu cầu của bạn
;;;-----------------------
(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: <" 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)
)

Ngoài ra nếu bạn có thể sử dụng lisp sau của bác gia_bach

(defun c:CWB (/ ov vl bit ss cur ssInside ssOutside ssN ssT ssAll curT plSet) ;CWB -> Copy With Boundary
(defun *error* (msg)
(if ov (mapcar 'setvar vl ov)) ; reset Sys vars
(princ (strcat "\n<< Error: " msg " >>")) ; Print Error Message
(princ) ; Exit Cleanly
)
(command "_.undo" "_begin")
(setq vl '("CMDECHO" "OSMODE" "ORTHOMODE") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(mapcar 'setvar vl '(0 0 0)) ; Turn off CMDECHO, OSMODE, ORTHOMODE
(initget "T N")
(setq bit (getkword "\nBan muon chon Trong hay Ngoai duong bao <T/N>: " ) )
(princ"\n<<< Chon duong bao >>> ")
(setq ss (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE")))
cur (ssname ss 0))
(setq p1 (vlax-curve-getStartPoint cur)
p2 (getpoint p1 "\nDiem den :"))
(command "_copy" cur "" p1 p2)
(if (and (setq lstTouching (gettouching ss))
(setq ssTouching (ssadd))
(mapcar '(lambda (x) (ssadd x ssTouching)) lstTouching)
)
(progn
(command "_copy" ssTouching "" p1 p1)
(setq temp (ssget "p"))
(unvisible ssTouching)
(setq ssTouching temp)
)
)
(if (= bit "T") ;chon Trong duong bao
(progn
(setq ptLst (GetPtLst cur)
ssInside (ssget "_WP" ptLst ) )
(if ssInside
(command "_copy" ssInside "" p1 p2 )
)
(if (and (setq ssInside (GetssBreak ss "in"))
(> (sslength ssInside) 0))
(command "_move" ssInside "" p1 p2 )
)
)
(progn ;(= bit "N") ;chon Ngoai duong bao
;chi chon doi tuong Giao voi duong bao
(if (and (setq ssOutside (GetssBreak ss "out"))
(> (sslength ssOutside) 0))
(command "_move" ssOutside "" p1 p2 )
)
);;chon Ngoai duong bao
);cond
(Visible)
(mapcar 'setvar vl ov) ; reset Sys Vars
(command "_.undo" "_end")
(princ)
)
(defun GetssBreak (ss2 opt / ptLst cur ssInside lstss1 ss1)
(if (and (setq lstss1 (gettouching ss2))
(setq ss1 (ssadd))
(mapcar '(lambda (x) (ssadd x ss1)) lstss1)
)
(progn ; co ssTouching
(break_with ss1 ss2 nil 0)
(setq cur (ssname ss2 0)
ssBreak (ssadd))
(mapcar '(lambda (x) (ssadd x ssBreak)) (gettouching ss2))
;loc ssTouching -> ssOutside
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssBreak)))
(if (= opt "in")
(if
(or
(not(insidep (vlax-curve-getStartPoint e) cur))
(not(insidep (vlax-curve-getEndPoint e) cur))
(not(insidep (vlax-curve-getPointAtParam e (/(+(vlax-curve-getStartParam e)(vlax-curve-getEndParam e))2)) cur))
);or
(entdel e)
)
(if ;(= opt "out")
(and (insidep (vlax-curve-getStartPoint e) cur)
(insidep (vlax-curve-getEndPoint e) cur)
(insidep (vlax-curve-getPointAtParam e (/(+(vlax-curve-getStartParam e)(vlax-curve-getEndParam e))2)) cur)
);and
(entdel e)
)
);if
);foreach
);progn
);if
(if (ssmemb cur ssBreak) (ssdel cur ssBreak))
ssBreak
)
;;;(defun GetssInside (ss2 / ptLst cur ssInside lstss1 ss1 ssTouching)
;;; (if (and (setq lstss1 (gettouching ss2))
;;; (setq ss1 (ssadd))
;;; (mapcar '(lambda (x) (ssadd x ss1)) lstss1)
;;; )
;;; (progn ; co ssTouching
;;; (break_with ss1 ss2 nil 0)
;;; (setq ssTouching (ssadd))
;;; (mapcar '(lambda (x) (ssadd x ssTouching)) (gettouching ss2))
;;; ;loc ssTouching -> ssInside
;;; (or ssInside (setq ssInside (ssadd)) )
;;; (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssTouching)))
;;; (if
;;; (and (insidep (vlax-curve-getStartPoint e) cur)
;;; (insidep (vlax-curve-getEndPoint e) cur)
;;; (insidep (vlax-curve-getPointAtParam e (/(+(vlax-curve-getStartParam e)(vlax-curve-getEndParam e))2)) cur)
;;; )
;;; (ssadd e ssInside)
;;; (entdel e)
;;; );if
;;; );foreach
;;; );progn
;;; );if
;;; (if (ssmemb cur ssInside) (ssdel cur ssInside))
;;; ssInside
;;; )

(defun GetPtLst (obj / startparam endparam anginc delta div inc pt ptlst)
(defun ZClosed (lst)
(if (and (vlax-curve-isClosed obj)
(not(equal (car lst)(last lst) 1e-6)))
(append lst (list (car lst)))
lst))

(or (eq (type obj) 'VLA-OBJECT)
(setq obj (vlax-ename->vla-object obj)))
(setq typ (vlax-get obj 'ObjectName))
(if (or (eq typ "AcDbCircle") (eq typ "AcDbEllipse"))
(progn
(setq param 0)
(while (< param (* pi 2))
(setq pt (vlax-curve-getPointAtParam obj param)
ptlst (cons pt ptlst)
param (+ (/ (* pi 2) 72) param))
)
(reverse ptlst)
)
(progn ;Pline (eq typ "AcDbPolyline")
(setq param (vlax-curve-getStartParam obj)
endparam (vlax-curve-getEndParam obj)
anginc (* pi (/ 7.5 180.0)))
(setq tparam param)
(while (<= param endparam)
(setq pt (vlax-curve-getPointAtParam obj param))
(if (not (equal pt (car ptlst) 1e-12))
(setq ptlst (cons pt ptlst)))
(if (and (/= param endparam)
(setq blg (abs (vlax-invoke obj 'GetBulge param)))
(/= 0 blg))
(progn
(setq delta (* 4 (atan blg)) ;included angle
inc (/ 1.0 (1+ (fix (/ delta anginc))))
arcparam (+ param inc))
(while (< arcparam (1+ param))
(setq pt (vlax-curve-getPointAtParam obj arcparam)
ptlst (cons pt ptlst)
arcparam (+ inc arcparam))))
)
(setq param (1+ param))
)
(if (and (apply 'and ptlst)
(> (length ptlst) 1))
(ZClosed (reverse ptlst))
)
)
)
)

;; Copyright (c) 2009, Lee McDonnell
;; (Contact Lee Mac, CADTutor.net)
(defun insidep (pt Obj / Obj Tol ang doc spc flag int lin xV yV)
(defun vlax-list->3D-point (lst flag)
(if lst
(cons ((if flag car cadr) lst)
(vlax-list->3D-point (cdddr lst) flag))))
(or (eq 'VLA-OBJECT (type Obj))
(setq Obj (vlax-ename->vla-object Obj)))
(if (not(vlax-curve-getParamAtPoint Obj pt))
(progn
(setq Tol (/ pi 6) ; Uncertainty
ang 0.0 flag T)
(setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object))
spc (if (zerop (vla-get-activespace doc))
(if (= (vla-get-mspace doc) :vlax-true)
(vla-get-modelspace doc)
(vla-get-paperspace doc))
(vla-get-modelspace doc)))
(while (and (< ang (* 2 pi)) flag)
(setq flag (and
(setq int
(vlax-invoke
(setq lin
(vla-addLine spc
(vlax-3D-point pt)
(vlax-3D-point
(polar pt ang
(if (vlax-property-available-p Obj 'length)
(vla-get-length Obj) 1.0)))))
'IntersectWith Obj
acExtendThisEntity))
(<= 6 (length int))
(setq xV (vl-sort (vlax-list->3D-point int T) '<)
yV (vl-sort (vlax-list->3D-point int nil) '<))
(or (<= (car xV) (car pt) (last xV))
(<= (car yV) (cadr pt) (last yV))))
ang (+ ang Tol))
(vla-delete lin))
flag
)
T
))

;;; Author: Copyright&#169; 2006-2008 Charles Alan Butler
;;; Contact @ www.TheSwamp.org
;;===========================================================================
;; 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 (sscros / ss lst lstb lstc objl)
(and
(setq lstb (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscros)))
objl (mapcar 'vlax-ename->vla-object lstb)
)
(setq ss (ssget "_A" (list '(-4 . "<AND")
'(-4 . "<NOT") '(60 . 1) '(-4 . "NOT>")
'(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 410 (getvar "ctab"))
'(-4 . "AND>")
)
)
)
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq lst (mapcar 'vlax-ename->vla-object lst))
(mapcar
'(lambda (x)
(mapcar
'(lambda (y)
(if (not
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(vlax-safearray->list
(vlax-variant-value
(vla-intersectwith y x acextendnone)
))))))
(setq lstc (cons (vlax-vla-object->ename x) lstc))
)
) objl)
) lst)
)
lstc
)
;;; Author: Copyright&#169; 2006-2008 Charles Alan Butler
;;; Contact @ www.TheSwamp.org
(defun break_with (ss2brk ss2brkwith self Gap / cmd intpts lst masterlist ss ssobjs
onlockedlayer ssget->vla-list list->3pair GetNewEntities oc
get_interpts break_obj GetLastEnt LastEntInDatabase ss2brkwithList
)
;; ss2brk selection set to break
;; ss2brkwith selection set to use as break points
;; self when true will allow an object to break itself
;; note that plined will break at each vertex
;;
;; return list of enames of new objects
(vl-load-com)
(princ "\nCalculating Break Points, Please Wait.\n")
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S U B F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; return T if entity is on a locked layer
(defun onlockedlayer (ename / entlst)
(setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
(= 4 (logand 4 (cdr (assoc 70 entlst))))
)
;; return a list of objects from a selection set
;| (defun ssget->vla-list (ss)
(mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss ))))
)|;
(defun ssget->vla-list (ss / i ename allobj) ; this is faster, changed in ver 1.7
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(setq allobj (cons (vlax-ename->vla-object ename) allobj))
)
allobj
)

;; return a list of lists grouped by 3 from a flat list
(defun list->3pair (old / new)
(while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
old (cdddr old)))
(reverse new)
)

;;=====================================
;; return a list of intersect points
;;=====================================
(defun get_interpts (obj1 obj2 / iplist)
(if (not (vl-catch-all-error-p
(setq iplist (vl-catch-all-apply
'vlax-safearray->list
(list
(vlax-variant-value
(vla-intersectwith obj1 obj2 acextendnone)
))))))
iplist
)
)
;;========================================
;; Break entity at break points in list
;;========================================
(defun break_obj (ent brkptlst BrkGap / brkobjlst en enttype maxparam closedobj
minparam obj obj2break p1param p2param brkpt2 dlst idx brkptS
brkptE brkpt result GapFlg result ignore dist tmppt
#ofpts 2gap enddist lastent obj2break stdist
)
(or BrkGap (setq BrkGap 0.0)) ; default to 0
(setq BrkGap (/ BrkGap 2.0)) ; if Gap use 1/2 per side of break point

(setq obj2break ent
brkobjlst (list ent)
enttype (cdr (assoc 0 (entget ent)))
GapFlg (not (zerop BrkGap)) ; gap > 0
closedobj (vlax-curve-isclosed obj2break)
)
;; when zero gap no need to break at end points
(if (zerop Brkgap)
(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 brkptlst
(progn
;; sort break points based on the distance along the break object
;; get distance to break point, catch error if pt is off end
;; ver 2.0 fix - added COND to fix break point is at the end of a
;; line which is not a valid break but does no harm
(setq brkptlst (mapcar '(lambda(x) (list x (vlax-curve-getdistatparam obj2break
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break x))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break x))))))
) brkptlst))
;; sort primary list on distance
(setq brkptlst (vl-sort brkptlst '(lambda (a1 a2) (< (cadr a1) (cadr a2)))))

(if GapFlg ; gap > 0
;; Brkptlst starts as the break point and then a list of pairs of points
;; is creates as the break points
(progn
;; create a list of list of break points
;; ((idx# stpoint distance)(idx# endpoint distance)...)
(setq idx 0)
(foreach brkpt brkptlst

;; ----------------------------------------------------------
;; create start break point, then create end break point
;; ((idx# startpoint distance)(idx# endpoint distance)...)
;; ----------------------------------------------------------
(setq dist (cadr brkpt)) ; distance to center of gap
;; subtract gap to get start point of break gap
(cond
((and (minusp (setq stDist (- dist BrkGap))) closedobj )
(setq stdist (+ (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break)) stDist))
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
((minusp stDist) ; off start of object so get startpoint
(setq dlst (cons (list idx (vlax-curve-getstartpoint obj2break) 0.0) dlst))
)
(t
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
)
;; add gap to get end point of break gap
(cond
((and (> (setq stDist (+ dist BrkGap))
(setq endDist (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break)))) closedobj )
(setq stdist (- stDist endDist))
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
((> stDist endDist) ; off end of object so get endpoint
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getendparam obj2break))
endDist) dlst))
)
(t
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
)
;; -------------------------------------------------------
(setq idx (1+ IDX))
) ; foreach brkpt brkptlst

(setq dlst (reverse dlst))
;; remove the points of the gap segments that overlap
(setq idx -1
2gap (* BrkGap 2)
#ofPts (length Brkptlst)
)
(while (<= (setq idx (1+ idx)) #ofPts)
(cond
((null result) ; 1st time through
(setq result (list (car dlst)) ; get first start point
result (cons (nth (1+(* idx 2)) dlst) result))
)
((= idx #ofPts) ; last pass, check for wrap
(if (and closedobj (> #ofPts 1)
(<= (+(- (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break))
(cadr (last BrkPtLst))) (cadar BrkPtLst)) 2Gap))
(progn
(if (zerop (rem (length result) 2))
(setq result (cdr result)) ; remove the last end point
)
;; ignore previous endpoint and present start point
(setq result (cons (cadr (reverse result)) result) ; get last end point
result (cdr (reverse result))
result (reverse (cdr result)))
)
)
)
;; Break Gap Overlaps
((< (cadr (nth idx Brkptlst)) (+ (cadr (nth (1- idx) Brkptlst)) 2Gap))
(if (zerop (rem (length result) 2))
(setq result (cdr result)) ; remove the last end point
)
;; ignore previous endpoint and present start point
(setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get present end point
)
;; Break Gap does Not Overlap previous point
(t
(setq result (cons (nth (* idx 2) dlst) result)) ; get this start point
(setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get this end point
)
) ; end cond stmt
) ; while

(setq dlst (reverse result)
brkptlst nil)
(while dlst ; grab the points only
(setq brkptlst (cons (list (cadar dlst)(cadadr dlst)) brkptlst)
dlst (cddr dlst))
)
)
)
;; -----------------------------------------------------
;; (if (equal a ent) (princ)) ; debug CAB -------------

(foreach brkpt (reverse brkptlst)
(if GapFlg ; gap > 0
(setq brkptS (car brkpt)
brkptE (cadr brkpt))
(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
)
)
)
)
)
)
)
(setq closedobj (vlax-curve-isclosed obj2break))
(if GapFlg ; gap > 0
(if closedobj
(progn ; need to break a closed object
(setq brkpt2 (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getDistAtPoint obj2break brkptE) 0.00001)))
(command "._break" obj2break "_non" (trans brkpt2 0 1)
"_non" (trans brkptE 0 1))
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(setq BrkptE brkpt2)
)
)
(if (and closedobj
(not (setq brkptE (vlax-curve-getPointAtDist obj2break
(+ (vlax-curve-getdistatparam obj2break
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))))
;; ver 2.0 fix
(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
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001)))
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break brkpts))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))
)
) ; endif

;; (if (null brkptE) (princ)) ; debug

(setq LastEnt (GetLastEnt))
(command "._break" obj2break "_non" (trans brkptS 0 1) "_non" (trans brkptE 0 1))
(and *BrkVerbose* (princ (setq *brkcnt* (1+ *brkcnt*))) (princ "\r"))
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(if (and (not closedobj) ; new object was created
(not (equal LastEnt (entlast))))
(setq brkobjlst (cons (entlast) brkobjlst))
)
)
)
) ; endif 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
)
;;===================================
;; CAB - return a list of new enames
(defun GetNewEntities (ename / new)
(cond
((null ename) (alert "Ename nil"))
((eq 'ENAME (type ename))
(while (setq ename (entnext ename))
(if (entget ename) (setq new (cons ename new)))
)
)
((alert "Ename wrong type."))
)
new
)

;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S T A R T S U B R O U T I N E H E R E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

(setq LastEntInDatabase (GetLastEnt))
(if (and ss2brk ss2brkwith)
(progn
(setq oc 0
ss2brkwithList (ssget->vla-list ss2brkwith))
(if (> (* (sslength ss2brk)(length ss2brkwithList)) 5000)
(setq *BrkVerbose* t)
)
(and *BrkVerbose*
(princ (strcat "Objects to be Checked: "
(itoa (* (sslength ss2brk)(length ss2brkwithList))) "\n")))
;; CREATE a list of entity & it's break points
(foreach obj (ssget->vla-list ss2brk) ; check each object in ss2brk
(if (not (onlockedlayer (vlax-vla-object->ename obj)))
(progn
(setq lst nil)
;; check for break pts with other objects in ss2brkwith
(foreach intobj ss2brkwithList
(if (and (or self (not (equal obj intobj)))
(setq intpts (get_interpts obj intobj))
)
(setq lst (append (list->3pair intpts) lst)) ; entity w/ break points
)
(and *BrkVerbose* (princ (strcat "Objects Checked: " (itoa (setq oc (1+ oc))) "\r")))
)
(if lst
(setq masterlist (cons (cons (vlax-vla-object->ename obj) lst) masterlist))
)
)
)
)
(and *BrkVerbose* (princ "\nBreaking Objects.\n"))
(setq *brkcnt* 0) ; break counter
;; masterlist = ((ent brkpts)(ent brkpts)...)
(if masterlist
(foreach obj2brk masterlist
(break_obj (car obj2brk) (cdr obj2brk) Gap)
)
)
)
)
;;==============================================================
(and (zerop *brkcnt*) (princ "\nNone to be broken."))
(setq *BrkVerbose* nil)
(GetNewEntities LastEntInDatabase) ; return list of enames of new objects
)
(defun unvisible (objSet)
(vl-load-com)
(foreach obj (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr(ssnamex objSet))))
(vl-catch-all-error-p
(vl-catch-all-apply
'vla-put-visible
(list obj :vlax-false)))
)
(princ)
)
(defun visible(/ objSet)
(vl-load-com)
(setq objSet (ssget "_X" '((60 . 1))))
(if objSet
(foreach obj (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr(ssnamex objSet))))
(vl-catch-all-error-p
(vl-catch-all-apply
'vla-put-visible
(list obj :vlax-true)))
)
)
(princ)
)

<<

Filename: 168488_trichbd.lsp
Tác giả: ketxu
Bài viết gốc: 168515
Tên lệnh: add-hatch
Lisp gộp Hatch Pattern



Lisp add toàn bộ Hatch Pattern trong các file PAT từ 1 thư mục (và các thư mục con) vào bảng Hatch của CAD

Filename: 168515_add-hatch.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 168526
Tên lệnh: copart
Lisp Copy đường Bình đồ Từ Tim Tuyến

Hề hề hề,
bạn dùng thử cái này coi đã ưng ý chưa hè,


Chúc bạn vui.

Hề hề hề, chán quá, thẻ code của diễn đàn bị lỗi. Bạn hãy lưu ý rằng các dấu (') phải được thay thế bằng các dấu (") nhé.
Nếu không được bạn cho địa chỉ mail mình sẽ gửi file cho .

Filename: 168526_copart.lsp
Tác giả: gia_bach
Bài viết gốc: 168522
Tên lệnh: swe
Copy đường Bình đồ Từ Tim Tuyến
Lisp Vẽ đuờng bao và chọn các đối tượng giao với đuờng bao này.

Filename: 168522_swe.lsp
Tác giả: Tue_NV
Bài viết gốc: 94331
Tên lệnh: ctg
Sửa định dạng font trong MTEXT


Thachphathien sử dụng code này thử nhé :

Filename: 94331_ctg.lsp
Tác giả: cd2k44
Bài viết gốc: 168488
Tên lệnh: cwb
Lisp Copy đường Bình đồ Từ Tim Tuyến


Bạn ketxu có thời gian thì chỉnh lại lisp trích thửa của bác thiệp thì sẽ thực hiện được yêu cầu của bạn này.Lisp của bác thiệp làm được việc bạn muốn chỉ có điều đường bao mà bạn mong muốn thì bác thiệp đã cố định nó là khung chữ nhật hoặc elisp... chứ không có chức năng chọn đường bao như bạn yêu cầu.Mình post lisp đó lên bạn có thể nhờ chính tác giả hoặc các anh...
>>

Bạn ketxu có thời gian thì chỉnh lại lisp trích thửa của bác thiệp thì sẽ thực hiện được yêu cầu của bạn này.Lisp của bác thiệp làm được việc bạn muốn chỉ có điều đường bao mà bạn mong muốn thì bác thiệp đã cố định nó là khung chữ nhật hoặc elisp... chứ không có chức năng chọn đường bao như bạn yêu cầu.Mình post lisp đó lên bạn có thể nhờ chính tác giả hoặc các anh trong diễn đàn chỉnh sửa lisp này cho phù hợp yêu cầu của bạn
;;;-----------------------
(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: <" 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)
)

Ngoài ra nếu bạn có thể sử dụng lisp sau của bác gia_bach

(defun c:CWB (/ ov vl bit ss cur ssInside ssOutside ssN ssT ssAll curT plSet) ;CWB -> Copy With Boundary
(defun *error* (msg)
(if ov (mapcar 'setvar vl ov)) ; reset Sys vars
(princ (strcat "\n<< Error: " msg " >>")) ; Print Error Message
(princ) ; Exit Cleanly
)
(command "_.undo" "_begin")
(setq vl '("CMDECHO" "OSMODE" "ORTHOMODE") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(mapcar 'setvar vl '(0 0 0)) ; Turn off CMDECHO, OSMODE, ORTHOMODE
(initget "T N")
(setq bit (getkword "\nBan muon chon Trong hay Ngoai duong bao <T/N>: " ) )
(princ"\n<<< Chon duong bao >>> ")
(setq ss (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE")))
cur (ssname ss 0))
(setq p1 (vlax-curve-getStartPoint cur)
p2 (getpoint p1 "\nDiem den :"))
(command "_copy" cur "" p1 p2)
(if (and (setq lstTouching (gettouching ss))
(setq ssTouching (ssadd))
(mapcar '(lambda (x) (ssadd x ssTouching)) lstTouching)
)
(progn
(command "_copy" ssTouching "" p1 p1)
(setq temp (ssget "p"))
(unvisible ssTouching)
(setq ssTouching temp)
)
)
(if (= bit "T") ;chon Trong duong bao
(progn
(setq ptLst (GetPtLst cur)
ssInside (ssget "_WP" ptLst ) )
(if ssInside
(command "_copy" ssInside "" p1 p2 )
)
(if (and (setq ssInside (GetssBreak ss "in"))
(> (sslength ssInside) 0))
(command "_move" ssInside "" p1 p2 )
)
)
(progn ;(= bit "N") ;chon Ngoai duong bao
;chi chon doi tuong Giao voi duong bao
(if (and (setq ssOutside (GetssBreak ss "out"))
(> (sslength ssOutside) 0))
(command "_move" ssOutside "" p1 p2 )
)
);;chon Ngoai duong bao
);cond
(Visible)
(mapcar 'setvar vl ov) ; reset Sys Vars
(command "_.undo" "_end")
(princ)
)
(defun GetssBreak (ss2 opt / ptLst cur ssInside lstss1 ss1)
(if (and (setq lstss1 (gettouching ss2))
(setq ss1 (ssadd))
(mapcar '(lambda (x) (ssadd x ss1)) lstss1)
)
(progn ; co ssTouching
(break_with ss1 ss2 nil 0)
(setq cur (ssname ss2 0)
ssBreak (ssadd))
(mapcar '(lambda (x) (ssadd x ssBreak)) (gettouching ss2))
;loc ssTouching -> ssOutside
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssBreak)))
(if (= opt "in")
(if
(or
(not(insidep (vlax-curve-getStartPoint e) cur))
(not(insidep (vlax-curve-getEndPoint e) cur))
(not(insidep (vlax-curve-getPointAtParam e (/(+(vlax-curve-getStartParam e)(vlax-curve-getEndParam e))2)) cur))
);or
(entdel e)
)
(if ;(= opt "out")
(and (insidep (vlax-curve-getStartPoint e) cur)
(insidep (vlax-curve-getEndPoint e) cur)
(insidep (vlax-curve-getPointAtParam e (/(+(vlax-curve-getStartParam e)(vlax-curve-getEndParam e))2)) cur)
);and
(entdel e)
)
);if
);foreach
);progn
);if
(if (ssmemb cur ssBreak) (ssdel cur ssBreak))
ssBreak
)
;;;(defun GetssInside (ss2 / ptLst cur ssInside lstss1 ss1 ssTouching)
;;; (if (and (setq lstss1 (gettouching ss2))
;;; (setq ss1 (ssadd))
;;; (mapcar '(lambda (x) (ssadd x ss1)) lstss1)
;;; )
;;; (progn ; co ssTouching
;;; (break_with ss1 ss2 nil 0)
;;; (setq ssTouching (ssadd))
;;; (mapcar '(lambda (x) (ssadd x ssTouching)) (gettouching ss2))
;;; ;loc ssTouching -> ssInside
;;; (or ssInside (setq ssInside (ssadd)) )
;;; (foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssTouching)))
;;; (if
;;; (and (insidep (vlax-curve-getStartPoint e) cur)
;;; (insidep (vlax-curve-getEndPoint e) cur)
;;; (insidep (vlax-curve-getPointAtParam e (/(+(vlax-curve-getStartParam e)(vlax-curve-getEndParam e))2)) cur)
;;; )
;;; (ssadd e ssInside)
;;; (entdel e)
;;; );if
;;; );foreach
;;; );progn
;;; );if
;;; (if (ssmemb cur ssInside) (ssdel cur ssInside))
;;; ssInside
;;; )

(defun GetPtLst (obj / startparam endparam anginc delta div inc pt ptlst)
(defun ZClosed (lst)
(if (and (vlax-curve-isClosed obj)
(not(equal (car lst)(last lst) 1e-6)))
(append lst (list (car lst)))
lst))

(or (eq (type obj) 'VLA-OBJECT)
(setq obj (vlax-ename->vla-object obj)))
(setq typ (vlax-get obj 'ObjectName))
(if (or (eq typ "AcDbCircle") (eq typ "AcDbEllipse"))
(progn
(setq param 0)
(while (< param (* pi 2))
(setq pt (vlax-curve-getPointAtParam obj param)
ptlst (cons pt ptlst)
param (+ (/ (* pi 2) 72) param))
)
(reverse ptlst)
)
(progn ;Pline (eq typ "AcDbPolyline")
(setq param (vlax-curve-getStartParam obj)
endparam (vlax-curve-getEndParam obj)
anginc (* pi (/ 7.5 180.0)))
(setq tparam param)
(while (<= param endparam)
(setq pt (vlax-curve-getPointAtParam obj param))
(if (not (equal pt (car ptlst) 1e-12))
(setq ptlst (cons pt ptlst)))
(if (and (/= param endparam)
(setq blg (abs (vlax-invoke obj 'GetBulge param)))
(/= 0 blg))
(progn
(setq delta (* 4 (atan blg)) ;included angle
inc (/ 1.0 (1+ (fix (/ delta anginc))))
arcparam (+ param inc))
(while (< arcparam (1+ param))
(setq pt (vlax-curve-getPointAtParam obj arcparam)
ptlst (cons pt ptlst)
arcparam (+ inc arcparam))))
)
(setq param (1+ param))
)
(if (and (apply 'and ptlst)
(> (length ptlst) 1))
(ZClosed (reverse ptlst))
)
)
)
)

;; Copyright (c) 2009, Lee McDonnell
;; (Contact Lee Mac, CADTutor.net)
(defun insidep (pt Obj / Obj Tol ang doc spc flag int lin xV yV)
(defun vlax-list->3D-point (lst flag)
(if lst
(cons ((if flag car cadr) lst)
(vlax-list->3D-point (cdddr lst) flag))))
(or (eq 'VLA-OBJECT (type Obj))
(setq Obj (vlax-ename->vla-object Obj)))
(if (not(vlax-curve-getParamAtPoint Obj pt))
(progn
(setq Tol (/ pi 6) ; Uncertainty
ang 0.0 flag T)
(setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object))
spc (if (zerop (vla-get-activespace doc))
(if (= (vla-get-mspace doc) :vlax-true)
(vla-get-modelspace doc)
(vla-get-paperspace doc))
(vla-get-modelspace doc)))
(while (and (< ang (* 2 pi)) flag)
(setq flag (and
(setq int
(vlax-invoke
(setq lin
(vla-addLine spc
(vlax-3D-point pt)
(vlax-3D-point
(polar pt ang
(if (vlax-property-available-p Obj 'length)
(vla-get-length Obj) 1.0)))))
'IntersectWith Obj
acExtendThisEntity))
(<= 6 (length int))
(setq xV (vl-sort (vlax-list->3D-point int T) '<)
yV (vl-sort (vlax-list->3D-point int nil) '<))
(or (<= (car xV) (car pt) (last xV))
(<= (car yV) (cadr pt) (last yV))))
ang (+ ang Tol))
(vla-delete lin))
flag
)
T
))

;;; Author: Copyright&#169; 2006-2008 Charles Alan Butler
;;; Contact @ www.TheSwamp.org
;;===========================================================================
;; 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 (sscros / ss lst lstb lstc objl)
(and
(setq lstb (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscros)))
objl (mapcar 'vlax-ename->vla-object lstb)
)
(setq ss (ssget "_A" (list '(-4 . "<AND")
'(-4 . "<NOT") '(60 . 1) '(-4 . "NOT>")
'(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 410 (getvar "ctab"))
'(-4 . "AND>")
)
)
)
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq lst (mapcar 'vlax-ename->vla-object lst))
(mapcar
'(lambda (x)
(mapcar
'(lambda (y)
(if (not
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(vlax-safearray->list
(vlax-variant-value
(vla-intersectwith y x acextendnone)
))))))
(setq lstc (cons (vlax-vla-object->ename x) lstc))
)
) objl)
) lst)
)
lstc
)
;;; Author: Copyright&#169; 2006-2008 Charles Alan Butler
;;; Contact @ www.TheSwamp.org
(defun break_with (ss2brk ss2brkwith self Gap / cmd intpts lst masterlist ss ssobjs
onlockedlayer ssget->vla-list list->3pair GetNewEntities oc
get_interpts break_obj GetLastEnt LastEntInDatabase ss2brkwithList
)
;; ss2brk selection set to break
;; ss2brkwith selection set to use as break points
;; self when true will allow an object to break itself
;; note that plined will break at each vertex
;;
;; return list of enames of new objects
(vl-load-com)
(princ "\nCalculating Break Points, Please Wait.\n")
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S U B F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; return T if entity is on a locked layer
(defun onlockedlayer (ename / entlst)
(setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
(= 4 (logand 4 (cdr (assoc 70 entlst))))
)
;; return a list of objects from a selection set
;| (defun ssget->vla-list (ss)
(mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss ))))
)|;
(defun ssget->vla-list (ss / i ename allobj) ; this is faster, changed in ver 1.7
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(setq allobj (cons (vlax-ename->vla-object ename) allobj))
)
allobj
)

;; return a list of lists grouped by 3 from a flat list
(defun list->3pair (old / new)
(while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
old (cdddr old)))
(reverse new)
)

;;=====================================
;; return a list of intersect points
;;=====================================
(defun get_interpts (obj1 obj2 / iplist)
(if (not (vl-catch-all-error-p
(setq iplist (vl-catch-all-apply
'vlax-safearray->list
(list
(vlax-variant-value
(vla-intersectwith obj1 obj2 acextendnone)
))))))
iplist
)
)
;;========================================
;; Break entity at break points in list
;;========================================
(defun break_obj (ent brkptlst BrkGap / brkobjlst en enttype maxparam closedobj
minparam obj obj2break p1param p2param brkpt2 dlst idx brkptS
brkptE brkpt result GapFlg result ignore dist tmppt
#ofpts 2gap enddist lastent obj2break stdist
)
(or BrkGap (setq BrkGap 0.0)) ; default to 0
(setq BrkGap (/ BrkGap 2.0)) ; if Gap use 1/2 per side of break point

(setq obj2break ent
brkobjlst (list ent)
enttype (cdr (assoc 0 (entget ent)))
GapFlg (not (zerop BrkGap)) ; gap > 0
closedobj (vlax-curve-isclosed obj2break)
)
;; when zero gap no need to break at end points
(if (zerop Brkgap)
(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 brkptlst
(progn
;; sort break points based on the distance along the break object
;; get distance to break point, catch error if pt is off end
;; ver 2.0 fix - added COND to fix break point is at the end of a
;; line which is not a valid break but does no harm
(setq brkptlst (mapcar '(lambda(x) (list x (vlax-curve-getdistatparam obj2break
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break x))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break x))))))
) brkptlst))
;; sort primary list on distance
(setq brkptlst (vl-sort brkptlst '(lambda (a1 a2) (< (cadr a1) (cadr a2)))))

(if GapFlg ; gap > 0
;; Brkptlst starts as the break point and then a list of pairs of points
;; is creates as the break points
(progn
;; create a list of list of break points
;; ((idx# stpoint distance)(idx# endpoint distance)...)
(setq idx 0)
(foreach brkpt brkptlst

;; ----------------------------------------------------------
;; create start break point, then create end break point
;; ((idx# startpoint distance)(idx# endpoint distance)...)
;; ----------------------------------------------------------
(setq dist (cadr brkpt)) ; distance to center of gap
;; subtract gap to get start point of break gap
(cond
((and (minusp (setq stDist (- dist BrkGap))) closedobj )
(setq stdist (+ (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break)) stDist))
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
((minusp stDist) ; off start of object so get startpoint
(setq dlst (cons (list idx (vlax-curve-getstartpoint obj2break) 0.0) dlst))
)
(t
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
)
;; add gap to get end point of break gap
(cond
((and (> (setq stDist (+ dist BrkGap))
(setq endDist (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break)))) closedobj )
(setq stdist (- stDist endDist))
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
((> stDist endDist) ; off end of object so get endpoint
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getendparam obj2break))
endDist) dlst))
)
(t
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
)
;; -------------------------------------------------------
(setq idx (1+ IDX))
) ; foreach brkpt brkptlst

(setq dlst (reverse dlst))
;; remove the points of the gap segments that overlap
(setq idx -1
2gap (* BrkGap 2)
#ofPts (length Brkptlst)
)
(while (<= (setq idx (1+ idx)) #ofPts)
(cond
((null result) ; 1st time through
(setq result (list (car dlst)) ; get first start point
result (cons (nth (1+(* idx 2)) dlst) result))
)
((= idx #ofPts) ; last pass, check for wrap
(if (and closedobj (> #ofPts 1)
(<= (+(- (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break))
(cadr (last BrkPtLst))) (cadar BrkPtLst)) 2Gap))
(progn
(if (zerop (rem (length result) 2))
(setq result (cdr result)) ; remove the last end point
)
;; ignore previous endpoint and present start point
(setq result (cons (cadr (reverse result)) result) ; get last end point
result (cdr (reverse result))
result (reverse (cdr result)))
)
)
)
;; Break Gap Overlaps
((< (cadr (nth idx Brkptlst)) (+ (cadr (nth (1- idx) Brkptlst)) 2Gap))
(if (zerop (rem (length result) 2))
(setq result (cdr result)) ; remove the last end point
)
;; ignore previous endpoint and present start point
(setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get present end point
)
;; Break Gap does Not Overlap previous point
(t
(setq result (cons (nth (* idx 2) dlst) result)) ; get this start point
(setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get this end point
)
) ; end cond stmt
) ; while

(setq dlst (reverse result)
brkptlst nil)
(while dlst ; grab the points only
(setq brkptlst (cons (list (cadar dlst)(cadadr dlst)) brkptlst)
dlst (cddr dlst))
)
)
)
;; -----------------------------------------------------
;; (if (equal a ent) (princ)) ; debug CAB -------------

(foreach brkpt (reverse brkptlst)
(if GapFlg ; gap > 0
(setq brkptS (car brkpt)
brkptE (cadr brkpt))
(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
)
)
)
)
)
)
)
(setq closedobj (vlax-curve-isclosed obj2break))
(if GapFlg ; gap > 0
(if closedobj
(progn ; need to break a closed object
(setq brkpt2 (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getDistAtPoint obj2break brkptE) 0.00001)))
(command "._break" obj2break "_non" (trans brkpt2 0 1)
"_non" (trans brkptE 0 1))
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(setq BrkptE brkpt2)
)
)
(if (and closedobj
(not (setq brkptE (vlax-curve-getPointAtDist obj2break
(+ (vlax-curve-getdistatparam obj2break
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))))
;; ver 2.0 fix
(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
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001)))
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break brkpts))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))
)
) ; endif

;; (if (null brkptE) (princ)) ; debug

(setq LastEnt (GetLastEnt))
(command "._break" obj2break "_non" (trans brkptS 0 1) "_non" (trans brkptE 0 1))
(and *BrkVerbose* (princ (setq *brkcnt* (1+ *brkcnt*))) (princ "\r"))
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(if (and (not closedobj) ; new object was created
(not (equal LastEnt (entlast))))
(setq brkobjlst (cons (entlast) brkobjlst))
)
)
)
) ; endif 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
)
;;===================================
;; CAB - return a list of new enames
(defun GetNewEntities (ename / new)
(cond
((null ename) (alert "Ename nil"))
((eq 'ENAME (type ename))
(while (setq ename (entnext ename))
(if (entget ename) (setq new (cons ename new)))
)
)
((alert "Ename wrong type."))
)
new
)

;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S T A R T S U B R O U T I N E H E R E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

(setq LastEntInDatabase (GetLastEnt))
(if (and ss2brk ss2brkwith)
(progn
(setq oc 0
ss2brkwithList (ssget->vla-list ss2brkwith))
(if (> (* (sslength ss2brk)(length ss2brkwithList)) 5000)
(setq *BrkVerbose* t)
)
(and *BrkVerbose*
(princ (strcat "Objects to be Checked: "
(itoa (* (sslength ss2brk)(length ss2brkwithList))) "\n")))
;; CREATE a list of entity & it's break points
(foreach obj (ssget->vla-list ss2brk) ; check each object in ss2brk
(if (not (onlockedlayer (vlax-vla-object->ename obj)))
(progn
(setq lst nil)
;; check for break pts with other objects in ss2brkwith
(foreach intobj ss2brkwithList
(if (and (or self (not (equal obj intobj)))
(setq intpts (get_interpts obj intobj))
)
(setq lst (append (list->3pair intpts) lst)) ; entity w/ break points
)
(and *BrkVerbose* (princ (strcat "Objects Checked: " (itoa (setq oc (1+ oc))) "\r")))
)
(if lst
(setq masterlist (cons (cons (vlax-vla-object->ename obj) lst) masterlist))
)
)
)
)
(and *BrkVerbose* (princ "\nBreaking Objects.\n"))
(setq *brkcnt* 0) ; break counter
;; masterlist = ((ent brkpts)(ent brkpts)...)
(if masterlist
(foreach obj2brk masterlist
(break_obj (car obj2brk) (cdr obj2brk) Gap)
)
)
)
)
;;==============================================================
(and (zerop *brkcnt*) (princ "\nNone to be broken."))
(setq *BrkVerbose* nil)
(GetNewEntities LastEntInDatabase) ; return list of enames of new objects
)
(defun unvisible (objSet)
(vl-load-com)
(foreach obj (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr(ssnamex objSet))))
(vl-catch-all-error-p
(vl-catch-all-apply
'vla-put-visible
(list obj :vlax-false)))
)
(princ)
)
(defun visible(/ objSet)
(vl-load-com)
(setq objSet (ssget "_X" '((60 . 1))))
(if objSet
(foreach obj (mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr(ssnamex objSet))))
(vl-catch-all-error-p
(vl-catch-all-apply
'vla-put-visible
(list obj :vlax-true)))
)
)
(princ)
)

<<

Filename: 168488_cwb.lsp
Tác giả: Nguyen Hoanh
Bài viết gốc: 18371
Tên lệnh: tenham
Đường dẫn của file lisp vừa mới load!!!!!!!!!!!!
Cảm ơn bạn, cách này khá hay. Từ lâu rồi tôi luôn tìm kiếm, nhưng không nghĩ ra là đọc từ đường dẫn của Appload Dialog.

Đoạn khác biệt R17.1\\ACAD-6001:409 mà bạn thắc mắc thì rất dễ, có thể dùng hàm (vlax-product-key) để biết chính xác phần này.
Ngoài ra nếu mình cố định "<>" thì không phải lúc nào cũng đúng. Điều này chỉ đúng khi người sử dụng chưa định...
>>
Cảm ơn bạn, cách này khá hay. Từ lâu rồi tôi luôn tìm kiếm, nhưng không nghĩ ra là đọc từ đường dẫn của Appload Dialog.

Đoạn khác biệt R17.1\\ACAD-6001:409 mà bạn thắc mắc thì rất dễ, có thể dùng hàm (vlax-product-key) để biết chính xác phần này.
Ngoài ra nếu mình cố định "<>" thì không phải lúc nào cũng đúng. Điều này chỉ đúng khi người sử dụng chưa định nghĩa một Profile nào. Khi người sử dụng có nhiều profile, để muốn biết profile hiện tại, sử dụng tập hợp hàm (vla-get-activeprofile (vla-get-profiles (vla-get-preferences (vlax-get-acad-object)))) để xác định nó.

Như vậy, cải tiến lệnh TENHAM dưới đây sẽ chạy đúng trong mọi phiên bản acad và chạy đúng trong mọi trường hợp profile:

<<

Filename: 18371_tenham.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 168534
Tên lệnh: copart
Lisp Copy đường Bình đồ Từ Tim Tuyến

Hề hề hề,
Thử chơi thẻ codebox xem có ngon hơn không:

Filename: 168534_copart.lsp
Tác giả: npham
Bài viết gốc: 167967
Tên lệnh: pco
xin lisp copy đối tượng cho trước lần lượt theo các điểm trên đường polyline
các bác có thể thay hàm ACET-GEOM-VERTEX-LIST thành 1 hàm khác (lấy tập dỉnh polyline)

Tham khảo:


(defun c:pco (/ ss ent p1 p2 lst i)

(defun vlp-GetPoint (ent / lst ret name)
(setq lst (vlax-get (vlax-ename->vla-object ent) 'Coordinates))
(while lst
(setq ret (append ret (list (list (car lst) (cadr lst)))))
(setq lst (cddr lst))
)
ret
)
(vl-load-com)
>>
các bác có thể thay hàm ACET-GEOM-VERTEX-LIST thành 1 hàm khác (lấy tập dỉnh polyline)

Tham khảo:


(defun c:pco (/ ss ent p1 p2 lst i)

(defun vlp-GetPoint (ent / lst ret name)
(setq lst (vlax-get (vlax-ename->vla-object ent) 'Coordinates))
(while lst
(setq ret (append ret (list (list (car lst) (cadr lst)))))
(setq lst (cddr lst))
)
ret
)
(vl-load-com)
(setq ss (ssget))
(setq ent (car (entsel)))

(setq lst (vlp-getpoint ent))
(setq p1 (car lst) i 1)
(while (setq p2 (nth i lst))
(command "copy" ss "" p1 p2)
(setq i (1+ i))
)
)

<<

Filename: 167967_pco.lsp
Tác giả: phamthanhbinh
Bài viết gốc: 168588
Tên lệnh: gcdtn
[Yêu cầu]lisp tạo ra các điểm point lấy gt từ trắc dọc

Hề hề hề,
1/- Bỏ việc chọn tỷ lệ trong mỗi bước lặp:

2/- Có nhẽ bạn chưa thực sự hiểu cái lisp của mình hay ngược lại mình chưa thực sự hiểu ý bạn chăng.
Vẫn cái hình bạn post mình test thử thì thấy nó OK 100% luôn.

Mình xin giải thích cái lisp của mình như sau:
Khi bạn gõ lệnh gcdtn, lisp sẽ yêu cầu bạn chọn đường biểu diễn cao độ của...
>>

Hề hề hề,
1/- Bỏ việc chọn tỷ lệ trong mỗi bước lặp:

2/- Có nhẽ bạn chưa thực sự hiểu cái lisp của mình hay ngược lại mình chưa thực sự hiểu ý bạn chăng.
Vẫn cái hình bạn post mình test thử thì thấy nó OK 100% luôn.

Mình xin giải thích cái lisp của mình như sau:
Khi bạn gõ lệnh gcdtn, lisp sẽ yêu cầu bạn chọn đường biểu diễn cao độ của mặt đất tự nhiên (đường màu vàng)
Tiếp theo lisp yêu cầu bạn chọn đường biểu diễn cao độ của mặt đường theo thiết kế. (đường màu đỏ)
Tiếp theo lisp sẽ yêu cầu bạn chọn tập hợp các đường biểu diễn vị trí của các cọc mà bạn cần xác định cao độ tim trên trắc ngang.(các đường đứng màu trắng)
Từ đó lisp sẽ tính ra độ chênh cao từ mặt đất tự nhiên tới mặt đường theo thiết kế tại vị trí tim mỗi cọc mà bạn đã chọn.
Các cọc này được lisp sắp xếp lại theo trình tự từ trái qua phải để tiện cho việc bạn chọn các mặt cắt ngang ở bước kế tiếp. Tránh tình trạng râu ông nọ cắm cằm bà kia.
Đến đây lisp sẽ hỏi bạn nhập tỷ lệ giửa trắc ngang và trắc dọc chứ không phải tỷ lệ của trắc ngang. Nghĩa là nếu tỷ lệ của trắc dọc là 1/50 và tỷ lệ của trắc ngang là 1/100 thì bạn sẽ phải nhập cái tỷ lệ này là (1/100) / (1/50) = 1/2 = 0,5.
Sau khi nhập tỷ lệ bạn phải chọn các giao điểm của cọc tim (đường màu trắng) trên các trắc ngang (phù hợp với trật tự từ trái sang phải của các vị trí cọc đã chọn trên trắc dọc) với đường biể diễn cao độ mặt đất tự nhiên trên trắc ngang đó (đường màu vàng). Từ đó lisp sẽ vẽ một point tại vị trí tương ứng trên trắc ngang.

Đây là nói về cái mình đã sửa để chỉ phải nhập tỷ lệ một lần nhé.

Hy vọng rằng bạn sẽ sử dụng được cái lisp này với những điều mình đã nói ở trên. Nếu có gì chưa đúng ý bạn hãy post lên nhé.
Do mình không phải dân trong ngành nên bắt bạn nói hoài cũng mệt. rất mong bạn thông cảm.

Do hộp code của diễn đàn bị lỗi nên nó hiển thị sai nội dung lisp, bạn hãy download nó chứ đừng copy nhé.
<<

Filename: 168588_gcdtn.lsp
Tác giả: q288
Bài viết gốc: 65364
Tên lệnh: 3 1 2
Lisp hay bị lỗi, tự động undo n lần ???


Sửa rồi như sau:

Filename: 65364_3_1_2.lsp
Tác giả: quan08
Bài viết gốc: 172632
Tên lệnh: tdx
Vẽ trục cho đường tròn
Mình down được trên diễn đàn lisp vẽ trục cho đường tròn,nay nhờ các bác chỉnh sửa lại sao cho lisp có thể định được trục cho hình vuông,hình chữ nhật được vẽ bằng polyline.Chân thành cảm ơn trước.

defun NewLayer (Name Col Typ)
(if (not (tblsearch "layer" Name))
(command "-layer" "n" Name "c" Col Name "l" Typ Name "" ))
)
(defun...
>>
Mình down được trên diễn đàn lisp vẽ trục cho đường tròn,nay nhờ các bác chỉnh sửa lại sao cho lisp có thể định được trục cho hình vuông,hình chữ nhật được vẽ bằng polyline.Chân thành cảm ơn trước.

defun NewLayer (Name Col Typ)
(if (not (tblsearch "layer" Name))
(command "-layer" "n" Name "c" Col Name "l" Typ Name "" ))
)
(defun c:tdx ( / ss oldos oldla ent r c)
(setq oldos (getvar "osmode"))
(setq oldla (getvar "clayer"))
(NewLayer "TRUCDX" 9 "CENTER2")
(setvar "osmode" 0)
(setvar "clayer" "TRUCDX")
(setq ss (ssget '((0 . "CIRCLE"))))
(setq c 0)
(repeat (sslength ss)
(setq ent (entget (ssname ss c)))
(setq r (cdr (assoc 40 ent)))
(setq pt (cdr (assoc 10 ent)))
(command ".pline" (list (- (car pt) r (/ r 5)) (cadr pt)) (list (+ (car pt) r (/ r 5)) (cadr pt)) "")
(command ".pline" (list (car pt) (- (cadr pt) r (/ r 5))) (list (car pt) (+ (cadr pt) r (/ r 5))) "")
(setq c (1+ c))
)
(setvar "osmode" oldos)
(setvar "clayer" oldla)
(princ "\n* * * Completed! * * *")
(princ)
)

<<

Filename: 172632_tdx.lsp
Tác giả: ketxu
Bài viết gốc: 172642
Tên lệnh: cl
Vẽ trục cho các đối tượng

- Vẽ trục cho mọi đối tượng (kín, hở, vuông, tròn...)
Để thay đổi theo ý thích, mình đã ghi chú trong Lisp

Filename: 172642_cl.lsp
Tác giả: lp_hai
Bài viết gốc: 172618
Tên lệnh: sw
Lisp chọn nhiều đối tượng giống nhau

tại mình thấy lisp chưa hoàn thiện với lại có vẻ như "ko ai xài" nên gỡ xuống. Theo hướng dẫn của các pác ở trên mình viết lại đây:

(defun c:sw(/ aaa ls dt dt1 sdt sdt1 ent ent1 id id1)
(setq AAA(SSGET)
sdt (sslength AAA)
id 0
dt (ssadd)
)
(repeat sdt;;repeat1
(setq ent (ssname AAA id)
id (1+ id)
);;setq
(setq ls (entget ent))
(if (= (cdr (assoc 0 ls))...
>>

tại mình thấy lisp chưa hoàn thiện với lại có vẻ như "ko ai xài" nên gỡ xuống. Theo hướng dẫn của các pác ở trên mình viết lại đây:

(defun c:sw(/ aaa ls dt dt1 sdt sdt1 ent ent1 id id1)
(setq AAA(SSGET)
sdt (sslength AAA)
id 0
dt (ssadd)
)
(repeat sdt;;repeat1
(setq ent (ssname AAA id)
id (1+ id)
);;setq
(setq ls (entget ent))
(if (= (cdr (assoc 0 ls)) "INSERT")
(get-block ent)
(setq dt1(ssget"all"(list(assoc 0 ls) (assoc 8 ls))))
);;if
(setq sdt1 (sslength dt1)
id1 -1)
(while (setq ent1(ssname dt1 (setq id1 (1+ id1))))
(setq dt (ssadd ent1 dt))
);;While
(sssetfirst dt dt)
(princ)
);;repeat1
)
;;;;;;;;;;;;;;;;;;;;;;;;
(defun get-block(entm / sdtb idb ent2 entb dtm namem name BBB entb)
(setq dtm (vlax-ename->vla-object entm))
(setq namem (if(vlax-property-available-p dtm 'effectivename)
(vla-get-effectivename dtm)
(vla-get-name dtm)
));;;
(setq BBB(SSGET "all" (list(cons 0 "INSERT") (assoc 8 (entget entm))))
sdtb (sslength BBB)
idb 0
dt1 (ssadd)
)
(repeat sdtb;;repeat1
(setq entb (ssname BBB idb)
idb (1+ idb)
)
(setq ent2(vlax-ename->vla-object entb))
(setq name (if(vlax-property-available-p ent2 'effectivename)
(vla-get-effectivename ent2)
(vla-get-name ent2)
))
(if (= name namem)
(setq dt1 (ssadd entb dt1))
)
)
)

lisp cho phép người dùng chọn nhiều dt mẫu cùng lúc
<<

Filename: 172618_sw.lsp
Tác giả: tien2005
Bài viết gốc: 33987
Tên lệnh: arearon
Viết Lisp theo yêu cầu


Mình đã xem lại code trên, SCALE chỉ có tác dụng xác định chiều cao text chứ không có tác dụng trong tính diện tích.

Code sau đã được modify để không phải nhập tỉ lệ và lấy bao nhiêu số thập phân. Mặc định chiều cao text = 2.5 (nếu textheight = 0, nếu khác 0 sẽ lấy textheight làm chiều cao text) và lấy 1 số thập phân. Nếu muôn thay đổi các giá trị này Bạn chỉ cần thay...
>>


Mình đã xem lại code trên, SCALE chỉ có tác dụng xác định chiều cao text chứ không có tác dụng trong tính diện tích.

Code sau đã được modify để không phải nhập tỉ lệ và lấy bao nhiêu số thập phân. Mặc định chiều cao text = 2.5 (nếu textheight = 0, nếu khác 0 sẽ lấy textheight làm chiều cao text) và lấy 1 số thập phân. Nếu muôn thay đổi các giá trị này Bạn chỉ cần thay đổi các giá trị được tô đậm sau: (utext pt (rtos areaobj 2 1) "TC" "2.5" "0")

<<

Filename: 33987_arearon.lsp
Tác giả: Tue_NV
Bài viết gốc: 56674
Tên lệnh: vnh
lisp đổi Font sang font SHX bị lỗi.

Kiểm tra với các font .shx khác thì OK nhưng chưa kiểm tra với font kythuat1.SHX vì bạn không post lên ở đây. Hãy chạy thử nếu không có vấn đề gì thì thôi, còn nếu bạn có vấn đề thì hãy post lên đây, kèm theo font kythuat1.shx của bạn.
Code được chỉnh lại chút xíu

:cheers:

Filename: 56674_vnh.lsp
Tác giả: Snowman
Bài viết gốc: 34480
Tên lệnh: ep mep
Viết Lisp theo yêu cầu

Đây có thể là lisp bạn cần: lệnh ep để nhập 1 cao độ cho nhiều đường, lệnh mep để nhập cao độ khác nhau cho nhiều đường (chọn tất cả và lệnh sẽ zoom từng đường để bạn vào số liệu, hoặc nhập theo thứ tự tăng dần cao độ - phải chọn polyline theo đúng thứ tự: pick hoặc dùng fence line)

Filename: 34480_ep_mep.lsp
Tác giả: gia_bach
Bài viết gốc: 34677
Tên lệnh: dtt
Viết Lisp theo yêu cầu


Đoạn list của bạn đây :

Filename: 34677_dtt.lsp
Tác giả: gia_bach
Bài viết gốc: 37134
Tên lệnh: sdkt
Viết Lisp theo yêu cầu

Bạn dùng thử LISP này :

Filename: 37134_sdkt.lsp

Trang 53/330

53