Chuyển đến nội dung
Diễn đàn CADViet
Nguyen Hoanh

Viết lisp theo yêu cầu [phần 2]

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

Hình như bạn dùng phiên bản cad2004 hoặc thấp hơn đúng không??. Nếu bạn dùng phiên bản cad cao hơn thì đây chỉ là chuyện nhỏ đâu cần đến lisp.

em cám ơn amh tú nhe! anh nói em mới để ý em làm được rồi

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


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Đây là phần tiếp theo của topic Viết lisp theo yêu cầu, mời các bạn tiếp tục thảo luận.

Xin bạn cho mình hỏi! Bạn có biết câu lệnh Autolisp nào để lấy tên của Block đang hiệu chỉnh trong Block Editor không?! Mình đã biết là khi biến hệ thống BLOCKEDITOR bằng 1 thì đang ở chế độ block editor. Cảm ơn bạn! rất mong đuợc giúp đỡ!

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


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Xin bạn cho mình hỏi! Bạn có biết câu lệnh Autolisp nào để lấy tên của Block đang hiệu chỉnh trong Block Editor không?! Mình đã biết là khi biến hệ thống BLOCKEDITOR bằng 1 thì đang ở chế độ block editor. Cảm ơn bạn! rất mong đuợc giúp đỡ!

Chào bạn mình cũng như bạn không biết hệ thống nào cho tên block hiện hành. Nhưng mình nghĩ có thể làm thủ công như sau:

(defun tenblock ()
 (command "bclose" "s")
 (setq name (ssname (ssget "p") 0))
 (setq ten (cdr (assoc 2 (entget name))))
 (command "bedit" ten)
 ten
 )

Bác nào biết thì chỉ cho em với nhé.

  • Vote tăng 1

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


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Tiện thể nhờ các bác giúp giùm e 1 cái nửa.E có 1lisp ghi chú :Điểm click đầu tiên sẽ 1 mũi tên,e muốn nhờ các bác sửa giùm khi click điểm đầu tiên sẽ là 1 vòng tròn có đường kính 200 thay cho mũi tên và vòng tròn này với các đường thẳng sẽ là 1 giống như polyline đồng thời gán giùm e vòng tròn ký hiệu số là 1 block ATT vì e vẫn chưa hiểu hết về tạo block ATT trong lisp.Thanks.

;GHI CHU THEP
(DEFUN C:gct ()
(SETQ DK1 (GETVAR "USERR3"))
(IF (= DK1 0)
(PROGN
 (SETQ STR "1")
 (SETVAR "USERR3" 1)
)	
(SETQ STR (RTOS DK1))
)
(SETQ PRPT (STRCAT "\nSize <" STR ">:"))
(SETQ DK1 (GETREAL PRPT))
(IF (= DK1 NIL)
(SETQ DK1 (GETVAR "USERR3"))
(SETVAR "USERR3" DK1)
)
(setq dk (* dk1 50))
(INITGET 7)
(SETQ PTD (GETPOINT "\nFrom point:"))
(INITGET 7)
(SETQ PTC (GETPOINT PTD "\nTo point:"))
(SETQ GOCX (ANGLE PTD PTC))
(SETQ GOCY (+ GOCX (/ PI 2)))
(setq v (rtos dk))
(setq t (distance ptd ptc))
(setq r (/ t 2))
(SETQ PT1 (POLAR  PTc  0   (* 33 DK)))
(SETQ o (POLAR  PT1  0   (* 5.2 DK)))
(setq h (substr v 1 1))
(setq y (substr v 2 3))
(setq l (distance ptc pt1))
(setq pt3 (polar ptc 0 (/ l 1.85)))
(setq pt4 (polar pt3 (/ pi 2) (* 4 DK)))
(setq pt5 (polar ptd (- gocx (/ pi 2)) r))
(setq pt6 (polar ptd (+ gocx (/ pi 2)) r))
(setq pt7 (polar ptd (+ gocx  pi) r))
(setq pt8 (polar ptd  gocx   (* 2.8 dk)))
(command "osnap"  "")
(command "layer" "m" "ghichu" "c" "163" """")
(COMMAND "COLOR" "84" "")
(COMMAND "STYLE" "T_THEP"  "romans.shx,vn1.shx" "" "" "" "" "" "" )
(command "text" "j" "m" pt4 (* 5 DK) 0)
(command "%%c10a150" )
(COMMAND "STYLE" "VnAvant"  ".VnAvant" "" "" "" "" "")
(command "text" "j" "m" o (* 5 DK) 0)
(command "1" "")
(COMMAND "COLOR" "4" "")
(command "circle" o (* 5.2 DK)"")
(COMMAND "COLOR" "150" "")
(COMMAND "PLINE" ptd "w" "" (* 0.5 dk) pt8  "w" "" 0 pt8 ptc pt1  "")
(COMMAND "COLOR" "BYLAYER" "")
(command "osnap" "End,Mid,Cen,Quad,Int,Perp,Tan,Near,App,Int,Ext,Par"  )
(command "ddedit" pause)
)

Mình sửa cho bạn này:

(DEFUN C:gct ()
(SETQ DK1 (GETVAR "USERR3"))
(IF (= DK1 0)
    (PROGN
     (SETQ STR "1")
     (SETVAR "USERR3" 1)
    )    
    (SETQ STR (RTOS DK1))
)
(SETQ PRPT (STRCAT "\nSize <" STR ">:"))
(SETQ DK1 (GETREAL PRPT))
(IF (= DK1 NIL)
    (SETQ DK1 (GETVAR "USERR3"))
    (SETVAR "USERR3" DK1)
)
(setq dk (* DK1 50))
(INITGET 7)
(SETQ PTD (GETPOINT "\nFrom point:"))
(INITGET 7)
(SETQ PTC (GETPOINT PTD "\nTo point:"))
(SETQ GOCX (ANGLE PTD PTC))
(SETQ GOCY (+ GOCX (/ PI 2)))
(setq v (rtos dk))
(setq t (distance ptd ptc))
(setq r (/ t 2))
(SETQ PT1 (POLAR  PTc  0   (* 33 DK)))
(SETQ o (POLAR  PT1  0   (* 5.2 DK)))
(setq h (substr v 1 1))
(setq y (substr v 2 3))
(setq l (distance ptc pt1))
(setq pt3 (polar ptc 0 (/ l 1.85)))
(setq pt4 (polar pt3 (/ pi 2) (* 4 DK)))
(setq pt5 (polar ptd (- gocx (/ pi 2)) r))
(setq pt6 (polar ptd (+ gocx (/ pi 2)) r))
(setq pt7 (polar ptd (+ gocx  pi) r))
(setq pt8 (polar ptd  gocx   (* 2.8 dk)))
(command "osnap"  "")
(command "layer" "m" "ghichu" "c" "163" """")
(COMMAND "COLOR" "84" "")
(COMMAND "STYLE" "T_THEP"  "romans.shx,vn1.shx" "" "" "" "" "" "" )
(command "text" "j" "m" pt4 (* 5 DK) 0)
(command "%%c10a150" )
 (setq sua (entlast))
(if (= (tblsearch "block" "ghithep_t") nil)
(progn
(COMMAND "STYLE" "VnAvant"  ".VnAvant" "" "" "" "" "")
(command "attdef" "" 1 1 1 "j" "m" o (* 5 50) 0)
(setq ss (ssadd))
(setq ss (ssadd (entlast) ss))
(COMMAND "COLOR" "4" "")
(command "circle" o (* 5.2 50)"")
(setq ss (ssadd (entlast) ss))
(command "block" "ghithep_t" o ss "")
(command "insert" "ghithep_t" o DK1 DK1 "" "1")
)
(command "insert" "ghithep_t" o DK1 DK1 "" "1")
)
(COMMAND "COLOR" "150" "")
(COMMAND "PLINE" ptd "w" "" (* 0.5 dk) pt8  "w" "" 0 pt8 ptc pt1  "")
(COMMAND "COLOR" "BYLAYER" "")
(command "osnap" "End,Mid,Cen,Quad,Int,Perp,Tan,Near,App,Int,Ext,Par"  )
(command "ddedit" sua pause)
)

  • Vote tăng 1

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


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Nếu mình vẽ lề trái bằng Pline qua nhiều điểm và lề phải qua nhiêều đieểm thì lisp chạy cắt không châẩn. Mong bạn xem lại giúp.

Xin lỗi vì mình không hiểu ý bạn. Mình sửa cho bạn rồi đây:

;; free lisp from cadviet.com

(defun c:tg ()
(vl-load-com)
(setq (getvar "osmode" oldos))
(setvar "osmode" 0)
(setq l1 (car (entsel "\nChon duong thu nhat: "))
l2 (car (entsel "\nChon duong thu hai: "))
;;;;;; p (getpoint "\Pick 1 diem ben ngoai ban ve: ")
ls1 (acet-geom-vertex-list l1)
;p2 (cadr (acet-geom-vertex-list l1))
ls2 (acet-geom-vertex-list l2)
;p4 (cadr (acet-geom-vertex-list l2))
)
(command "pline")
 (setq i 0)
 (repeat (length ls1)
   (command (nth i ls1))
   (setq i (1+ i))
   )
(if (> (distance (car ls1) (car ls2)) (distance (car ls1) (last ls2)))
(progn
 (setq i 0)
 (repeat (length ls2)
   (command (nth i ls2))
   (setq i (1+ i))
   )
(command "c")
)
(progn
 (setq i 0)
 (setq ls2 (reverse ls2))
 (repeat (length ls2)
   (command (nth i ls2))
   (setq i (1+ i))
   )
(command "c")
)
)
(setq el (entlast))
(command "offset" 0.1 el mp "")
(setq in (entlast))
;;;;;;;;;;;(command "offset" 0.1 el p "")
;;;;;;;;;;;(setq out (entlast))
;;;;;;;;;;;(setq lsp (acet-geom-vertex-list el))
;;;;;;;;;;;(setq ss (ssget "cp" lsp))
;;;;;;;;;;;;;(setq ss (ssdel el ss))
;;;;;;;;;;(setq ss (ssdel in ss))
;;;;;;;;;;;;;(command "copy" ss "" mp p "")
;;;;;;;;;;;;;;;(command "copy" el "" mp p "")
;;;;;;;;;;;;(setq elc (entlast))
;;;;;;;;;;;;;;;(command "move" out "" mp p)
;;;;;;;;;;;;;;(setq lsout (acet-geom-vertex-list out))
;;;;;;;;;;;(entdel out)
;;;;;;;;;;;;;;(repeat 5
;;;;;;;;;;;;;;;;;(setq i 0)
;;;;;;;;;;;;;;;;;(command "trim" elc "" "f")
;;;;;;;;;;;;;;;(repeat (length lsout)
;;;;;;;;;;;;;;(command (nth i lsout))
;;;;;;;;;;;;;;;;(setq i (1+ i))
;;;;;;;;;;;;;;;:s_big:
;;;;;;;;;;;;(command "" "")
;;;;;;;;;;;;;;:leluoi:
;;;;;;;;;;;;(setq lsin (acet-geom-vertex-list in))
;;;;;;;;;;;;(entdel in)
;;;;;;;;;;;;(repeat 5
;;;;;;;;;;;;;;;(setq i 0)
;;;;;;;;;;;(command "trim" el "" "f")
;;;;;;;;;;(repeat (length lsin)
;;;;;;;;;;;;;;(command (nth i lsin))
;;;;;;;;;;;;;;;;;;;(setq i (1+ i))
;;;;;;;;;;;;;;;:cheers:
;;;;;;;;;;;;;;;;;(command "" "")
;;;;;;;;;;;;;;;:D
;;;;;;;;;;;;;;;;;(command "erase" (ssget "wp" lsp) "")
;;;;;;;;;;;;;(setq lselc (acet-geom-vertex-list elc))
;;;;;;;;;;;;;;;;(entdel elc)
;;;;;;;;;;;;;;;;(setq tt (ssget "cp" lselc))
;;;;;;;;;;;;;;;;;;(command "move" tt "" p mp)

(setq el (ssadd el))
(breakwithtouching el)
(setq tt (ssget "cp" (acet-geom-vertex-list in)))
(command "change" tt "" "p" "la" "biendong" "c" "bylayer" "")
(entdel el)
(entdel in)
(setvar "osmode" oldos)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;

(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
;;========================================
;; New as per version 1.8 [brkGap] --- This subroutine has been re-written
;; Loop through the break points breaking the entity
;; If the entity is not a closed entity then a new object is created
;; This object is added to a list. When break points don't fall on the current
;; entity the list of new entities are searched to locate the entity that the
;; point is on so it can be broken.
;; "Break with a Gap" has been added to this routine. The problem faced with
;; this method is that sections to be removed may lap if the break points are
;; too close to each other. The solution is to create a list of break point pairs
;; representing the gap to be removed and test to see if there i an overlap. If
;; there is then merge the break point pairs into one large gap. This way the
;; points will always fall on an object with one exception. If the gap is too near
;; the end of an object one break point will be off the end and therefore that
;; point will need to be replaced with the end point.
;; NOTE: in ACAD2000 the (vlax-curve-getdistatpoint function has proven unreliable
;; so I have used (vlax-curve-getdistatparam in most cases
(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

;; setup brkptlst with pair of break pts ((p1 p2)(p3 p4)...)
;; one of the pair of points will be on the object that
;; needs to be broken
(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
)
)
)
)
)
)
)
;| ;; ver 2.0 fix - removed this code as there are cases where the break point
;; is at the end of a line which is not a valid break but does no harm
(if (and brkobjlst idx (minusp idx)
(null (alert (strcat "Error - point not on object"
"\nPlease report this error to"
"\n CAB at TheSwamp.org"))))
(exit)
)
|;
;; (if (equal (if (null a)(setq a (car(entsel"\nTest Ent"))) a) ent) (princ)) ; debug CAB -------------

;; Handle any objects that can not be used with the Break Command
;; using one point, gap of 0.000001 is used
(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)
)
)
;; single breakpoint ----------------------------------------------------
;|(if (and closedobj ; problems with ACAD200 & this code
(not (setq brkptE (vlax-curve-getPointAtDist obj2break
(+ (vlax-curve-getDistAtPoint obj2break brkptS) 0.00001))))
)
(setq brkptE (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getDistAtPoint obj2break brkptS) 0.00001)))

)|;
(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
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; E N D O F M A I N S U B R O U T I N E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; M A I N S U B F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;;======================
;; Redraw ss with mode
;;======================
(defun ssredraw (ss mode / i num)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(redraw (ssname ss i) mode)
)
)

;;===========================================================================
;; 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 (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 410 (getvar "ctab"))))
)
(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
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; E N D M A I N F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;===============================================
;; Break all objects selected with each other
;;===============================================
(defun c:BreakAll (/ cmd ss NewEnts AllEnts tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nSelect objects to break with each other & press enter: ")
(if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq NewEnts (Break_with ss ss nil Bgap) ; ss2break ss2breakwith (flag nil = not to break with self)
; AllEnts (append NewEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;===========================================
;; Break a single object with other objects
;;===========================================
(defun c:BreakObject (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)

;; get objects to break
(prompt "\nSelect single object to break: ")
(if (and (setq ss1 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (redraw (ssname ss1 0) 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (redraw (ssname ss1 0) 4)))
(Break_with ss1 ss2 nil Bgap) ; ss2break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;==========================================
;; Break many objects with a single object
;;==========================================
(defun c:BreakWobject (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select single object to break with: ***"))
(setq ss2 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;==========================================
;; Break objects with objects on a layer
;;==========================================
;; New 08/01/2008
(defun c:BreakWlayer (/ cmd ss1 ss2 tmp lay)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\n*** Select single object for break layer: ***")

(if (and (setq ss2 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq lay (assoc 8 (entget (ssname ss2 0))))
(setq ss2 (ssget "_X" (list
'(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
lay (cons 410 (getvar "ctab")))))
(not (prompt "\nSelect object(s) to break & press enter: "))
(setq ss1 (ssget (list
'(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 8 (strcat "~" (cdr lay))))))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;======================================================
;; Break selected objects with other selected objects
;;======================================================
(defun c:BreakWith (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak selected objects with other selected objects.")
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;=============================================
;; Break objects touching selected objects
;;=============================================

(defun c:BreakTouching (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak objects touching selected objects.")
(if (and (not (prompt "\nSelect object(s) to break & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;=================================================
;; Break touching objects with selected objects
;;=================================================
;; New 08/01/2008
(defun BreakWithTouching ( ss2 / cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)

;; get objects to break
(prompt "\nBreak objects touching selected objects.")
(prompt "\nSelect object(s) to break with & press enter: ")
(if 
(and 
;;;;;;;;;(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
ss2
(setq tlst (gettouching ss2))
)
(progn
(setq tlst (vl-remove-if '(lambda (x)(ssmemb x ss2)) tlst)) ; remove if in picked ss
(mapcar '(lambda (x) (ssadd x ss1)) tlst) ; convert to a selection set
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;==========================================================
;; Break selected objects with any objects that touch it
;;==========================================================
(defun c:BreakSelected (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak selected objects with any objects that touch it.")
(if (and (not (prompt "\nSelect object(s) to break with touching & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss2 ss1 nil Bgap) ; ss2break ss1breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;; ***************************************************
;; Function to create a dcl support file if it
;; does not exist
;; Usage : (create_dcl "file name")
;; Returns : T if successful else nil
;; ***************************************************
(defun create_Breakdcl (fname / acadfn dcl-rev-check)
;;=======================================
;; check revision date Routine
;;=======================================
(defun dcl-rev-check (fn / rvdate ln lp)
;; revision flag must match exactly and must
;; begin with //
(setq rvflag "// Revision Control 05/12/2008@14:11" )
(if (setq fn (findfile fn))
(progn ; check rev date
(setq lp 5) ; read 4 lines
(setq fn (open fn "r")) ; open file for reading
(while (> (setq lp (1- lp)) 0)
(setq ln (read-line fn)) ; get a line from file
(if (vl-string-search rvflag ln)
(setq lp 0)
)
)
(close fn) ; close the open file handle
(if (= lp -1)
nil ; no new dcl needed
t ; flag to create new file
)
)
t ; flag to create new file
)
)
(if (null(wcmatch (strcase fname) "*`.DCL"))
(setq fname (strcat fname ".DCL"))
)
(if (dcl-rev-check fname)
;; create dcl file in same directory as ACAD.PAT
(progn
(setq acadfn (findfile "ACAD.PAT")
fn (strcat (substr acadfn 1 (- (strlen acadfn) 8))fname)
fn (open fn "w")
)
(foreach x (list
"// WARNING file will be recreated if you change the next line"
rvflag
"//BreakAll.DCL"
"BreakDCL : dialog { label = \"[ Break All or Some by CAB v1.8 ]\";"
" : text { label = \"--=< Select type of Break Function needed >=--\"; "
" key = \"tm\"; alignment = centered; fixed_width = true;}"
" spacer_1;"
" : button { key = \"b1\"; mnemonic = \"T\"; alignment = centered;"
" label = \"Break all objects selected with each other\";} "
" : button { key = \"b2\"; mnemonic = \"T\"; alignment = centered;"
" label = \"Break selected objects with other selected objects\";}"
" : button { key = \"b3\"; mnemonic = \"T\"; alignment = centered;"
" label = \" Break selected objects with any objects that touch it\";}"
" spacer_1;"
" : row { spacer_0;"
" : edit_box {key = \"gap\" ; width = 8; mnemonic = \"G\"; label = \"Gap\"; fixed_width = true;}"
" : button { label = \"Help\"; key = \"help\"; mnemonic = \"H\"; fixed_width = true;} "
" cancel_button;"
" spacer_0;"
" }"
"}"
) ; endlist
(princ x fn)
(write-line "" fn)
) ; end foreach
(close fn)
(setq acadfn nil)
(alert (strcat "\nDCL file created, please restart the routine"
"\n again if an error occures."))
t ; return True, file created
)
t ; return True, file found
)
) ; end defun
;;==============================
;; BreakAll Dialog Routine
;;==============================
(defun c:MyBreak(/ dclfile dcl# RunDCL BreakHelp cmd txt2num)
;; return number or nil
(defun txt2num (txt / num)
(if txt
(or (setq num (distof txt 5))
(setq num (distof txt 2))
(setq num (distof txt 1))
(setq num (distof txt 4))
(setq num (distof txt 3))
)
)
(if (numberp num)
num
)
)
(defun mydonedialog (flag)
(setq DCLgap (txt2num (get_tile "gap")))
(done_dialog flag)
)
(defun RunDCL (/ action)
(or DCLgap (setq DCLgap 0)) ; error trap value
(action_tile "b1" "(mydonedialog 1)")
(action_tile "b2" "(mydonedialog 2)")
(action_tile "b3" "(mydonedialog 3)")
(action_tile "gap" "(setq DCLgap (txt2num value$))")
(set_tile "gap" (rtos DCLgap))
(action_tile "help" "(BreakHelp)")
(action_tile "cancel" "(done_dialog 0)")
(setq action (start_dialog))
(or DCLgap (setq DCLgap 0)) ; error trap value
(setq DCLgap (max DCLgap 0)) ; nu negative numbers

(cond
((= action 1) ; BreakAll
(command "_.undo" "_begin")
;; get objects to break
(prompt "\nSelect objects to break with each other & press enter: ")
(if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq NewEnts (Break_with ss ss nil DCLgap) ; ss2break ss2breakwith (flag nil = not to break with self)
; AllEnts (append NewEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
(command "_.undo" "_end")
(princ)
)

((= action 2) ; BreakWith
;; get objects to break
(prompt "\nBreak selected objects with other selected objects.")
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil DCLgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

)
((= action 3) ; BreakSelected
(setq ss1 (ssadd))
;; get objects to break
(prompt "\nBreak selected objects with any objects that touch it.")
(if (and (not (prompt "\nSelect object(s) to break with touching & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss2 ss1 nil DCLgap) ; ss2break ss1breakwith (flag nil = not to break with self)
)
)
)
)
(defun BreakHelp ()
(alert
(strcat
"BreakAll.lsp © 2007-2008 Charles Alan Butler\n\n"
"This LISP routine will break objects based on the routine you select.\n"
"It will not break objects on locked layers and objects must have the same z-value.\n"
"Object types are limited to LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE\n"
"BreakAll - Break all objects selected with each other\n"
"BreakwObject - Break many objects with a single object\n"
"BreakObject - Break a single object with many objects \n"
"BreakWith - Break selected objects with other selected objects\n"
"BreakTouching - Break objects touching selected objects\n"
"BreakSelected - Break selected objects with any objects that touch it\n"
" The Gap distance is the total opening created.\n"
"You may run each routine by entering the function name at the command line.\n"
"For updates & comments contact Charles Alan Butler AKA CAB at TheSwamp.org.\n")
)
)

;;================================================================
;; Start of Routine
;;================================================================
(vl-load-com)
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq dclfile "BreakAll.dcl")
(cond
((not (create_Breakdcl dclfile))
(prompt (strcat "\nCannot create " dclfile "."))
)
((< (setq dcl# (load_dialog dclfile)) 0)
(prompt (strcat "\nCannot load " dclfile "."))
)
((not (new_dialog "BreakDCL" dcl#))
(prompt (strcat "\nProblem with " dclfile "."))
)
((RunDCL)) ; No DCL problems: fire it up
)
(and cmd (setvar "CMDECHO" cmd))
(princ)
)
(prompt "Break routines loaded, Enter Mybreak to run.")
(princ)
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.
;; E n d O f F i l e I f y o u A r e H e r e
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.

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


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Mình sửa cho bạn này:

(DEFUN C:gct ()
(SETQ DK1 (GETVAR "USERR3"))
(IF (= DK1 0)
    (PROGN
     (SETQ STR "1")
     (SETVAR "USERR3" 1)
    )    
    (SETQ STR (RTOS DK1))
)
(SETQ PRPT (STRCAT "\nSize <" STR ">:"))
(SETQ DK1 (GETREAL PRPT))
(IF (= DK1 NIL)
    (SETQ DK1 (GETVAR "USERR3"))
    (SETVAR "USERR3" DK1)
)
(setq dk (* DK1 50))
(INITGET 7)
(SETQ PTD (GETPOINT "\nFrom point:"))
(INITGET 7)
(SETQ PTC (GETPOINT PTD "\nTo point:"))
(SETQ GOCX (ANGLE PTD PTC))
(SETQ GOCY (+ GOCX (/ PI 2)))
(setq v (rtos dk))
(setq t (distance ptd ptc))
(setq r (/ t 2))
(SETQ PT1 (POLAR  PTc  0   (* 33 DK)))
(SETQ o (POLAR  PT1  0   (* 5.2 DK)))
(setq h (substr v 1 1))
(setq y (substr v 2 3))
(setq l (distance ptc pt1))
(setq pt3 (polar ptc 0 (/ l 1.85)))
(setq pt4 (polar pt3 (/ pi 2) (* 4 DK)))
(setq pt5 (polar ptd (- gocx (/ pi 2)) r))
(setq pt6 (polar ptd (+ gocx (/ pi 2)) r))
(setq pt7 (polar ptd (+ gocx  pi) r))
(setq pt8 (polar ptd  gocx   (* 2.8 dk)))
(command "osnap"  "")
(command "layer" "m" "ghichu" "c" "163" """")
(COMMAND "COLOR" "84" "")
(COMMAND "STYLE" "T_THEP"  "romans.shx,vn1.shx" "" "" "" "" "" "" )
(command "text" "j" "m" pt4 (* 5 DK) 0)
(command "%%c10a150" )
 (setq sua (entlast))
(if (= (tblsearch "block" "ghithep_t") nil)
(progn
(COMMAND "STYLE" "VnAvant"  ".VnAvant" "" "" "" "" "")
(command "attdef" "" 1 1 1 "j" "m" o (* 5 50) 0)
(setq ss (ssadd))
(setq ss (ssadd (entlast) ss))
(COMMAND "COLOR" "4" "")
(command "circle" o (* 5.2 50)"")
(setq ss (ssadd (entlast) ss))
(command "block" "ghithep_t" o ss "")
(command "insert" "ghithep_t" o DK1 DK1 "" "1")
)
(command "insert" "ghithep_t" o DK1 DK1 "" "1")
)
(COMMAND "COLOR" "150" "")
(COMMAND "PLINE" ptd "w" "" (* 0.5 dk) pt8  "w" "" 0 pt8 ptc pt1  "")
(COMMAND "COLOR" "BYLAYER" "")
(command "osnap" "End,Mid,Cen,Quad,Int,Perp,Tan,Near,App,Int,Ext,Par"  )
(command "ddedit" sua pause)
)

Chưa hết ý bác ơi.E muốn thay cái mũi tên thành vòng tròn có đường kính 200 và nó cùng với các đường thẳng là một,giống như 1 polyline.Cảm ơn bác nhiều.

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


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Lisp tp của bạn cắt rất tốt, nhưng chiỉ sử dụng qua 2 đường thằng. Nhưng khi đường pline có nhiều đoạn thì ó chiỉ cắt trên độạn, bạn giúp lại mình đi

http://www.cadviet.com/upfiles/3/biendong1.dwg

Hề hề hề,

Không phải là không phải đâu. Bạn phải nói là khi lề trái hoặc phải được cấu tạo bởi nhiều pline hay nhiều line chứ không phải là 1 line duy nhất thì mới đúng.

Cách sửa có hai cách:

1/- Bạn vẽ lại 1 pline duy nhất qua các điểm đã có.

2/- Làm như bác phamngoctukts đã nói.

 

Còn cái cách lười nhất là nhờ viết lại lisp thì bạn phải chịu khó chờ chút xíu hè.....

Hề hề hề,...

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


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

Không phải là không phải đâu. Bạn phải nói là khi lề trái hoặc phải được cấu tạo bởi nhiều pline hay nhiều line chứ không phải là 1 line duy nhất thì mới đúng.

Cách sửa có hai cách:

1/- Bạn vẽ lại 1 pline duy nhất qua các điểm đã có.

2/- Làm như bác phamngoctukts đã nói.

 

Còn cái cách lười nhất là nhờ viết lại lisp thì bạn phải chịu khó chờ chút xíu hè.....

Hề hề hề,...

Chào Bác Bình!

Cái này em đã sửa cho bạn ở trên rồi Bác không phải nhọc lòng nữa đâu.

Đúng là lisp không chạy được với các đường pline nhiều đoạn. VÌ cai file đầu bạn up lên đường pline có mỗi 1 đoạn nên em chỉ lấy có 4 điểm để vẽ đa giác.

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


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Xin lỗi vì mình không hiểu ý bạn. Mình sửa cho bạn rồi đây:

Hề hề hề,

Bác Phamngoctukts ơi,

Hình như bác sửa bị sót cái điểm mp bác ạ. Việc chọn cái điểm này cũng khá lôi thôi khi mà cái đường biên l1 và l2 nó loằng ngoằng bác ạ. Thế nên theo mình thiển nghĩ thì ta cú chỉ định phứt là l1 là đường biên trái hoặc trên, l2 là dường biên phải hay dưới căn cứ vào cái vị trí chọn bác ạ. Từ đó ta lấy mp dựa vào một điểm trên l1 hoặc l2 sẽ đỡ bị rối hơn. Hoặc bắt người dùng chọn mp vào trong vùng cần xóa cho nó chắc cú.

Bác thử xem lại chỗ này nhé.

Hề hề hề,

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


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

Bác Phamngoctukts ơi,

Hình như bác sửa bị sót cái điểm mp bác ạ. Việc chọn cái điểm này cũng khá lôi thôi khi mà cái đường biên l1 và l2 nó loằng ngoằng bác ạ. Thế nên theo mình thiển nghĩ thì ta cú chỉ định phứt là l1 là đường biên trái hoặc trên, l2 là dường biên phải hay dưới căn cứ vào cái vị trí chọn bác ạ. Từ đó ta lấy mp dựa vào một điểm trên l1 hoặc l2 sẽ đỡ bị rối hơn. Hoặc bắt người dùng chọn mp vào trong vùng cần xóa cho nó chắc cú.

Bác thử xem lại chỗ này nhé.

Hề hề hề,

Chào Bác bình!

Hê hê trường hợp này đâu càn phải xác định điểm mp. Em sửa lại thế này Bác xem thế nào.

;; free lisp from cadviet.com

;; free lisp from cadviet.com

(defun c:tg ()
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq l1 (car (entsel "\nChon duong thu nhat: "))
l2 (car (entsel "\nChon duong thu hai: "))
;;;;;; p (getpoint "\Pick 1 diem ben ngoai ban ve: ")
ls1 (acet-geom-vertex-list l1)
;p2 (cadr (acet-geom-vertex-list l1))
ls2 (acet-geom-vertex-list l2)
;p4 (cadr (acet-geom-vertex-list l2))
)
(command "pline")
 (setq i 0)
 (repeat (length ls1)
   (command (nth i ls1))
   (setq i (1+ i))
   )
(if (> (distance (car ls1) (car ls2)) (distance (car ls1) (last ls2)))
(progn
 (setq i 0)
 (repeat (length ls2)
   (command (nth i ls2))
   (setq i (1+ i))
   )
(command "c")
)
(progn
 (setq i 0)
 (setq ls2 (reverse ls2))
 (repeat (length ls2)
   (command (nth i ls2))
   (setq i (1+ i))
   )
(command "c")
)
)
(setq el (entlast))
;;(command "offset" 0.1 el mp "")
;;(setq in (entlast))
;;;;;;;;;;;(command "offset" 0.1 el p "")
;;;;;;;;;;;(setq out (entlast))
;;;;;;;;;;;(setq lsp (acet-geom-vertex-list el))
;;;;;;;;;;;(setq ss (ssget "cp" lsp))
;;;;;;;;;;;;;(setq ss (ssdel el ss))
;;;;;;;;;;(setq ss (ssdel in ss))
;;;;;;;;;;;;;(command "copy" ss "" mp p "")
;;;;;;;;;;;;;;;(command "copy" el "" mp p "")
;;;;;;;;;;;;(setq elc (entlast))
;;;;;;;;;;;;;;;(command "move" out "" mp p)
;;;;;;;;;;;;;;(setq lsout (acet-geom-vertex-list out))
;;;;;;;;;;;(entdel out)
;;;;;;;;;;;;;;(repeat 5
;;;;;;;;;;;;;;;;;(setq i 0)
;;;;;;;;;;;;;;;;;(command "trim" elc "" "f")
;;;;;;;;;;;;;;;(repeat (length lsout)
;;;;;;;;;;;;;;(command (nth i lsout))
;;;;;;;;;;;;;;;;(setq i (1+ i))
;;;;;;;;;;;;;;;:s_big:
;;;;;;;;;;;;(command "" "")
;;;;;;;;;;;;;;:leluoi:
;;;;;;;;;;;;(setq lsin (acet-geom-vertex-list in))
;;;;;;;;;;;;(entdel in)
;;;;;;;;;;;;(repeat 5
;;;;;;;;;;;;;;;(setq i 0)
;;;;;;;;;;;(command "trim" el "" "f")
;;;;;;;;;;(repeat (length lsin)
;;;;;;;;;;;;;;(command (nth i lsin))
;;;;;;;;;;;;;;;;;;;(setq i (1+ i))
;;;;;;;;;;;;;;;:cheers:
;;;;;;;;;;;;;;;;;(command "" "")
;;;;;;;;;;;;;;;:D
;;;;;;;;;;;;;;;;;(command "erase" (ssget "wp" lsp) "")
;;;;;;;;;;;;;(setq lselc (acet-geom-vertex-list elc))
;;;;;;;;;;;;;;;;(entdel elc)
;;;;;;;;;;;;;;;;(setq tt (ssget "cp" lselc))
;;;;;;;;;;;;;;;;;;(command "move" tt "" p mp)
(setq els (ssadd))
(setq els (ssadd el els))
(breakwithtouching els)
(setq tt (ssget "wp" (acet-geom-vertex-list el)))
(command "change" tt "" "p" "la" "biendong" "c" "bylayer" "")
(entdel el)
(entdel in)
(setvar "osmode" oldos)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;;;;;

(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
;;========================================
;; New as per version 1.8 [brkGap] --- This subroutine has been re-written
;; Loop through the break points breaking the entity
;; If the entity is not a closed entity then a new object is created
;; This object is added to a list. When break points don't fall on the current
;; entity the list of new entities are searched to locate the entity that the
;; point is on so it can be broken.
;; "Break with a Gap" has been added to this routine. The problem faced with
;; this method is that sections to be removed may lap if the break points are
;; too close to each other. The solution is to create a list of break point pairs
;; representing the gap to be removed and test to see if there i an overlap. If
;; there is then merge the break point pairs into one large gap. This way the
;; points will always fall on an object with one exception. If the gap is too near
;; the end of an object one break point will be off the end and therefore that
;; point will need to be replaced with the end point.
;; NOTE: in ACAD2000 the (vlax-curve-getdistatpoint function has proven unreliable
;; so I have used (vlax-curve-getdistatparam in most cases
(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

;; setup brkptlst with pair of break pts ((p1 p2)(p3 p4)...)
;; one of the pair of points will be on the object that
;; needs to be broken
(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
)
)
)
)
)
)
)
;| ;; ver 2.0 fix - removed this code as there are cases where the break point
;; is at the end of a line which is not a valid break but does no harm
(if (and brkobjlst idx (minusp idx)
(null (alert (strcat "Error - point not on object"
"\nPlease report this error to"
"\n CAB at TheSwamp.org"))))
(exit)
)
|;
;; (if (equal (if (null a)(setq a (car(entsel"\nTest Ent"))) a) ent) (princ)) ; debug CAB -------------

;; Handle any objects that can not be used with the Break Command
;; using one point, gap of 0.000001 is used
(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)
)
)
;; single breakpoint ----------------------------------------------------
;|(if (and closedobj ; problems with ACAD200 & this code
(not (setq brkptE (vlax-curve-getPointAtDist obj2break
(+ (vlax-curve-getDistAtPoint obj2break brkptS) 0.00001))))
)
(setq brkptE (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getDistAtPoint obj2break brkptS) 0.00001)))

)|;
(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
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; E N D O F M A I N S U B R O U T I N E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; M A I N S U B F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;;======================
;; Redraw ss with mode
;;======================
(defun ssredraw (ss mode / i num)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(redraw (ssname ss i) mode)
)
)

;;===========================================================================
;; 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 (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 410 (getvar "ctab"))))
)
(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
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; E N D M A I N F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;===============================================
;; Break all objects selected with each other
;;===============================================
(defun c:BreakAll (/ cmd ss NewEnts AllEnts tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nSelect objects to break with each other & press enter: ")
(if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq NewEnts (Break_with ss ss nil Bgap) ; ss2break ss2breakwith (flag nil = not to break with self)
; AllEnts (append NewEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;===========================================
;; Break a single object with other objects
;;===========================================
(defun c:BreakObject (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)

;; get objects to break
(prompt "\nSelect single object to break: ")
(if (and (setq ss1 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (redraw (ssname ss1 0) 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (redraw (ssname ss1 0) 4)))
(Break_with ss1 ss2 nil Bgap) ; ss2break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;==========================================
;; Break many objects with a single object
;;==========================================
(defun c:BreakWobject (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select single object to break with: ***"))
(setq ss2 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;==========================================
;; Break objects with objects on a layer
;;==========================================
;; New 08/01/2008
(defun c:BreakWlayer (/ cmd ss1 ss2 tmp lay)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\n*** Select single object for break layer: ***")

(if (and (setq ss2 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq lay (assoc 8 (entget (ssname ss2 0))))
(setq ss2 (ssget "_X" (list
'(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
lay (cons 410 (getvar "ctab")))))
(not (prompt "\nSelect object(s) to break & press enter: "))
(setq ss1 (ssget (list
'(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 8 (strcat "~" (cdr lay))))))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;======================================================
;; Break selected objects with other selected objects
;;======================================================
(defun c:BreakWith (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak selected objects with other selected objects.")
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;=============================================
;; Break objects touching selected objects
;;=============================================

(defun c:BreakTouching (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak objects touching selected objects.")
(if (and (not (prompt "\nSelect object(s) to break & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;=================================================
;; Break touching objects with selected objects
;;=================================================
;; New 08/01/2008
(defun BreakWithTouching ( ss2 / cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)

;; get objects to break
(prompt "\nBreak objects touching selected objects.")
(prompt "\nSelect object(s) to break with & press enter: ")
(if 
(and 
;;;;;;;;;(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
ss2
(setq tlst (gettouching ss2))
)
(progn
(setq tlst (vl-remove-if '(lambda (x)(ssmemb x ss2)) tlst)) ; remove if in picked ss
(mapcar '(lambda (x) (ssadd x ss1)) tlst) ; convert to a selection set
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;==========================================================
;; Break selected objects with any objects that touch it
;;==========================================================
(defun c:BreakSelected (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak selected objects with any objects that touch it.")
(if (and (not (prompt "\nSelect object(s) to break with touching & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss2 ss1 nil Bgap) ; ss2break ss1breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;; ***************************************************
;; Function to create a dcl support file if it
;; does not exist
;; Usage : (create_dcl "file name")
;; Returns : T if successful else nil
;; ***************************************************
(defun create_Breakdcl (fname / acadfn dcl-rev-check)
;;=======================================
;; check revision date Routine
;;=======================================
(defun dcl-rev-check (fn / rvdate ln lp)
;; revision flag must match exactly and must
;; begin with //
(setq rvflag "// Revision Control 05/12/2008@14:11" )
(if (setq fn (findfile fn))
(progn ; check rev date
(setq lp 5) ; read 4 lines
(setq fn (open fn "r")) ; open file for reading
(while (> (setq lp (1- lp)) 0)
(setq ln (read-line fn)) ; get a line from file
(if (vl-string-search rvflag ln)
(setq lp 0)
)
)
(close fn) ; close the open file handle
(if (= lp -1)
nil ; no new dcl needed
t ; flag to create new file
)
)
t ; flag to create new file
)
)
(if (null(wcmatch (strcase fname) "*`.DCL"))
(setq fname (strcat fname ".DCL"))
)
(if (dcl-rev-check fname)
;; create dcl file in same directory as ACAD.PAT
(progn
(setq acadfn (findfile "ACAD.PAT")
fn (strcat (substr acadfn 1 (- (strlen acadfn) 8))fname)
fn (open fn "w")
)
(foreach x (list
"// WARNING file will be recreated if you change the next line"
rvflag
"//BreakAll.DCL"
"BreakDCL : dialog { label = \"[ Break All or Some by CAB v1.8 ]\";"
" : text { label = \"--=< Select type of Break Function needed >=--\"; "
" key = \"tm\"; alignment = centered; fixed_width = true;}"
" spacer_1;"
" : button { key = \"b1\"; mnemonic = \"T\"; alignment = centered;"
" label = \"Break all objects selected with each other\";} "
" : button { key = \"b2\"; mnemonic = \"T\"; alignment = centered;"
" label = \"Break selected objects with other selected objects\";}"
" : button { key = \"b3\"; mnemonic = \"T\"; alignment = centered;"
" label = \" Break selected objects with any objects that touch it\";}"
" spacer_1;"
" : row { spacer_0;"
" : edit_box {key = \"gap\" ; width = 8; mnemonic = \"G\"; label = \"Gap\"; fixed_width = true;}"
" : button { label = \"Help\"; key = \"help\"; mnemonic = \"H\"; fixed_width = true;} "
" cancel_button;"
" spacer_0;"
" }"
"}"
) ; endlist
(princ x fn)
(write-line "" fn)
) ; end foreach
(close fn)
(setq acadfn nil)
(alert (strcat "\nDCL file created, please restart the routine"
"\n again if an error occures."))
t ; return True, file created
)
t ; return True, file found
)
) ; end defun
;;==============================
;; BreakAll Dialog Routine
;;==============================
(defun c:MyBreak(/ dclfile dcl# RunDCL BreakHelp cmd txt2num)
;; return number or nil
(defun txt2num (txt / num)
(if txt
(or (setq num (distof txt 5))
(setq num (distof txt 2))
(setq num (distof txt 1))
(setq num (distof txt 4))
(setq num (distof txt 3))
)
)
(if (numberp num)
num
)
)
(defun mydonedialog (flag)
(setq DCLgap (txt2num (get_tile "gap")))
(done_dialog flag)
)
(defun RunDCL (/ action)
(or DCLgap (setq DCLgap 0)) ; error trap value
(action_tile "b1" "(mydonedialog 1)")
(action_tile "b2" "(mydonedialog 2)")
(action_tile "b3" "(mydonedialog 3)")
(action_tile "gap" "(setq DCLgap (txt2num value$))")
(set_tile "gap" (rtos DCLgap))
(action_tile "help" "(BreakHelp)")
(action_tile "cancel" "(done_dialog 0)")
(setq action (start_dialog))
(or DCLgap (setq DCLgap 0)) ; error trap value
(setq DCLgap (max DCLgap 0)) ; nu negative numbers

(cond
((= action 1) ; BreakAll
(command "_.undo" "_begin")
;; get objects to break
(prompt "\nSelect objects to break with each other & press enter: ")
(if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq NewEnts (Break_with ss ss nil DCLgap) ; ss2break ss2breakwith (flag nil = not to break with self)
; AllEnts (append NewEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
(command "_.undo" "_end")
(princ)
)

((= action 2) ; BreakWith
;; get objects to break
(prompt "\nBreak selected objects with other selected objects.")
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil DCLgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

)
((= action 3) ; BreakSelected
(setq ss1 (ssadd))
;; get objects to break
(prompt "\nBreak selected objects with any objects that touch it.")
(if (and (not (prompt "\nSelect object(s) to break with touching & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss2 ss1 nil DCLgap) ; ss2break ss1breakwith (flag nil = not to break with self)
)
)
)
)
(defun BreakHelp ()
(alert
(strcat
"BreakAll.lsp © 2007-2008 Charles Alan Butler\n\n"
"This LISP routine will break objects based on the routine you select.\n"
"It will not break objects on locked layers and objects must have the same z-value.\n"
"Object types are limited to LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE\n"
"BreakAll - Break all objects selected with each other\n"
"BreakwObject - Break many objects with a single object\n"
"BreakObject - Break a single object with many objects \n"
"BreakWith - Break selected objects with other selected objects\n"
"BreakTouching - Break objects touching selected objects\n"
"BreakSelected - Break selected objects with any objects that touch it\n"
" The Gap distance is the total opening created.\n"
"You may run each routine by entering the function name at the command line.\n"
"For updates & comments contact Charles Alan Butler AKA CAB at TheSwamp.org.\n")
)
)

;;================================================================
;; Start of Routine
;;================================================================
(vl-load-com)
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq dclfile "BreakAll.dcl")
(cond
((not (create_Breakdcl dclfile))
(prompt (strcat "\nCannot create " dclfile "."))
)
((< (setq dcl# (load_dialog dclfile)) 0)
(prompt (strcat "\nCannot load " dclfile "."))
)
((not (new_dialog "BreakDCL" dcl#))
(prompt (strcat "\nProblem with " dclfile "."))
)
((RunDCL)) ; No DCL problems: fire it up
)
(and cmd (setvar "CMDECHO" cmd))
(princ)
)
(prompt "Break routines loaded, Enter Mybreak to run.")
(princ)
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.
;; E n d O f F i l e I f y o u A r e H e r e
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.

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


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

Kính chào bác gia bạch, và các anh trên diễn đàn, em dùng ứng dụng Autocad.net API.dll trích xuất text trong bản vã sang exel, khi xuất text qua exel thì tất cả các text đều nằm cùng 1 cột, bác Gia Bạch và các anh trên diễn đàn có cách nào xuất text qua exel mà text thuộc layer sothua nằm 1 cột, text Loaidat nằm 1 cột, text dt-GCN nằm 1 cột nhưng 3 text sothua, Loaidat, dt-GCN cùng 1 thửa khi qua exel thì nằm cùng 1 hàng. file cad em làm vd để xuất text http://www.cadviet.com/upfiles/3/xuattext_1.dwg, file exel em đạc được và kết quả cuối cùng http://www.cadviet.com/upfiles/3/text_1.rar, đây là ứng dụng Autocad.net APi.dll em dùng để xuất text http://www.cadviet.com/upfiles/3/megashare...tetoexcel_3.zip

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


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Mình sửa cho bạn này:

(DEFUN C:gct ()
(SETQ DK1 (GETVAR "USERR3"))
(IF (= DK1 0)
    (PROGN
     (SETQ STR "1")
     (SETVAR "USERR3" 1)
    )    
    (SETQ STR (RTOS DK1))
)
(SETQ PRPT (STRCAT "\nSize <" STR ">:"))
(SETQ DK1 (GETREAL PRPT))
(IF (= DK1 NIL)
    (SETQ DK1 (GETVAR "USERR3"))
    (SETVAR "USERR3" DK1)
)
(setq dk (* DK1 50))
(INITGET 7)
(SETQ PTD (GETPOINT "\nFrom point:"))
(INITGET 7)
(SETQ PTC (GETPOINT PTD "\nTo point:"))
(SETQ GOCX (ANGLE PTD PTC))
(SETQ GOCY (+ GOCX (/ PI 2)))
(setq v (rtos dk))
(setq t (distance ptd ptc))
(setq r (/ t 2))
(SETQ PT1 (POLAR  PTc  0   (* 33 DK)))
(SETQ o (POLAR  PT1  0   (* 5.2 DK)))
(setq h (substr v 1 1))
(setq y (substr v 2 3))
(setq l (distance ptc pt1))
(setq pt3 (polar ptc 0 (/ l 1.85)))
(setq pt4 (polar pt3 (/ pi 2) (* 4 DK)))
(setq pt5 (polar ptd (- gocx (/ pi 2)) r))
(setq pt6 (polar ptd (+ gocx (/ pi 2)) r))
(setq pt7 (polar ptd (+ gocx  pi) r))
(setq pt8 (polar ptd  gocx   (* 2.8 dk)))
(command "osnap"  "")
(command "layer" "m" "ghichu" "c" "163" """")
(COMMAND "COLOR" "84" "")
(COMMAND "STYLE" "T_THEP"  "romans.shx,vn1.shx" "" "" "" "" "" "" )
(command "text" "j" "m" pt4 (* 5 DK) 0)
(command "%%c10a150" )
 (setq sua (entlast))
(if (= (tblsearch "block" "ghithep_t") nil)
(progn
(COMMAND "STYLE" "VnAvant"  ".VnAvant" "" "" "" "" "")
(command "attdef" "" 1 1 1 "j" "m" o (* 5 50) 0)
(setq ss (ssadd))
(setq ss (ssadd (entlast) ss))
(COMMAND "COLOR" "4" "")
(command "circle" o (* 5.2 50)"")
(setq ss (ssadd (entlast) ss))
(command "block" "ghithep_t" o ss "")
(command "insert" "ghithep_t" o DK1 DK1 "" "1")
)
(command "insert" "ghithep_t" o DK1 DK1 "" "1")
)
(COMMAND "COLOR" "150" "")
(COMMAND "PLINE" ptd "w" "" (* 0.5 dk) pt8  "w" "" 0 pt8 ptc pt1  "")
(COMMAND "COLOR" "BYLAYER" "")
(command "osnap" "End,Mid,Cen,Quad,Int,Perp,Tan,Near,App,Int,Ext,Par"  )
(command "ddedit" sua pause)
)

Chưa hết ý bác ơi.E muốn thay cái mũi tên thành vòng tròn có đường kính 200 và nó cùng với các đường thẳng là một,giống như 1 polyline.Cảm ơn các bác nhiều. Các bác không giúp được e sao?

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


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Chưa hết ý bác ơi.E muốn thay cái mũi tên thành vòng tròn có đường kính 200 và nó cùng với các đường thẳng là một,giống như 1 polyline.Cảm ơn các bác nhiều. Các bác không giúp được e sao?

Chào bạn hugo75!

Bạn đã nghe câu này chưa "Đợi chờ là hanh phúc" đó bạn. Chưa gì bạn đã kêu rồi sẽ đến lượt bạn.

;; free lisp from cadviet.com

(DEFUN C:gct ()
(SETQ DK1 (GETVAR "USERR3"))
(IF (= DK1 0)
    (PROGN
     (SETQ STR "1")
     (SETVAR "USERR3" 1)
    )    
    (SETQ STR (RTOS DK1))
)
(SETQ PRPT (STRCAT "\nSize <" STR ">:"))
(SETQ DK1 (GETREAL PRPT))
(IF (= DK1 NIL)
    (SETQ DK1 (GETVAR "USERR3"))
    (SETVAR "USERR3" DK1)
)
(setq dk (* DK1 50))
(INITGET 7)
(SETQ PTD (GETPOINT "\nFrom point:"))
(INITGET 7)
(SETQ PTC (GETPOINT PTD "\nTo point:"))
(SETQ GOCX (ANGLE PTD PTC))
(SETQ GOCY (+ GOCX (/ PI 2)))
(setq v (rtos dk))
(setq t (distance ptd ptc))
(setq r (/ t 2))
(SETQ PT1 (POLAR  PTc  0   (* 33 DK)))
(SETQ o (POLAR  PT1  0   (* 5.2 DK)))
(setq h (substr v 1 1))
(setq y (substr v 2 3))
(setq l (distance ptc pt1))
(setq pt3 (polar ptc 0 (/ l 1.85)))
(setq pt4 (polar pt3 (/ pi 2) (* 4 DK)))
(setq pt5 (polar ptd (- gocx (/ pi 2)) r))
(setq pt6 (polar ptd (+ gocx (/ pi 2)) r))
(setq pt7 (polar ptd (+ gocx  pi) r))
(setq pt8 (polar ptd  gocx   100))
(command "osnap"  "")
(command "layer" "m" "ghichu" "c" "163" """")
(COMMAND "COLOR" "84" "")
(COMMAND "STYLE" "T_THEP"  "romans.shx,vn1.shx" "" "" "" "" "" "" )
(command "text" "j" "m" pt4 (* 5 DK) 0)
(command "%%c10a150" )
 (setq sua (entlast))
(if (= (tblsearch "block" "ghithep_t") nil)
(progn
(COMMAND "STYLE" "VnAvant"  ".VnAvant" "" "" "" "" "")
(command "attdef" "" 1 1 1 "j" "m" o (* 5 50) 0)
(setq ss (ssadd))
(setq ss (ssadd (entlast) ss))
(COMMAND "COLOR" "4" "")
(command "circle" o (* 5.2 50)"")
(setq ss (ssadd (entlast) ss))
(COMMAND "COLOR" "150" "")
(COMMAND "PLINE" pt8 ptc pt1 "")
(setq ss (ssadd (entlast) ss))
(command "circle" ptd 100 "")
(setq ss (ssadd (entlast) ss))
(command "block" "ghithep_t" ptd ss "")
(command "insert" "ghithep_t" ptd DK1 DK1 "" "1")
)
(command "insert" "ghithep_t" ptd DK1 DK1 "" "1")
)
(COMMAND "COLOR" "BYLAYER" "")
(command "osnap" "End,Mid,Cen,Quad,Int,Perp,Tan,Near,App,Int,Ext,Par"  )
(command "ddedit" sua pause)
)

  • Vote tăng 1

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


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Đã giải quyết vấn đề các đường là pline qua nhều điểm . nhưng còn hạn chế , sau khi cắt thì không chọn hết các cạnh đưa về lớp biendong.

Mong duoc ban giup

Vì mình chưa nghĩ ra cách xác định điểm mp nên bạn chịu khó pick thêm 1 điểm vào giữa 2 đường ranh giới nhé.

;; free lisp from cadviet.com

;; free lisp from cadviet.com

(defun c:tg ()
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq l1 (car (entsel "\nChon duong thu nhat: "))
l2 (car (entsel "\nChon duong thu hai: "))
;;;;;; p (getpoint "\Pick 1 diem ben ngoai ban ve: ")
ls1 (acet-geom-vertex-list l1)
;p2 (cadr (acet-geom-vertex-list l1))
ls2 (acet-geom-vertex-list l2)
;p4 (cadr (acet-geom-vertex-list l2))
pin (getpoint "\nPick diem giua hai duong ranh gioi ")
)
(command "pline")
 (setq i 0)
 (repeat (length ls1)
   (command (nth i ls1))
   (setq i (1+ i))
   )
(if (> (distance (car ls1) (car ls2)) (distance (car ls1) (last ls2)))
(progn
 (setq i 0)
 (repeat (length ls2)
   (command (nth i ls2))
   (setq i (1+ i))
   )
(command "c")
)
(progn
 (setq i 0)
 (setq ls2 (reverse ls2))
 (repeat (length ls2)
   (command (nth i ls2))
   (setq i (1+ i))
   )
(command "c")
)
)
(setq el (entlast))
 (command "offset" 0.5 el pin "")
 (setq elin (entlast))
;;(command "offset" 0.1 el mp "")
;;(setq in (entlast))
;;;;;;;;;;;(command "offset" 0.1 el p "")
;;;;;;;;;;;(setq out (entlast))
;;;;;;;;;;;(setq lsp (acet-geom-vertex-list el))
;;;;;;;;;;;(setq ss (ssget "cp" lsp))
;;;;;;;;;;;;;(setq ss (ssdel el ss))
;;;;;;;;;;(setq ss (ssdel in ss))
;;;;;;;;;;;;;(command "copy" ss "" mp p "")
;;;;;;;;;;;;;;;(command "copy" el "" mp p "")
;;;;;;;;;;;;(setq elc (entlast))
;;;;;;;;;;;;;;;(command "move" out "" mp p)
;;;;;;;;;;;;;;(setq lsout (acet-geom-vertex-list out))
;;;;;;;;;;;(entdel out)
;;;;;;;;;;;;;;(repeat 5
;;;;;;;;;;;;;;;;;(setq i 0)
;;;;;;;;;;;;;;;;;(command "trim" elc "" "f")
;;;;;;;;;;;;;;;(repeat (length lsout)
;;;;;;;;;;;;;;(command (nth i lsout))
;;;;;;;;;;;;;;;;(setq i (1+ i))
;;;;;;;;;;;;;;;:s_big:
;;;;;;;;;;;;(command "" "")
;;;;;;;;;;;;;;:leluoi:
;;;;;;;;;;;;(setq lsin (acet-geom-vertex-list in))
;;;;;;;;;;;;(entdel in)
;;;;;;;;;;;;(repeat 5
;;;;;;;;;;;;;;;(setq i 0)
;;;;;;;;;;;(command "trim" el "" "f")
;;;;;;;;;;(repeat (length lsin)
;;;;;;;;;;;;;;(command (nth i lsin))
;;;;;;;;;;;;;;;;;;;(setq i (1+ i))
;;;;;;;;;;;;;;;:cheers:
;;;;;;;;;;;;;;;;;(command "" "")
;;;;;;;;;;;;;;;:D
;;;;;;;;;;;;;;;;;(command "erase" (ssget "wp" lsp) "")
;;;;;;;;;;;;;(setq lselc (acet-geom-vertex-list elc))
;;;;;;;;;;;;;;;;(entdel elc)
;;;;;;;;;;;;;;;;(setq tt (ssget "cp" lselc))
;;;;;;;;;;;;;;;;;;(command "move" tt "" p mp)
(setq els (ssadd))
(setq els (ssadd el els))
(breakwithtouching els)
(setq tt (ssget "cp" (acet-geom-vertex-list elin)))
(command "change" tt "" "p" "la" "biendong" "c" "bylayer" "")
(entdel el)
(entdel elin)
(setvar "osmode" oldos)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;;;;;

(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
;;========================================
;; New as per version 1.8 [brkGap] --- This subroutine has been re-written
;; Loop through the break points breaking the entity
;; If the entity is not a closed entity then a new object is created
;; This object is added to a list. When break points don't fall on the current
;; entity the list of new entities are searched to locate the entity that the
;; point is on so it can be broken.
;; "Break with a Gap" has been added to this routine. The problem faced with
;; this method is that sections to be removed may lap if the break points are
;; too close to each other. The solution is to create a list of break point pairs
;; representing the gap to be removed and test to see if there i an overlap. If
;; there is then merge the break point pairs into one large gap. This way the
;; points will always fall on an object with one exception. If the gap is too near
;; the end of an object one break point will be off the end and therefore that
;; point will need to be replaced with the end point.
;; NOTE: in ACAD2000 the (vlax-curve-getdistatpoint function has proven unreliable
;; so I have used (vlax-curve-getdistatparam in most cases
(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

;; setup brkptlst with pair of break pts ((p1 p2)(p3 p4)...)
;; one of the pair of points will be on the object that
;; needs to be broken
(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
)
)
)
)
)
)
)
;| ;; ver 2.0 fix - removed this code as there are cases where the break point
;; is at the end of a line which is not a valid break but does no harm
(if (and brkobjlst idx (minusp idx)
(null (alert (strcat "Error - point not on object"
"\nPlease report this error to"
"\n CAB at TheSwamp.org"))))
(exit)
)
|;
;; (if (equal (if (null a)(setq a (car(entsel"\nTest Ent"))) a) ent) (princ)) ; debug CAB -------------

;; Handle any objects that can not be used with the Break Command
;; using one point, gap of 0.000001 is used
(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)
)
)
;; single breakpoint ----------------------------------------------------
;|(if (and closedobj ; problems with ACAD200 & this code
(not (setq brkptE (vlax-curve-getPointAtDist obj2break
(+ (vlax-curve-getDistAtPoint obj2break brkptS) 0.00001))))
)
(setq brkptE (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getDistAtPoint obj2break brkptS) 0.00001)))

)|;
(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
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; E N D O F M A I N S U B R O U T I N E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; M A I N S U B F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;;======================
;; Redraw ss with mode
;;======================
(defun ssredraw (ss mode / i num)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(redraw (ssname ss i) mode)
)
)

;;===========================================================================
;; 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 (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 410 (getvar "ctab"))))
)
(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
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; E N D M A I N F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;===============================================
;; Break all objects selected with each other
;;===============================================
(defun c:BreakAll (/ cmd ss NewEnts AllEnts tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nSelect objects to break with each other & press enter: ")
(if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq NewEnts (Break_with ss ss nil Bgap) ; ss2break ss2breakwith (flag nil = not to break with self)
; AllEnts (append NewEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;===========================================
;; Break a single object with other objects
;;===========================================
(defun c:BreakObject (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)

;; get objects to break
(prompt "\nSelect single object to break: ")
(if (and (setq ss1 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (redraw (ssname ss1 0) 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (redraw (ssname ss1 0) 4)))
(Break_with ss1 ss2 nil Bgap) ; ss2break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;;==========================================
;; Break many objects with a single object
;;==========================================
(defun c:BreakWobject (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select single object to break with: ***"))
(setq ss2 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;==========================================
;; Break objects with objects on a layer
;;==========================================
;; New 08/01/2008
(defun c:BreakWlayer (/ cmd ss1 ss2 tmp lay)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\n*** Select single object for break layer: ***")

(if (and (setq ss2 (ssget "+.:E:S" '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq lay (assoc 8 (entget (ssname ss2 0))))
(setq ss2 (ssget "_X" (list
'(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
lay (cons 410 (getvar "ctab")))))
(not (prompt "\nSelect object(s) to break & press enter: "))
(setq ss1 (ssget (list
'(0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 8 (strcat "~" (cdr lay))))))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;======================================================
;; Break selected objects with other selected objects
;;======================================================
(defun c:BreakWith (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak selected objects with other selected objects.")
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;=============================================
;; Break objects touching selected objects
;;=============================================

(defun c:BreakTouching (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak objects touching selected objects.")
(if (and (not (prompt "\nSelect object(s) to break & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;=================================================
;; Break touching objects with selected objects
;;=================================================
;; New 08/01/2008
(defun BreakWithTouching ( ss2 / cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)

;; get objects to break
(prompt "\nBreak objects touching selected objects.")
(prompt "\nSelect object(s) to break with & press enter: ")
(if 
(and 
;;;;;;;;;(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
ss2
(setq tlst (gettouching ss2))
)
(progn
(setq tlst (vl-remove-if '(lambda (x)(ssmemb x ss2)) tlst)) ; remove if in picked ss
(mapcar '(lambda (x) (ssadd x ss1)) tlst) ; convert to a selection set
(break_with ss1 ss2 nil Bgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)
;;==========================================================
;; Break selected objects with any objects that touch it
;;==========================================================
(defun c:BreakSelected (/ cmd ss1 ss2 tmp)

(command "_.undo" "_begin")
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq ss1 (ssadd))
(or Bgap (setq Bgap 0)) ; default
(initget 4) ; no negative numbers
(if (setq tmp (getdist (strcat "\nEnter Break Gap.<"(rtos Bgap)"> ")))
(setq Bgap tmp)
)
;; get objects to break
(prompt "\nBreak selected objects with any objects that touch it.")
(if (and (not (prompt "\nSelect object(s) to break with touching & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss2 ss1 nil Bgap) ; ss2break ss1breakwith (flag nil = not to break with self)
)

(setvar "CMDECHO" cmd)
(command "_.undo" "_end")
(princ)
)

;; ***************************************************
;; Function to create a dcl support file if it
;; does not exist
;; Usage : (create_dcl "file name")
;; Returns : T if successful else nil
;; ***************************************************
(defun create_Breakdcl (fname / acadfn dcl-rev-check)
;;=======================================
;; check revision date Routine
;;=======================================
(defun dcl-rev-check (fn / rvdate ln lp)
;; revision flag must match exactly and must
;; begin with //
(setq rvflag "// Revision Control 05/12/2008@14:11" )
(if (setq fn (findfile fn))
(progn ; check rev date
(setq lp 5) ; read 4 lines
(setq fn (open fn "r")) ; open file for reading
(while (> (setq lp (1- lp)) 0)
(setq ln (read-line fn)) ; get a line from file
(if (vl-string-search rvflag ln)
(setq lp 0)
)
)
(close fn) ; close the open file handle
(if (= lp -1)
nil ; no new dcl needed
t ; flag to create new file
)
)
t ; flag to create new file
)
)
(if (null(wcmatch (strcase fname) "*`.DCL"))
(setq fname (strcat fname ".DCL"))
)
(if (dcl-rev-check fname)
;; create dcl file in same directory as ACAD.PAT
(progn
(setq acadfn (findfile "ACAD.PAT")
fn (strcat (substr acadfn 1 (- (strlen acadfn) 8))fname)
fn (open fn "w")
)
(foreach x (list
"// WARNING file will be recreated if you change the next line"
rvflag
"//BreakAll.DCL"
"BreakDCL : dialog { label = \"[ Break All or Some by CAB v1.8 ]\";"
" : text { label = \"--=< Select type of Break Function needed >=--\"; "
" key = \"tm\"; alignment = centered; fixed_width = true;}"
" spacer_1;"
" : button { key = \"b1\"; mnemonic = \"T\"; alignment = centered;"
" label = \"Break all objects selected with each other\";} "
" : button { key = \"b2\"; mnemonic = \"T\"; alignment = centered;"
" label = \"Break selected objects with other selected objects\";}"
" : button { key = \"b3\"; mnemonic = \"T\"; alignment = centered;"
" label = \" Break selected objects with any objects that touch it\";}"
" spacer_1;"
" : row { spacer_0;"
" : edit_box {key = \"gap\" ; width = 8; mnemonic = \"G\"; label = \"Gap\"; fixed_width = true;}"
" : button { label = \"Help\"; key = \"help\"; mnemonic = \"H\"; fixed_width = true;} "
" cancel_button;"
" spacer_0;"
" }"
"}"
) ; endlist
(princ x fn)
(write-line "" fn)
) ; end foreach
(close fn)
(setq acadfn nil)
(alert (strcat "\nDCL file created, please restart the routine"
"\n again if an error occures."))
t ; return True, file created
)
t ; return True, file found
)
) ; end defun
;;==============================
;; BreakAll Dialog Routine
;;==============================
(defun c:MyBreak(/ dclfile dcl# RunDCL BreakHelp cmd txt2num)
;; return number or nil
(defun txt2num (txt / num)
(if txt
(or (setq num (distof txt 5))
(setq num (distof txt 2))
(setq num (distof txt 1))
(setq num (distof txt 4))
(setq num (distof txt 3))
)
)
(if (numberp num)
num
)
)
(defun mydonedialog (flag)
(setq DCLgap (txt2num (get_tile "gap")))
(done_dialog flag)
)
(defun RunDCL (/ action)
(or DCLgap (setq DCLgap 0)) ; error trap value
(action_tile "b1" "(mydonedialog 1)")
(action_tile "b2" "(mydonedialog 2)")
(action_tile "b3" "(mydonedialog 3)")
(action_tile "gap" "(setq DCLgap (txt2num value$))")
(set_tile "gap" (rtos DCLgap))
(action_tile "help" "(BreakHelp)")
(action_tile "cancel" "(done_dialog 0)")
(setq action (start_dialog))
(or DCLgap (setq DCLgap 0)) ; error trap value
(setq DCLgap (max DCLgap 0)) ; nu negative numbers

(cond
((= action 1) ; BreakAll
(command "_.undo" "_begin")
;; get objects to break
(prompt "\nSelect objects to break with each other & press enter: ")
(if (setq ss (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(setq NewEnts (Break_with ss ss nil DCLgap) ; ss2break ss2breakwith (flag nil = not to break with self)
; AllEnts (append NewEnts (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
)
)
(command "_.undo" "_end")
(princ)
)

((= action 2) ; BreakWith
;; get objects to break
(prompt "\nBreak selected objects with other selected objects.")
(prompt "\nSelect object(s) to break & press enter: ")
(if (and (setq ss1 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 3))
(not (prompt "\n*** Select object(s) to break with & press enter: ***"))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(not (ssredraw ss1 4))
)
(break_with ss1 ss2 nil DCLgap) ; ss1break ss2breakwith (flag nil = not to break with self)
)

)
((= action 3) ; BreakSelected
(setq ss1 (ssadd))
;; get objects to break
(prompt "\nBreak selected objects with any objects that touch it.")
(if (and (not (prompt "\nSelect object(s) to break with touching & press enter: "))
(setq ss2 (ssget '((0 . "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"))))
(mapcar '(lambda (x) (ssadd x ss1)) (gettouching ss2))
)
(break_with ss2 ss1 nil DCLgap) ; ss2break ss1breakwith (flag nil = not to break with self)
)
)
)
)
(defun BreakHelp ()
(alert
(strcat
"BreakAll.lsp © 2007-2008 Charles Alan Butler\n\n"
"This LISP routine will break objects based on the routine you select.\n"
"It will not break objects on locked layers and objects must have the same z-value.\n"
"Object types are limited to LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE\n"
"BreakAll - Break all objects selected with each other\n"
"BreakwObject - Break many objects with a single object\n"
"BreakObject - Break a single object with many objects \n"
"BreakWith - Break selected objects with other selected objects\n"
"BreakTouching - Break objects touching selected objects\n"
"BreakSelected - Break selected objects with any objects that touch it\n"
" The Gap distance is the total opening created.\n"
"You may run each routine by entering the function name at the command line.\n"
"For updates & comments contact Charles Alan Butler AKA CAB at TheSwamp.org.\n")
)
)

;;================================================================
;; Start of Routine
;;================================================================
(vl-load-com)
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq dclfile "BreakAll.dcl")
(cond
((not (create_Breakdcl dclfile))
(prompt (strcat "\nCannot create " dclfile "."))
)
((< (setq dcl# (load_dialog dclfile)) 0)
(prompt (strcat "\nCannot load " dclfile "."))
)
((not (new_dialog "BreakDCL" dcl#))
(prompt (strcat "\nProblem with " dclfile "."))
)
((RunDCL)) ; No DCL problems: fire it up
)
(and cmd (setvar "CMDECHO" cmd))
(princ)
)
(prompt "Break routines loaded, Enter Mybreak to run.")
(princ)
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.
;; E n d O f F i l e I f y o u A r e H e r e
;;/'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\./'\.

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


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

Chào bác Bình!

Mình thấy lisp bác viết cho bạn " Gió trời" rất hay. Nhưng khi mình chạy nó hay bị báo lỗi ; error: bad argument type: fixnump: nil. Lỗi này là sao vậy bạn có phải do file mình bị lỗi hay không? Hay là do nó tính diện tích bị lỗi? Mình cũng cần xuất các dữ liệu từ cad sang excel giống như bạn phongthien vậy. Nhưng mình không cần phải tính diện tích thực tế, mà chỉ cấn xuất lớp "dien tich giay chung nhan" đã có sẵn mà thôi. Bác sữa lisp dùm mình tí nhé.

Cám ơn bác nhìu nhìu!!

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


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

Bạn đã nghe câu này chưa "Đợi chờ là hanh phúc" đó bạn. Chưa gì bạn đã kêu rồi sẽ đến lượt bạn.

;; free lisp from cadviet.com

(DEFUN C:gct ()
(SETQ DK1 (GETVAR "USERR3"))
(IF (= DK1 0)
    (PROGN
     (SETQ STR "1")
     (SETVAR "USERR3" 1)
    )    
    (SETQ STR (RTOS DK1))
)
(SETQ PRPT (STRCAT "\nSize <" STR ">:"))
(SETQ DK1 (GETREAL PRPT))
(IF (= DK1 NIL)
    (SETQ DK1 (GETVAR "USERR3"))
    (SETVAR "USERR3" DK1)
)
(setq dk (* DK1 50))
(INITGET 7)
(SETQ PTD (GETPOINT "\nFrom point:"))
(INITGET 7)
(SETQ PTC (GETPOINT PTD "\nTo point:"))
(SETQ GOCX (ANGLE PTD PTC))
(SETQ GOCY (+ GOCX (/ PI 2)))
(setq v (rtos dk))
(setq t (distance ptd ptc))
(setq r (/ t 2))
(SETQ PT1 (POLAR  PTc  0   (* 33 DK)))
(SETQ o (POLAR  PT1  0   (* 5.2 DK)))
(setq h (substr v 1 1))
(setq y (substr v 2 3))
(setq l (distance ptc pt1))
(setq pt3 (polar ptc 0 (/ l 1.85)))
(setq pt4 (polar pt3 (/ pi 2) (* 4 DK)))
(setq pt5 (polar ptd (- gocx (/ pi 2)) r))
(setq pt6 (polar ptd (+ gocx (/ pi 2)) r))
(setq pt7 (polar ptd (+ gocx  pi) r))
(setq pt8 (polar ptd  gocx   100))
(command "osnap"  "")
(command "layer" "m" "ghichu" "c" "163" """")
(COMMAND "COLOR" "84" "")
(COMMAND "STYLE" "T_THEP"  "romans.shx,vn1.shx" "" "" "" "" "" "" )
(command "text" "j" "m" pt4 (* 5 DK) 0)
(command "%%c10a150" )
 (setq sua (entlast))
(if (= (tblsearch "block" "ghithep_t") nil)
(progn
(COMMAND "STYLE" "VnAvant"  ".VnAvant" "" "" "" "" "")
(command "attdef" "" 1 1 1 "j" "m" o (* 5 50) 0)
(setq ss (ssadd))
(setq ss (ssadd (entlast) ss))
(COMMAND "COLOR" "4" "")
(command "circle" o (* 5.2 50)"")
(setq ss (ssadd (entlast) ss))
(COMMAND "COLOR" "150" "")
(COMMAND "PLINE" pt8 ptc pt1 "")
(setq ss (ssadd (entlast) ss))
(command "circle" ptd 100 "")
(setq ss (ssadd (entlast) ss))
(command "block" "ghithep_t" ptd ss "")
(command "insert" "ghithep_t" ptd DK1 DK1 "" "1")
)
(command "insert" "ghithep_t" ptd DK1 DK1 "" "1")
)
(COMMAND "COLOR" "BYLAYER" "")
(command "osnap" "End,Mid,Cen,Quad,Int,Perp,Tan,Near,App,Int,Ext,Par"  )
(command "ddedit" sua pause)
)

Xin lỗi bác vì sự nóng vội của e.Lisp này hình như vẫn còn lỗi ,vẽ lần đầu thì ok nhưng lần 2,lần 3...thì không đúng vì text và các đường thẳng không nằm đúng vị trí .Mong bác xem lại giùm e.Cảm ơn sự nhiệt tình giúp đỡ của bác.

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


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

Các bác cho e hỏi :E có 1 lisp vẽ hình tam giác khi mở CAD lên thì báo:

Current ucs name: *WORLD*

Specify origin of UCS or [Face/NAmed/OBject/Previous/View/World/X/Y/Z/ZAxis]

: s

Enter name to save current UCS or [?]: luu_ucsname y Unknown command "Y".

Khi vẽ hình thì toàn bị ngược.Mong các bác giúp đỡ.Thanks

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


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

Diễn đàn có thể giúp viết lisp đảo chiều đường polyline hay Lwpolyline không ạ?

Tức là các điểm đầu thành các điểm cuối và ngược lại.

Nếu có lệnh Cad có thể làm được yêu cầu này thì nhờ diễn đàn chỉ giúp.

Xin cảm ơn!

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


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Đây là phần tiếp theo của topic Viết lisp theo yêu cầu, mời các bạn tiếp tục thảo luận.

e muốn nhờ viết 1 lisp chia polyline,line,arc thành các đoạn thẳng có khoảng cách không bằng nhau,có thể nhập bằng tay hoặc từ 1 file text. Mong các anh giúp đở

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


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Diễn đàn có thể giúp viết lisp đảo chiều đường polyline hay Lwpolyline không ạ?

Tức là các điểm đầu thành các điểm cuối và ngược lại.

Nếu có lệnh Cad có thể làm được yêu cầu này thì nhờ diễn đàn chỉ giúp.

Xin cảm ơn!

Lệnh Pe (pedit) làm được việc này (nếu mình nhớ không nhầm)

không thì dùng lệnh reverse - lệnh này đảo chiều cả pline và spline

  • Vote tăng 1

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


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Chào bác Bình!

Mình thấy lisp bác viết cho bạn " Gió trời" rất hay. Nhưng khi mình chạy nó hay bị báo lỗi ; error: bad argument type: fixnump: nil. Lỗi này là sao vậy bạn có phải do file mình bị lỗi hay không? Hay là do nó tính diện tích bị lỗi? Mình cũng cần xuất các dữ liệu từ cad sang excel giống như bạn phongthien vậy. Nhưng mình không cần phải tính diện tích thực tế, mà chỉ cấn xuất lớp "dien tich giay chung nhan" đã có sẵn mà thôi. Bác sữa lisp dùm mình tí nhé.

Cám ơn bác nhìu nhìu!!

Hề hề hề,

Chào bạn yêu CAD (love cad),

Vì lisp mình viết cho bạn phongthien có tới hai ba cái lận, nên chưa rõ bạn cần cái nào. Đoán theo cái bạn hỏi thì có nhẽ nó là cái lisp tkqh thì phải. Nếu vậy thì câu trả lời sẽ là như sau:

1/- Việc cái lỗi bad argument type: fixmumber: nil có thể do một vài nguyên nhân như sau:

- Do lisp sử dụng lệnh boundary để tạo polyline bao quanh thửa đất mình chọn rồi mới tính được diện tích của cái boundary đó bằng hàm (command "area" "o" (entlast)) và (getvar "area") bạn ạ. Mà cái lệnh boundary này nó hơi bị kiêu nên nếu bạn không cho nó nhòm thấy người yêu của nó (thửa đất) một cách rõ ràng nhất, (tức là đầy đủ các đường bao xung quanh thửa đất và các đường bao này phải thật sự khép kín) thì nó sẽ không chịu cưới. (không tạo được boundary). Và thế là chả thể có con cái gì cả, ( cái vụ (command "area" "o" (entlast)) sẽ trả về nil ) nên lấy đâu ra cháu bồng (thằng (getvar "area") sẽ báo lỗi như bạn thấy) hề hề hề.

Vậy nên cách khắc phục trong trường hợp này chính là khi bạn muốn thống kê tại khu vực nào của bản vẽ thì nên zoom cái khu vực ấy lên cho đủ lớn để có thể nhòm thấy đầy đủ các đường bao của các thửa đất một cách rõ ràng nhất bạn ạ, và chỉ chọn các thửa đất thấy đủ các đường bao để làm bảng thống kê thôi.

- Cũng do cái hàm boundary này mà khi các đường bao thửa đất được vẽ bởi cáp polyline quá loằng ngoằng thì khi tách các đảo trống ở giửa nó tách không nổi và thế là nó tiệt giống luôn và cho bạn cái báo lỗi to đùng ngã ngửa như vậy.

Các khắc phục trong trường hợp này là nên chữa lại các đường bao sao cho đơn giản và dễ nhận biết nhất tức là nên cắt các đường bao này tại những điểm góc ranh cho phù hợp.

Hề hề hề, Ấy là cái cách hiểu của mình, tuy chả được khoa học lắm nhưng có nhẽ với dân đi mót như mình thì cũng hề hề hề được.

2/- Việc bạn chả muốn có cái cột diện tích thực tế trên Excel thì chả có gì khó khăn cả bạn ạ. Bạn có thể xài một trong những cách củ chuối như sau:

- Cứ dùng cái lisp này chạy cho ra đủ các cột trong Excel rồi thấy ghét thằng nào thì delete một phát cho chết. Vậy là chả phải nghĩ ngợi gì. Hề hề hề.

- Giở cái lisp này ra, tìm đến dòng:

qhlst (append qhlst (list (list cd sth ld cn dt)))

Nhòm vào đấy thấy thằng nào dễ ghét thì xóa béng nó đi là xong. Tỷ như ghét thằng chủ đất thì xóa thằng cd để thành :

qhlst (append qhlst (list (list sth ld cn dt)))

Ghét thằng số thửa nữa thì:

qhlst (append qhlst (list (list ld cn dt)))

Ghét thêm thằng diện tích thực tế thì:

qhlst (append qhlst (list (list ld cn ))) và thế là trên Excel chỉ còn nhõn hai thằng loại đất và diện tích cấp chứng nhận bạn ạ.

Hề hề hề, dễ như ăn ớt ấy mà..... Bạn cứ tùy nghi ứng biến miễn sao bạn khoái là OK hỉ.

 

3/- Cũng giống với bạn phongthien, mình khuyên bạn rằng để lisp chạy ngon lành bạn nên tổ chức lại các bản vẽ của bạn sao cho nó thống nhất về các loại đường nét màu sắc và tên các lớp để lisp nó đỡ hoa mắt mà chạy nhầm đường bạn nhé. Cái thằng lisp này nó ham vui lắm, cứ thấy chỗ nào có tí quen biết là nó tới thăm hỏi liền à, vậy nên nếu bạn không xiết chặt kỷ luật là anh cu này chạy tới bến luôn đó. hề hề hề....

 

Chúc bạn vui vẻ hỉ....

 

PS: từ sau nếu bạn muốn hỏi về cái lisp nào thì hãy post kèm với nó để mọi người đỡ công lần mò nhé. Hề hề hề....

  • Vote tăng 1

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


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
e muốn nhờ viết 1 lisp chia polyline,line,arc thành các đoạn thẳng có khoảng cách không bằng nhau,có thể nhập bằng tay hoặc từ 1 file text. Mong các anh giúp đở

Hề hề hề,

Mong bạn cho biết chính xác là cái khoảng cách ấy là gì ???? là độ dài của đường cần chia tính từ hai điểm chia hay là độ lớn của đoạn thẳng nối hai điểm chia????

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


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Các bác cho e hỏi :E có 1 lisp vẽ hình tam giác khi mở CAD lên thì báo:

Current ucs name: *WORLD*

Specify origin of UCS or [Face/NAmed/OBject/Previous/View/World/X/Y/Z/ZAxis]

: s

Enter name to save current UCS or [?]: luu_ucsname y Unknown command "Y".

Khi vẽ hình thì toàn bị ngược.Mong các bác giúp đỡ.Thanks

Hề hề hề,

Hãy post cái lisp đó lên nhé...

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


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Xin lỗi bác vì sự nóng vội của e.Lisp này hình như vẫn còn lỗi ,vẽ lần đầu thì ok nhưng lần 2,lần 3...thì không đúng vì text và các đường thẳng không nằm đúng vị trí .Mong bác xem lại giùm e.Cảm ơn sự nhiệt tình giúp đỡ của bác.

Chào bạn hugo75!

Xin lỗi bạn tại mình chưa test thử nhiều lần nên mới bị vậy. Mình sửa cho bạn đây. Bạn muốn cái đường tròn liền với cái pline thì quả thực rất khó. Có lẽ chỉ có thể dùng qleader để mình nghiên cứu tiếp cho bạn. trong khi chờ đợi bạn dùng tạm cái này mình đã sửa lỗi trên rồi.

;; free lisp from cadviet.com

;; free lisp from cadviet.com

(DEFUN C:gct ()
(SETQ DK1 (GETVAR "USERR3"))
(IF (= DK1 0)
    (PROGN
     (SETQ STR "1")
     (SETVAR "USERR3" 1)
    )    
    (SETQ STR (RTOS DK1))
)
(SETQ PRPT (STRCAT "\nSize <" STR ">:"))
(SETQ DK1 (GETREAL PRPT))
(IF (= DK1 NIL)
    (SETQ DK1 (GETVAR "USERR3"))
    (SETVAR "USERR3" DK1)
)
(setq dk (* DK1 50))
(INITGET 7)
(SETQ PTD (GETPOINT "\nFrom point:"))
(INITGET 7)
(SETQ PTC (GETPOINT PTD "\nTo point:"))
(SETQ GOCX (ANGLE PTD PTC))
(SETQ GOCY (+ GOCX (/ PI 2)))
(setq v (rtos dk))
(setq t (distance ptd ptc))
(setq r (/ t 2))
(SETQ PT1 (POLAR  PTc  0   (* 33 DK)))
(SETQ o (POLAR  PT1  0   (* 5.2 DK)))
(setq h (substr v 1 1))
(setq y (substr v 2 3))
(setq l (distance ptc pt1))
(setq pt3 (polar ptc 0 (/ l 1.85)))
(setq pt4 (polar pt3 (/ pi 2) (* 4 DK)))
(setq pt5 (polar ptd (- gocx (/ pi 2)) r))
(setq pt6 (polar ptd (+ gocx (/ pi 2)) r))
(setq pt7 (polar ptd (+ gocx  pi) r))
(setq pt8 (polar ptd  gocx   100))
(command "osnap"  "")
(command "layer" "m" "ghichu" "c" "163" """")
(COMMAND "COLOR" "84" "")
(COMMAND "STYLE" "T_THEP"  "romans.shx,vn1.shx" "" "" "" "" "" "" )
(command "text" "j" "m" pt4 (* 5 DK) 0)
(command "%%c10a150" )
 (setq sua (entlast))
(if (= (tblsearch "block" "ghithep_t") nil)
(progn
(COMMAND "STYLE" "VnAvant"  ".VnAvant" "" "" "" "" "")
(command "attdef" "" 1 1 1 "j" "m" o (* 5 50) 0)
(setq ss (ssadd))
(setq ss (ssadd (entlast) ss))
(COMMAND "COLOR" "4" "")
(command "circle" o (* 5.2 50)"")
(setq ss (ssadd (entlast) ss))
(command "block" "ghithep_t" o ss "")
(command "insert" "ghithep_t" o DK1 DK1 "" "1")
)
(command "insert" "ghithep_t" o DK1 DK1 "" "1")
)
(COMMAND "COLOR" "150" "")
(COMMAND "PLINE" pt8 ptc pt1 "")
(command "circle" ptd 100 "")
(COMMAND "COLOR" "BYLAYER" "")
(command "osnap" "End,Mid,Cen,Quad,Int,Perp,Tan,Near,App,Int,Ext,Par"  )
(command "ddedit" sua pause)
)

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


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

Xin lỗi bạn tại mình chưa test thử nhiều lần nên mới bị vậy. Mình sửa cho bạn đây. Bạn muốn cái đường tròn liền với cái pline thì quả thực rất khó. Có lẽ chỉ có thể dùng qleader để mình nghiên cứu tiếp cho bạn. trong khi chờ đợi bạn dùng tạm cái này mình đã sửa lỗi trên rồi.

;; free lisp from cadviet.com

;; free lisp from cadviet.com

(DEFUN C:gct ()
(SETQ DK1 (GETVAR "USERR3"))
(IF (= DK1 0)
    (PROGN
     (SETQ STR "1")
     (SETVAR "USERR3" 1)
    )    
    (SETQ STR (RTOS DK1))
)
(SETQ PRPT (STRCAT "\nSize <" STR ">:"))
(SETQ DK1 (GETREAL PRPT))
(IF (= DK1 NIL)
    (SETQ DK1 (GETVAR "USERR3"))
    (SETVAR "USERR3" DK1)
)
(setq dk (* DK1 50))
(INITGET 7)
(SETQ PTD (GETPOINT "\nFrom point:"))
(INITGET 7)
(SETQ PTC (GETPOINT PTD "\nTo point:"))
(SETQ GOCX (ANGLE PTD PTC))
(SETQ GOCY (+ GOCX (/ PI 2)))
(setq v (rtos dk))
(setq t (distance ptd ptc))
(setq r (/ t 2))
(SETQ PT1 (POLAR  PTc  0   (* 33 DK)))
(SETQ o (POLAR  PT1  0   (* 5.2 DK)))
(setq h (substr v 1 1))
(setq y (substr v 2 3))
(setq l (distance ptc pt1))
(setq pt3 (polar ptc 0 (/ l 1.85)))
(setq pt4 (polar pt3 (/ pi 2) (* 4 DK)))
(setq pt5 (polar ptd (- gocx (/ pi 2)) r))
(setq pt6 (polar ptd (+ gocx (/ pi 2)) r))
(setq pt7 (polar ptd (+ gocx  pi) r))
(setq pt8 (polar ptd  gocx   100))
(command "osnap"  "")
(command "layer" "m" "ghichu" "c" "163" """")
(COMMAND "COLOR" "84" "")
(COMMAND "STYLE" "T_THEP"  "romans.shx,vn1.shx" "" "" "" "" "" "" )
(command "text" "j" "m" pt4 (* 5 DK) 0)
(command "%%c10a150" )
 (setq sua (entlast))
(if (= (tblsearch "block" "ghithep_t") nil)
(progn
(COMMAND "STYLE" "VnAvant"  ".VnAvant" "" "" "" "" "")
(command "attdef" "" 1 1 1 "j" "m" o (* 5 50) 0)
(setq ss (ssadd))
(setq ss (ssadd (entlast) ss))
(COMMAND "COLOR" "4" "")
(command "circle" o (* 5.2 50)"")
(setq ss (ssadd (entlast) ss))
(command "block" "ghithep_t" o ss "")
(command "insert" "ghithep_t" o DK1 DK1 "" "1")
)
(command "insert" "ghithep_t" o DK1 DK1 "" "1")
)
(COMMAND "COLOR" "150" "")
(COMMAND "PLINE" pt8 ptc pt1 "")
(command "circle" ptd 100 "")
(COMMAND "COLOR" "BYLAYER" "")
(command "osnap" "End,Mid,Cen,Quad,Int,Perp,Tan,Near,App,Int,Ext,Par"  )
(command "ddedit" sua pause)
)

Chào bác Tú,lisp này bác có thể thêm dòng chọn đường tròn hay đường xiên không?Đường xiên nghêng 1 góc 45 độ và dài 200.Thanks.

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


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Khách
Chủ đề này bây giờ đã bị đóng lại để trả lời thêm.

×