Đến nội dung


Hình ảnh
- - - - -

[Yêu cầu] viết lisp nối các đoạn thẳng này hộ em với


  • Please log in to reply
13 replies to this topic

#1 khunglong37

khunglong37

    biết pan

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

Đã gửi 29 January 2011 - 03:54 PM

Chào cảc bác cao thủ,

Em mới lọ mọ học Autolisp, hiện tại em đang cần viết lisp nối các đoạn thẳng này thành các đường liền nhau. Nhờ các bác giúp hộ em với. Cảm ơn cả nhà
Hình đã gửi

Em dùng lệnh pe nhưng chỉ nối được từng đường vẫn thủ công mà không nối được các đường khác, nhờ các cao thủ giúp hộ
  • 0

#2 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5685 Bài viết
Điểm đánh giá: 2606 (tuyệt vời)

Đã gửi 29 January 2011 - 04:21 PM

Có người post r đó bạn :) Code tương đối dài, áp dụng với cả arc nhé

;;; ;free lisp from cadviet.com @ ....
;;; ====================================================== join polyline
(defun c:jp ( / ss plines ss2 st fuzz)
(acet-error-init
(list (list "cmdecho" 0
"highlight" nil
"plinetype" 2
"limcheck" 0
"osmode" 0

);list
0 ;use undo marks but do not roll back on a cancel
);list
);acet-error-init

(setq plines (ssget ":l" '(
(-4 . "<OR")
(0 . "ARC")
(0 . "LINE")
(-4 . "<AND")
(0 . "*POLYLINE")
(-4 . "<NOT") (-4 . "&") (70 . 88) (-4 . "NOT>") ;8 16 64 not a 3dpoly or 3d/pface mesh
(-4 . "AND>")
(0 . "LWPOLYLINE")
(-4 . "OR>")
)
)
);setq
(if plines
(setq plines (acet-ss-filter-current-ucs plines T))
);if
(if plines
(setq plines (car (acet-ss-filter (list plines '(("CURRENTUCS")) T))))
);if
(princ "\n")
(if plines
(setq ss (convert plines));setq
);if
(if (and ss
(> (sslength ss) 0)
plines
);and
(mpedit ss) ;after conversion, plines sset is duplicated in ss
(progn
(if (not plines)
(princ "\nNothing selected.")
(princ "\nNo valid objects selected.")
);if
);progn else
);if

(acet-error-restore)
(acet-pljoin2 ss st fuzz)
;(acet-pljoin-get-fuzz-and-mode2)
(princ)
);defun c:jp

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; mpedit functionality and switch cases based on kword input operation

(defun mpedit ( plines / opt newWidth ss flt fuz st na ss2 )

(initget 0 "Open Close Join Ltype Decurve Fit Spline Width eXit _Open Close Join Ltype Decurve Fit

Spline Width eXit")
(setq opt "Join")
; (setq opt (getkword "\nEnter an option [Open/Close/Join/Width/Fit/Spline/Decurve/Ltype gen/eXit]

<eXit>: "))
;Changed code below to a cond structure to improve readability R.K.
(cond
((= opt "Join")
(setq flt '((-4 . "<OR")
(0 . "LINE")
(0 . "ARC")
(-4 . "<AND")
(0 . "*POLYLINE")
(-4 . "<NOT") (-4 . "&") (70 . 89) (-4 . "NOT>") ;1 8 16 64
(-4 . "AND>")
(-4 . "OR>")
)
flt (list flt
"\n1 object is invalid for join."
"\n%1 objects are invalid for join."
);list
flt (list flt
(list "LAYERUNLOCKED")
(list "CURRENTUCS")
);list
ss (car (acet-ss-filter (list plines flt T)))
);setq

(acet-autoload (list "pljoin.lsp" "(acet-pljoin-get-fuzz-and-mode)"))
(acet-autoload (list "pljoin.lsp" "(acet-pljoin ss st fuz)"))

(if ss
(progn
(setvar "highlight" 0)
(setq fuz (acet-pljoin-get-fuzz-and-mode2)
st (cadr fuz)
fuz (car fuz)
na (entlast)
);setq
(acet-pljoin2 ss st fuz)
(setq ss2 (acet-ss-new na))
(setq plines (acet-ss-union (list plines ss2)))
);progn then
(princ "\nNo valid objects to join.")
);if
);cond Join option
);cond close
);defun mpedit

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Convert arcs and lines to polylines
;;; ss is retained as a duplicate of the plines selection set because
;;; after conversion, new handles are assigned to what were arcs and lines
(defun convert ( plines / ss count opt )
(if (> (sslength plines) 0)
(setq opt "Yes")
; (progn
; (initget 0 "Yes No _Yes No")
; (setq opt (getkword "Convert Lines and Arcs to polylines? [Yes/No] <Yes>: "))
; );progn then
);if
(if (not opt)
(setq opt "Yes")
)
(if (and (= opt "Yes")
(> (sslength plines) 0)
);and
(progn ;if yes -- convert lines and arcs to polylines
(acet-undo-begin)
(setq ss (ssadd))
(setq count 0)
(while (< count (sslength plines))
(if (or (equal (assoc 0 (entget (ssname plines count))) '(0 . "ARC"))
(equal (assoc 0 (entget (ssname plines count))) '(0 . "LINE"))
);or
(progn
(command "_.pedit" (ssname plines count) "_yes" "_exit")
(ssadd (entlast) ss)
);progn true
(ssadd (ssname plines count) ss)
);if
(setq count (1+ count))
);while
(acet-undo-end)
);progn yes
(progn ;if no -- do not convert
(setq ss plines)
(setq count 0)
(while (< count (sslength ss))
(if (or (equal (assoc 0 (entget (ssname ss count))) '(0 . "ARC"))
(equal (assoc 0 (entget (ssname ss count))) '(0 . "LINE"))
);or
(progn
(ssdel (ssname ss count) ss)
(setq count (1- count))
);progn true
);if
(setq count (1+ count))
);while
);progn no
);if
(if (and ss
(equal (type ss) 'PICKSET)
(equal 0 (sslength ss))
);and
(setq ss nil)
);if
ss
)
(if (not #acet-pljoin-prec)
(setq #acet-pljoin-prec 0.0000001)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin2 ( ss st fuzz / flt )

(setq flt '((-4 . "<OR")
(0 . "LINE")
(0 . "ARC")
(-4 . "<AND")
(0 . "*POLYLINE")
(-4 . "<NOT") (-4 . "&") (70 . 89) (-4 . "NOT>") ;1 8 16 64
(-4 . "AND>")
(-4 . "OR>")
)
);setq
(if (and (setq ss (acet-pljoin-do-ss-pre-work2 ss flt)) ;convert lines/arcs/heavy plines ..etc.
;to lighweight plines
(setq ss (acet-pljoin-1st-pass2 ss flt)) ;initial pass with pedit command
);and
(acet-pljoin-2nd-pass2 ss fuzz st flt) ;where the work is..
);if

);defun acet-pljoin


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Try to join as many as possible before performing the
;hashing.
;
(defun acet-pljoin-1st-pass2 ( ss flt / na )

(acet-spinner)

(setq na (entlast))
(command "_.pedit" (ssname ss 0) "_j" ss "" "_x")

(command "_.select" ss)
(if (not (equal na (entlast)))
(command (entlast) "")
(command "")
);if
(setq ss (acet-ss-ssget-filter ss flt));setq
(if (and ss
(:s_big:) ;closest pairs point at each other
(setq na (last id) ;get some of the data out of id and id2
na2 (last id2)
p1 (cadr id) ;the real points
p2 (cadr id2)
);setq
(progn ;get the proper entity names from the ename map lst5
(while (setq c (assoc na lst5)) (setq na (cadr c)));while
(while (setq c (assoc na2 lst5)) (setq na2 (cadr c)));while
T
);progn
na ;both entities still exist?
na2

; (/= 1 (logand 1 (cdr (assoc 70 (entget na)))))
; (/= 1 (logand 1 (cdr (assoc 70 (entget na2)))))
);and
(progn
;then attempt a join
(setq flag nil
lst5 (acet-pljoin-do-join2 fuzz st na p1 na2 p2 lst5 tmpe1 tmpe2)
flag (cadr lst5) ;join success?
lst5 (car lst5)
);setq return updated entname map and success flag
(if flag
(setq ulst (cons id ulst) ;Then the join succeeded.
ulst (cons id2 ulst) ;mark the two as used by adding the them to ulst
);setq the success
(setq flst (cons (list id id2) flst)
flst (cons (list id2 id) flst)
);setq else join failed so mark as such in flst
);if
);progn then
(progn
(setq nskip (+ nskip 1));setq

;(print '(not (member id ulst)))
;(print (not (member id ulst)))
;(print '(not (member id2 ulst)))
;(print (not (member id2 ulst)))
;(print '(not (member (list id id2) flst)))
;(print (not (member (list id id2) flst)))
;(print '(setq b (assoc id2 lst2)))
;(print (setq b (assoc id2 lst2)))
;(print '(equal id (cadr B)))
;(print (equal id (cadr B)))
;(print 'na)
;(print na)
;(print 'na2)
;(print na2)
;
;(d-point (cadr id) "1")
;(d-point (cadr id2) "2")
;(princ "\ndecided not to try it.")
;(getstring "")
;(entdel (entlast))
;(entdel (entlast))

);progn else
);if
(setq n (+ n 1))
);repeat

(if (equal nskip n)
(setq lst nil);then all were skipped so the job is finished.
);if

(setq lst2 nil);setq ;;;remove the used and non-candidate point data from lst
(setq n 0)
(repeat (length lst)
(setq a (nth n lst));setq
(if (and (not (member n lst3)) ;not a non-candidate
(not (member a ulst)) ;not used
);and
(setq lst2 (cons a lst2))
);if
(setq n (+ n 1))
);repeat

(list lst2 lst5 flst)
);defun acet-pljoin-get-matched-pairs


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin-get-closest2 ( p1 lst fuzz g flst / a b c d x1 x2 x3 y1 y2 y3 n j
lst2 lst3 len2 len3 clst
)

;(print "acet-pljoin-get-closest")
;(print "")

(setq b (cadr p1) ;the real point
a (car p1) ;the grid point
);setq

;determine the grid points to examine.
(cond
((equal fuzz 0.0 #acet-pljoin-prec)
(setq lst2 (list (list (car a) (cadr a))
);list
);setq else
);cond #2
(T
(if (B))
(setq x1 (car a)
x2 (acet-calc-round (+ (car a) g) g)
);setq
(setq x1 (acet-calc-round (- (car a) g) g)
x2 (car a)
);setq
);if
(if (B))
(setq y1 (cadr a)
y2 (acet-calc-round (+ (cadr a) g) g)
);setq
(setq y1 (acet-calc-round (- (cadr a) g) g)
y2 (cadr a)
);setq
);if
(setq lst2 (list (list x1 y1)
(list x2 y1)
(list x2 y2)
(list x1 y2)
);list
);setq
);cond #3
);cond close

(setq d (* fuzz 2.0)
len2 (length lst2)
);setq
;;loop through the grid points and check each of the points that fall on each grid point
(setq n 0)
(while (B)
(setq c (list (acet-calc-round (car a) g)
(acet-calc-round (cadr a) g)
);list
d (list (acet-calc-round (car B) g)
(acet-calc-round (cadr B) g)
);list
lst (cons (list c a 0 na) lst)
lst (cons (list d b 1 na) lst)
);setq then
);if

(if (equal n (* (/ n 10) 10)) ;update the spinner once every ten objects
(acet-spinner)
);if
(setq n (+ n 1));setq
);repeat
;(princ "Done.")

lst
);defun acet-pljoin-round


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin-get-epoints2 ( na / e1 a b z v )

;(print "acet-pljoin-get-epoints")
;(print "")

(if (and (setq e1 (entget na))
(setq e1 (acet-lwpline-remove-duplicate-pnts2 e1))
);and
(progn
(setq z (cdr (assoc 38 e1)));setq
(if (not z) (setq z 0.0))
(setq v (cdr (assoc 210 e1))
a (cdr (assoc 10 e1))
a (list (car a) (cadr a) z)
a (trans a v 1)
e1 (reverse e1)
b (cdr (assoc 10 e1))
b (list (car B) (cadr B) z)
b (trans b v 1)
);setq
(setq a (list a B))
);progn then
);if;

;(print "done epoints")

a
);defun acet-pljoin-get-epoints

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Takes an entity list of lwpolylines and modifies the object
;removing neighboring duplicate points. If no duplicated points
;are found then the object will not be passed to (entmod ).
;Returns the new elist when done.
(defun acet-lwpline-remove-duplicate-pnts2 ( e1 / a n lst e2)

(setq n 0)
(repeat (length e1)
(setq a (nth n e1));setq
(cond
((not (equal 10 (car a)))
(setq e2 (cons a e2))
);cond #1
((not (equal (car lst) a))
(setq lst (cons a lst)
e2 (cons a e2)
);setq
);cond #2
);cond close
(setq n (+ n 1));setq
);repeat
(setq e2 (reverse e2))
(if (and e2
(not (equal e1 e2))
lst
);and
(progn
(if (equal 1 (length lst))
(progn
(entdel (cdr (assoc -1 e1)))
(setq e2 nil)
);progn then single vertex polyline so delete it.
(progn
(setq e2 (subst (cons 90 (length lst)) (assoc 90 e2) e2)
);setq
(entmod e2)
);progn else
);if
);progn then
);if

e2
);defun acet-lwpline-make-remove-duplicate-pnts

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin-fillet-with-fuzz2 ( fuzz na p1 tmpe1 na2 p2 tmpe2 /
e1 e2 p1a p2a lst flag flag2 n a
tmpna tmpna2 x y v
)

;(print "acet-pljoin-fillet-with-fuzz")
;(print "")


(setq tmpna (cdr (assoc -1 tmpe1)) ;get the temp entitiy names out of the ent lists
tmpna2 (cdr (assoc -1 tmpe2))
lst (acet-pljoin-mod-tmp2 na p1 tmpe1) ;make the temp ent look like the begining or ending

segment
e1 (car lst) ;the modified temp ent list
flag (cadr lst) ;0 or 1 start or end
p1a (caddr lst) ;segment info sub-list (p1 p2 bulge) where p2 is always the

endpoint
lst (acet-pljoin-mod-tmp2 na2 p2 tmpe2)
e2 (car lst)
flag2 (cadr lst) ;0 or 1 start or end
p2a (caddr lst) ;segment info sub-list (p1 p2 bulge) ;in entity ucs
lst (acet-geom-intersectwith tmpna tmpna2 3) ;get the intersection list
v (cdr (assoc 210 e1))
lst (acet-geom-m-trans lst 0 v) ;trans to entity coord system
);setq

(if lst
(progn
(setq x (acet-pljoin-get-best-int2 p1a lst)) ;get the best intersection
(setq y (acet-pljoin-get-best-int2 p2a lst)) ;get the best intersection
;put the best intersections in the list x
(cond
((and x y)
(setq x (list x y))
);cond #1
;;(x (setq x (list x))) ;commented because both objects must pass the best intersect test
;;(y (setq x (list y)))
(T (setq x nil))
);cond
(if (and x
(setq x (acet-geom-m-trans x v 1))
(setq x (acet-pljoin-get-closest-int2 p1 p2 x))
(B))) ;arc segment, so get delta angle from arc_info
);if
(setq n 0)
(repeat (length lst)
(setq a (nth n lst))
(if (equal b 0.0)
(progn
;the it's a line segment
(if (and (or (equal (angle p1 a) a1 #acet-pljoin-prec) (equal (abs (- (angle p1 a) a1))
(* 2.0 pi)
#acet-pljoin-prec
)
);or
(or (not d)
(< (setq c (distance p2 a)) d)
);or
);and
(progn
(setq d c
j n
);setq
);progn then
);if
);progn then line segment
(progn
(if (equal p1 a #acet-pljoin-prec)
(progn
(setq a2 (* pi 2.0
(/ (abs a1) a1)
);mult
);setq then make it 360 degrees and preserve the sign.
);progn then
(progn
(setq nb (acet-pljoin-calc-new-bulge2 p1 b p2 a)
a2 (acet-geom-pline-arc-info p1 a nb)
a2 (caddr a2) ;delta angle
);setq
);progn else
);if
(setq c (abs (- (abs a2)
(abs a1)
)
)
);setq
(if (and (>= (* a2 a1) 0.0) ;same sign delta angle
(or (not d)
(:);if
;(entdel (entlast))
;(entdel (entlast))
;(if d (entdel (entlast)));if

d
);defun acet-pljoin-get-best-int

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin-get-closest-int2 ( p1 p2 lst / n a j d )

(setq n 0)
(repeat (length lst)
(setq a (nth n lst)
a (+ (distance a p1) (distance a p2))
);setq
(if (or (not d)
(B)
e2 (acet-list-put-nth (cons 10 x) e2 p1)
);setq then
(setq blg (acet-pljoin-calc-new-bulge2 (cdr (nth p2 e2))
(cdr (nth b e2))
(cdr (nth p1 e2))
x
)
e2 (acet-list-put-nth (cons 42 blg) e2 B)
e2 (acet-list-put-nth (cons 10 x) e2 p1)
);setq then
);if
);progn else arc segment
);if
(setq e1 (append e2 e1))
(if (equal flag 1)
(setq e1 (reverse e1))
);if
(entmod e1)

);defun acet-pljoin-fillet-mod-epoint

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Make the temporary ent match the segment of interest to get ready to
;use the intersectwith method.
;Takes an entity name and a point that is on one end of the entity
;and a entity list of a single segment lwpolyline
;modifies the single segment polyline such that it matches the
;first or last segment (depending on the p1 provided) of the
;polyline 'na'
;
(defun acet-pljoin-mod-tmp2 ( na p1 tmpe1 / e1 e2 a b z p2 flag v )

(setq e1 (entget na)
v (cdr (assoc 210 e1))
p1 (trans p1 1 v)
p1 (list (car p1) (cadr p1))
tmpe1 (subst (assoc 38 e1) (assoc 38 tmpe1) tmpe1)
tmpe1 (subst (assoc 39 e1) (assoc 39 tmpe1) tmpe1)
tmpe1 (subst (assoc 210 e1) (assoc 210 tmpe1) tmpe1)
z (cdr (assoc 38 e1))
a (assoc 10 e1)
);setq

(if (equal (cdr a) p1 #acet-pljoin-prec)
(progn
(setq flag 0
tmpe1 (reverse tmpe1)
tmpe1 (subst a (assoc 10 tmpe1) tmpe1)
tmpe1 (reverse tmpe1)
e2 (cdr (member (assoc 10 e1) e1))
p2 (list (car p1) (cadr p1) z)
p1 (cdr (assoc 10 e2))
p1 (list (car p1) (cadr p1) z)
tmpe1 (subst (assoc 10 e2) (assoc 10 tmpe1) tmpe1)
b (* -1.0 (cdr (assoc 42 e2)))
tmpe1 (subst (cons 42 B)
(assoc 42 tmpe1)
tmpe1
)
);setq
);progn then
(progn
(setq flag 1
e2 (reverse e1)
tmpe1 (reverse tmpe1)
a (assoc 10 e2)
p2 (cdr a)
p2 (list (car p2) (cadr p2) z)
tmpe1 (subst a (assoc 10 tmpe1) tmpe1)
e2 (cdr (member a e2))
p1 (cdr (assoc 10 e2))
p1 (list (car p1) (cadr p1) z)
b (cdr (assoc 42 e2))
tmpe1 (reverse tmpe1)
tmpe1 (subst (cons 42 B) (assoc 42 tmpe1) tmpe1)
a (assoc 10 e2)
tmpe1 (subst (assoc 10 e2) (assoc 10 tmpe1) tmpe1)
);setq
);progn else
);if

(entmod tmpe1)

(list e1 flag (list p1 p2 B))
);defun acet-pljoin-mod-tmp

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Calculates the new bulge formed by moving
;point p2 to p3 and still retaining the same radius and center point.
;
(defun acet-pljoin-calc-new-bulge2 ( p1 b p2 p3 / p4 x r a c b2 info )

(setq c (distance p1 p3))
(if (not (equal c 0.0))
(progn
(setq p4 (acet-geom-midpoint p1 p3)
info (acet-geom-pline-arc-info p1 p2 B)
r (cadr info);radius
x (car info) ;center point
a (- r
(distance x p4)
)
);setq
(setq b2 (/ (* 2.0 a) c)
b2 (* b2 (/ (abs B) B))
);setq
(setq info (acet-geom-pline-arc-info p1 p3 b2))
(if (not (equal x (car info) #acet-pljoin-prec))
(progn
(setq a (- (* r 2.0) a));setq
(setq b2 (/ (* 2.0 a) c)
b2 (* b2 (/ (abs B) B))
);setq
);progn then
);if
);progn then
(setq b2 0.0)
);if

b2
);defun acet-pljoin-calc-new-bulge


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;- explode all curve fitted and/or splined plines and re-join
;- convert all to light weight plines.
;- turn all arcs and lines into lightweight plines.
;- finally return a selection set of all plines.
(defun acet-pljoin-do-ss-pre-work2 ( ss flt / na ss2 ss3 n w)


(command "_.select" ss "")
(setq ss2 (ssget "_p" '((-4 . "&") (70 . 6)))) ;fit or splined
(command "_.select" ss "")
(setq ss3 (ssget "_p" '((-4 . "<OR") (0 . "LINE") (0 . "ARC") (-4 . "OR>")))) ;lines and arcs

(if ss2
(progn
(setq n 0)
(repeat (sslength ss2)
(setq na (ssname ss2 n)
w (acet-pljoin-get-width2 na)
);setq
(command "_.explode" na)
(while (wcmatch (getvar "cmdnames") "*EXPLODE*") (command ""))
(command "_.pedit" (entlast) "_y" "_j" "_p" "")
(if (not (equal w 0.0))
(command "_w" w)
);if
(command "_x")
(setq ss (ssdel na ss)
ss (ssadd (entlast) ss)
);setq
(setq n (+ n 1));setq
);repeat
);progn then
);if
(command "_.convertpoly" "_light" ss "")
(if ss3
(progn
(setq n 0)
(repeat (sslength ss3)
(setq na (ssname ss3 n));setq
(command "_.pedit" na "_y" "_x")
(setq ss (ssdel na ss)
ss (ssadd (entlast) ss)
);setq
(setq n (+ n 1));setq
);repeat
);progn then
);if
(if (equal 0 (sslength ss))
(setq ss nil)
);if
(setq ss (acet-pljoin-ss-flt2 ss flt))


ss
);defun acet-pljoin-do-ss-pre-work


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;return the with of the heavy polyline provided in 'na'
(defun acet-pljoin-get-width2 ( na / e1 a B)

(if (and (setq e1 (entget na))
(equal (cdr (assoc 0 e1)) "POLYLINE")
);and
(progn
(setq a (cdr (assoc 40 e1))
b (cdr (assoc 41 e1))
);setq
(while (and (equal a B)
(setq na (entnext na))
(setq e1 (entget na))
(not (equal (cdr (assoc 0 e1)) "SEQEND"))
);and
(setq a (cdr (assoc 40 e1))
b (cdr (assoc 41 e1))
);setq
);while
);progn then
(setq a 0.0)
);if
a
);defun acet-pljoin-get-width

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin-ss-flt2 ( ss flt / n na e1 p1 p2 )
(if (and ss
(> (sslength ss) 0)
);and
(progn
(command "_.select" ss "")
(setq ss (ssget "_p" flt))
);progn then
(setq ss nil)
);if

ss
);defun acet-pljoin-ss-flt


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;prompt for a joinmode setting of "Fillet" or "Add"
(defun acet-pljoinmode2 ( / st )
(acet-pljoin-init-mode2)
(initget "Fillet Add Both _Fillet Add Both")
(setq st (getkword
(acet-str-format "\nEnter join type [Fillet/Add/Both] <%1>: " #acet-pljoinmode)
);getkword
);setq
(if st
(progn
(setq #acet-pljoinmode st)
(acet-setvar (list "ACET-PLJOINMODE" #acet-pljoinmode 2))
);progn
);if
);defun acet-pljoinmode

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin-init-mode2 ()
(if (not #acet-pljoinmode)
(setq #acet-pljoinmode (acet-getvar '("ACET-PLJOINMODE" 2)))
);if
(if (not #acet-pljoinmode)
(progn
(setq #acet-pljoinmode "Both")
(acet-setvar (list "ACET-PLJOINMODE" #acet-pljoinmode 2))
);progn then
);if
#acet-pljoinmode
);defun acet-pljoin-init-mode

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;prompt for fuzz distance and/or pljoinmode setting.
;return list... (fuzz pljoinmode)
;
(defun acet-pljoin-get-fuzz-and-mode2 ( / st fuzz )
;;;;always say Both first
(progn
(setq #acet-pljoinmode "Both")
(acet-setvar (list "ACET-PLJOINMODE" #acet-pljoinmode 2))
);progn then
(if (not #acet-pljoin-fuzz)
(setq #acet-pljoin-fuzz 0.0)
);if
(if (assoc "OSMODE" (car acet:sysvar-list))
(setvar "OSMODE" (cadr (assoc "OSMODE" (car acet:sysvar-list))))
);if
(setq fuzz "")
(while (equal (type fuzz) 'STR)
;;;;;show status
(setq st (acet-pljoin-init-mode2))
(princ (acet-str-format "\n Join Type = %1" st))
(if (equal "Both" st)
(princ " (Fillet and Add) ")
);if
;;;
(initget "Jointype _Jointype" 4)
(setq fuzz (getdist
(acet-str-format "\nEnter fuzz distance or [Jointype] <%1>: " (rtos #acet-pljoin-fuzz))
);getdist
);setq
(cond
((not fuzz)
(setq fuzz #acet-pljoin-fuzz)
);cond #1
((equal "Jointype" fuzz)
(acet-pljoinmode2)
);cond #2
((equal (type fuzz) 'REAL)
(setq #acet-pljoin-fuzz fuzz)
);cond #3
);cond close
);while
(setvar "osmode" 0)

(list #acet-pljoin-fuzz #acet-pljoinmode)
);defun acet-pljoin-get-fuzz-and-mode

  • 1

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#3 khunglong37

khunglong37

    biết pan

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

Đã gửi 29 January 2011 - 04:30 PM

Cảm ơn bác ketxu, em đang thử xem, có gì em sẽ hỏi bác tiếp nhé.
Nhưng sử dụng là lệnh jp ah bác

Có người post r đó bạn :) Code tương đối dài, áp dụng với cả arc nhé

;;; ;free lisp from cadviet.com @ ....
;;; ====================================================== join polyline
(defun c:jp ( / ss plines ss2 st fuzz)
(acet-error-init
(list (list "cmdecho" 0
"highlight" nil
"plinetype" 2
"limcheck" 0
"osmode" 0

);list
0 ;use undo marks but do not roll back on a cancel
);list
);acet-error-init

(setq plines (ssget ":l" '(
(-4 . " (0 . "ARC")
(0 . "LINE")
(-4 . " (0 . "*POLYLINE")
(-4 . "") ;8 16 64 not a 3dpoly or 3d/pface mesh
(-4 . "AND>")
(0 . "LWPOLYLINE")
(-4 . "OR>")
)
)
);setq
(if plines
(setq plines (acet-ss-filter-current-ucs plines T))
);if
(if plines
(setq plines (car (acet-ss-filter (list plines '(("CURRENTUCS")) T))))
);if
(princ "\n")
(if plines
(setq ss (convert plines));setq
);if
(if (and ss
(> (sslength ss) 0)
plines
);and
(mpedit ss) ;after conversion, plines sset is duplicated in ss
(progn
(if (not plines)
(princ "\nNothing selected.")
(princ "\nNo valid objects selected.")
);if
);progn else
);if

(acet-error-restore)
(acet-pljoin2 ss st fuzz)
;(acet-pljoin-get-fuzz-and-mode2)
(princ)
);defun c:jp

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; mpedit functionality and switch cases based on kword input operation

(defun mpedit ( plines / opt newWidth ss flt fuz st na ss2 )

(initget 0 "Open Close Join Ltype Decurve Fit Spline Width eXit _Open Close Join Ltype Decurve Fit

Spline Width eXit")
(setq opt "Join")
; (setq opt (getkword "\nEnter an option [Open/Close/Join/Width/Fit/Spline/Decurve/Ltype gen/eXit]

: "))
;Changed code below to a cond structure to improve readability R.K.
(cond
((= opt "Join")
(setq flt '((-4 . " (0 . "LINE")
(0 . "ARC")
(-4 . " (0 . "*POLYLINE")
(-4 . "") ;1 8 16 64
(-4 . "AND>")
(-4 . "OR>")
)
flt (list flt
"\n1 object is invalid for join."
"\n%1 objects are invalid for join."
);list
flt (list flt
(list "LAYERUNLOCKED")
(list "CURRENTUCS")
);list
ss (car (acet-ss-filter (list plines flt T)))
);setq

(acet-autoload (list "pljoin.lsp" "(acet-pljoin-get-fuzz-and-mode)"))
(acet-autoload (list "pljoin.lsp" "(acet-pljoin ss st fuz)"))

(if ss
(progn
(setvar "highlight" 0)
(setq fuz (acet-pljoin-get-fuzz-and-mode2)
st (cadr fuz)
fuz (car fuz)
na (entlast)
);setq
(acet-pljoin2 ss st fuz)
(setq ss2 (acet-ss-new na))
(setq plines (acet-ss-union (list plines ss2)))
);progn then
(princ "\nNo valid objects to join.")
);if
);cond Join option
);cond close
);defun mpedit

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Convert arcs and lines to polylines
;;; ss is retained as a duplicate of the plines selection set because
;;; after conversion, new handles are assigned to what were arcs and lines
(defun convert ( plines / ss count opt )
(if (> (sslength plines) 0)
(setq opt "Yes")
; (progn
; (initget 0 "Yes No _Yes No")
; (setq opt (getkword "Convert Lines and Arcs to polylines? [Yes/No] : "))
; );progn then
);if
(if (not opt)
(setq opt "Yes")
)
(if (and (= opt "Yes")
(> (sslength plines) 0)
);and
(progn ;if yes -- convert lines and arcs to polylines
(acet-undo-begin)
(setq ss (ssadd))
(setq count 0)
(while (< count (sslength plines))
(if (or (equal (assoc 0 (entget (ssname plines count))) '(0 . "ARC"))
(equal (assoc 0 (entget (ssname plines count))) '(0 . "LINE"))
);or
(progn
(command "_.pedit" (ssname plines count) "_yes" "_exit")
(ssadd (entlast) ss)
);progn true
(ssadd (ssname plines count) ss)
);if
(setq count (1+ count))
);while
(acet-undo-end)
);progn yes
(progn ;if no -- do not convert
(setq ss plines)
(setq count 0)
(while (< count (sslength ss))
(if (or (equal (assoc 0 (entget (ssname ss count))) '(0 . "ARC"))
(equal (assoc 0 (entget (ssname ss count))) '(0 . "LINE"))
);or
(progn
(ssdel (ssname ss count) ss)
(setq count (1- count))
);progn true
);if
(setq count (1+ count))
);while
);progn no
);if
(if (and ss
(equal (type ss) 'PICKSET)
(equal 0 (sslength ss))
);and
(setq ss nil)
);if
ss
)
(if (not #acet-pljoin-prec)
(setq #acet-pljoin-prec 0.0000001)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin2 ( ss st fuzz / flt )

(setq flt '((-4 . " (0 . "LINE")
(0 . "ARC")
(-4 . " (0 . "*POLYLINE")
(-4 . "") ;1 8 16 64
(-4 . "AND>")
(-4 . "OR>")
)
);setq
(if (and (setq ss (acet-pljoin-do-ss-pre-work2 ss flt)) ;convert lines/arcs/heavy plines ..etc.
;to lighweight plines
(setq ss (acet-pljoin-1st-pass2 ss flt)) ;initial pass with pedit command
);and
(acet-pljoin-2nd-pass2 ss fuzz st flt) ;where the work is..
);if

);defun acet-pljoin


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Try to join as many as possible before performing the
;hashing.
;
(defun acet-pljoin-1st-pass2 ( ss flt / na )

(acet-spinner)

(setq na (entlast))
(command "_.pedit" (ssname ss 0) "_j" ss "" "_x")

(command "_.select" ss)
(if (not (equal na (entlast)))
(command (entlast) "")
(command "")
);if
(setq ss (acet-ss-ssget-filter ss flt));setq
(if (and ss
(:s_big:) ;closest pairs point at each other
(setq na (last id) ;get some of the data out of id and id2
na2 (last id2)
p1 (cadr id) ;the real points
p2 (cadr id2)
);setq
(progn ;get the proper entity names from the ename map lst5
(while (setq c (assoc na lst5)) (setq na (cadr c)));while
(while (setq c (assoc na2 lst5)) (setq na2 (cadr c)));while
T
);progn
na ;both entities still exist?
na2

; (/= 1 (logand 1 (cdr (assoc 70 (entget na)))))
; (/= 1 (logand 1 (cdr (assoc 70 (entget na2)))))
);and
(progn
;then attempt a join
(setq flag nil
lst5 (acet-pljoin-do-join2 fuzz st na p1 na2 p2 lst5 tmpe1 tmpe2)
flag (cadr lst5) ;join success?
lst5 (car lst5)
);setq return updated entname map and success flag
(if flag
(setq ulst (cons id ulst) ;Then the join succeeded.
ulst (cons id2 ulst) ;mark the two as used by adding the them to ulst
);setq the success
(setq flst (cons (list id id2) flst)
flst (cons (list id2 id) flst)
);setq else join failed so mark as such in flst
);if
);progn then
(progn
(setq nskip (+ nskip 1));setq

;(print '(not (member id ulst)))
;(print (not (member id ulst)))
;(print '(not (member id2 ulst)))
;(print (not (member id2 ulst)))
;(print '(not (member (list id id2) flst)))
;(print (not (member (list id id2) flst)))
;(print '(setq b (assoc id2 lst2)))
;(print (setq b (assoc id2 lst2)))
;(print '(equal id (cadr B)))
;(print (equal id (cadr B)))
;(print 'na)
;(print na)
;(print 'na2)
;(print na2)
;
;(d-point (cadr id) "1")
;(d-point (cadr id2) "2")
;(princ "\ndecided not to try it.")
;(getstring "")
;(entdel (entlast))
;(entdel (entlast))

);progn else
);if
(setq n (+ n 1))
);repeat

(if (equal nskip n)
(setq lst nil);then all were skipped so the job is finished.
);if

(setq lst2 nil);setq ;;;remove the used and non-candidate point data from lst
(setq n 0)
(repeat (length lst)
(setq a (nth n lst));setq
(if (and (not (member n lst3)) ;not a non-candidate
(not (member a ulst)) ;not used
);and
(setq lst2 (cons a lst2))
);if
(setq n (+ n 1))
);repeat

(list lst2 lst5 flst)
);defun acet-pljoin-get-matched-pairs


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

;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin-get-closest2 ( p1 lst fuzz g flst / a b c d x1 x2 x3 y1 y2 y3 n j
lst2 lst3 len2 len3 clst
)

;(print "acet-pljoin-get-closest")
;(print "")

(setq b (cadr p1) ;the real point
a (car p1) ;the grid point
);setq

;determine the grid points to examine.
(cond
((equal fuzz 0.0 #acet-pljoin-prec)
(setq lst2 (list (list (car a) (cadr a))
);list
);setq else
);cond #2
(T
(if (B))
(setq x1 (car a)
x2 (acet-calc-round (+ (car a) g) g)
);setq
(setq x1 (acet-calc-round (- (car a) g) g)
x2 (car a)
);setq
);if
(if (B))
(setq y1 (cadr a)
y2 (acet-calc-round (+ (cadr a) g) g)
);setq
(setq y1 (acet-calc-round (- (cadr a) g) g)
y2 (cadr a)
);setq
);if
(setq lst2 (list (list x1 y1)
(list x2 y1)
(list x2 y2)
(list x1 y2)
);list
);setq
);cond #3
);cond close

(setq d (* fuzz 2.0)
len2 (length lst2)
);setq
;;loop through the grid points and check each of the points that fall on each grid point
(setq n 0)
(while (B)
(setq c (list (acet-calc-round (car a) g)
(acet-calc-round (cadr a) g)
);list
d (list (acet-calc-round (car B) g)
(acet-calc-round (cadr B) g)
);list
lst (cons (list c a 0 na) lst)
lst (cons (list d b 1 na) lst)
);setq then
);if

(if (equal n (* (/ n 10) 10)) ;update the spinner once every ten objects
(acet-spinner)
);if
(setq n (+ n 1));setq
);repeat
;(princ "Done.")

lst
);defun acet-pljoin-round


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin-get-epoints2 ( na / e1 a b z v )

;(print "acet-pljoin-get-epoints")
;(print "")

(if (and (setq e1 (entget na))
(setq e1 (acet-lwpline-remove-duplicate-pnts2 e1))
);and
(progn
(setq z (cdr (assoc 38 e1)));setq
(if (not z) (setq z 0.0))
(setq v (cdr (assoc 210 e1))
a (cdr (assoc 10 e1))
a (list (car a) (cadr a) z)
a (trans a v 1)
e1 (reverse e1)
b (cdr (assoc 10 e1))
b (list (car B) (cadr B) z)
b (trans b v 1)
);setq
(setq a (list a B))
);progn then
);if;

;(print "done epoints")

a
);defun acet-pljoin-get-epoints

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Takes an entity list of lwpolylines and modifies the object
;removing neighboring duplicate points. If no duplicated points
;are found then the object will not be passed to (entmod ).
;Returns the new elist when done.
(defun acet-lwpline-remove-duplicate-pnts2 ( e1 / a n lst e2)

(setq n 0)
(repeat (length e1)
(setq a (nth n e1));setq
(cond
((not (equal 10 (car a)))
(setq e2 (cons a e2))
);cond #1
((not (equal (car lst) a))
(setq lst (cons a lst)
e2 (cons a e2)
);setq
);cond #2
);cond close
(setq n (+ n 1));setq
);repeat
(setq e2 (reverse e2))
(if (and e2
(not (equal e1 e2))
lst
);and
(progn
(if (equal 1 (length lst))
(progn
(entdel (cdr (assoc -1 e1)))
(setq e2 nil)
);progn then single vertex polyline so delete it.
(progn
(setq e2 (subst (cons 90 (length lst)) (assoc 90 e2) e2)
);setq
(entmod e2)
);progn else
);if
);progn then
);if

e2
);defun acet-lwpline-make-remove-duplicate-pnts

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin-fillet-with-fuzz2 ( fuzz na p1 tmpe1 na2 p2 tmpe2 /
e1 e2 p1a p2a lst flag flag2 n a
tmpna tmpna2 x y v
)

;(print "acet-pljoin-fillet-with-fuzz")
;(print "")


(setq tmpna (cdr (assoc -1 tmpe1)) ;get the temp entitiy names out of the ent lists
tmpna2 (cdr (assoc -1 tmpe2))
lst (acet-pljoin-mod-tmp2 na p1 tmpe1) ;make the temp ent look like the begining or ending

segment
e1 (car lst) ;the modified temp ent list
flag (cadr lst) ;0 or 1 start or end
p1a (caddr lst) ;segment info sub-list (p1 p2 bulge) where p2 is always the

endpoint
lst (acet-pljoin-mod-tmp2 na2 p2 tmpe2)
e2 (car lst)
flag2 (cadr lst) ;0 or 1 start or end
p2a (caddr lst) ;segment info sub-list (p1 p2 bulge) ;in entity ucs
lst (acet-geom-intersectwith tmpna tmpna2 3) ;get the intersection list
v (cdr (assoc 210 e1))
lst (acet-geom-m-trans lst 0 v) ;trans to entity coord system
);setq

(if lst
(progn
(setq x (acet-pljoin-get-best-int2 p1a lst)) ;get the best intersection
(setq y (acet-pljoin-get-best-int2 p2a lst)) ;get the best intersection
;put the best intersections in the list x
(cond
((and x y)
(setq x (list x y))
);cond #1
;;(x (setq x (list x))) ;commented because both objects must pass the best intersect test
;;(y (setq x (list y)))
(T (setq x nil))
);cond
(if (and x
(setq x (acet-geom-m-trans x v 1))
(setq x (acet-pljoin-get-closest-int2 p1 p2 x))
(B))) ;arc segment, so get delta angle from arc_info
);if
(setq n 0)
(repeat (length lst)
(setq a (nth n lst))
(if (equal b 0.0)
(progn
;the it's a line segment
(if (and (or (equal (angle p1 a) a1 #acet-pljoin-prec) (equal (abs (- (angle p1 a) a1))
(* 2.0 pi)
#acet-pljoin-prec
)
);or
(or (not d)
(< (setq c (distance p2 a)) d)
);or
);and
(progn
(setq d c
j n
);setq
);progn then
);if
);progn then line segment
(progn
(if (equal p1 a #acet-pljoin-prec)
(progn
(setq a2 (* pi 2.0
(/ (abs a1) a1)
);mult
);setq then make it 360 degrees and preserve the sign.
);progn then
(progn
(setq nb (acet-pljoin-calc-new-bulge2 p1 b p2 a)
a2 (acet-geom-pline-arc-info p1 a nb)
a2 (caddr a2) ;delta angle
);setq
);progn else
);if
(setq c (abs (- (abs a2)
(abs a1)
)
)
);setq
(if (and (>= (* a2 a1) 0.0) ;same sign delta angle
(or (not d)
(:);if
;(entdel (entlast))
;(entdel (entlast))
;(if d (entdel (entlast)));if

d
);defun acet-pljoin-get-best-int

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin-get-closest-int2 ( p1 p2 lst / n a j d )

(setq n 0)
(repeat (length lst)
(setq a (nth n lst)
a (+ (distance a p1) (distance a p2))
);setq
(if (or (not d)
(B)
e2 (acet-list-put-nth (cons 10 x) e2 p1)
);setq then
(setq blg (acet-pljoin-calc-new-bulge2 (cdr (nth p2 e2))
(cdr (nth b e2))
(cdr (nth p1 e2))
x
)
e2 (acet-list-put-nth (cons 42 blg) e2 B)
e2 (acet-list-put-nth (cons 10 x) e2 p1)
);setq then
);if
);progn else arc segment
);if
(setq e1 (append e2 e1))
(if (equal flag 1)
(setq e1 (reverse e1))
);if
(entmod e1)

);defun acet-pljoin-fillet-mod-epoint

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Make the temporary ent match the segment of interest to get ready to
;use the intersectwith method.
;Takes an entity name and a point that is on one end of the entity
;and a entity list of a single segment lwpolyline
;modifies the single segment polyline such that it matches the
;first or last segment (depending on the p1 provided) of the
;polyline 'na'
;
(defun acet-pljoin-mod-tmp2 ( na p1 tmpe1 / e1 e2 a b z p2 flag v )

(setq e1 (entget na)
v (cdr (assoc 210 e1))
p1 (trans p1 1 v)
p1 (list (car p1) (cadr p1))
tmpe1 (subst (assoc 38 e1) (assoc 38 tmpe1) tmpe1)
tmpe1 (subst (assoc 39 e1) (assoc 39 tmpe1) tmpe1)
tmpe1 (subst (assoc 210 e1) (assoc 210 tmpe1) tmpe1)
z (cdr (assoc 38 e1))
a (assoc 10 e1)
);setq

(if (equal (cdr a) p1 #acet-pljoin-prec)
(progn
(setq flag 0
tmpe1 (reverse tmpe1)
tmpe1 (subst a (assoc 10 tmpe1) tmpe1)
tmpe1 (reverse tmpe1)
e2 (cdr (member (assoc 10 e1) e1))
p2 (list (car p1) (cadr p1) z)
p1 (cdr (assoc 10 e2))
p1 (list (car p1) (cadr p1) z)
tmpe1 (subst (assoc 10 e2) (assoc 10 tmpe1) tmpe1)
b (* -1.0 (cdr (assoc 42 e2)))
tmpe1 (subst (cons 42 B)
(assoc 42 tmpe1)
tmpe1
)
);setq
);progn then
(progn
(setq flag 1
e2 (reverse e1)
tmpe1 (reverse tmpe1)
a (assoc 10 e2)
p2 (cdr a)
p2 (list (car p2) (cadr p2) z)
tmpe1 (subst a (assoc 10 tmpe1) tmpe1)
e2 (cdr (member a e2))
p1 (cdr (assoc 10 e2))
p1 (list (car p1) (cadr p1) z)
b (cdr (assoc 42 e2))
tmpe1 (reverse tmpe1)
tmpe1 (subst (cons 42 B) (assoc 42 tmpe1) tmpe1)
a (assoc 10 e2)
tmpe1 (subst (assoc 10 e2) (assoc 10 tmpe1) tmpe1)
);setq
);progn else
);if

(entmod tmpe1)

(list e1 flag (list p1 p2 B))
);defun acet-pljoin-mod-tmp

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;Calculates the new bulge formed by moving
;point p2 to p3 and still retaining the same radius and center point.
;
(defun acet-pljoin-calc-new-bulge2 ( p1 b p2 p3 / p4 x r a c b2 info )

(setq c (distance p1 p3))
(if (not (equal c 0.0))
(progn
(setq p4 (acet-geom-midpoint p1 p3)
info (acet-geom-pline-arc-info p1 p2 B)
r (cadr info);radius
x (car info) ;center point
a (- r
(distance x p4)
)
);setq
(setq b2 (/ (* 2.0 a) c)
b2 (* b2 (/ (abs B) B))
);setq
(setq info (acet-geom-pline-arc-info p1 p3 b2))
(if (not (equal x (car info) #acet-pljoin-prec))
(progn
(setq a (- (* r 2.0) a));setq
(setq b2 (/ (* 2.0 a) c)
b2 (* b2 (/ (abs B) B))
);setq
);progn then
);if
);progn then
(setq b2 0.0)
);if

b2
);defun acet-pljoin-calc-new-bulge


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;- explode all curve fitted and/or splined plines and re-join
;- convert all to light weight plines.
;- turn all arcs and lines into lightweight plines.
;- finally return a selection set of all plines.
(defun acet-pljoin-do-ss-pre-work2 ( ss flt / na ss2 ss3 n w)


(command "_.select" ss "")
(setq ss2 (ssget "_p" '((-4 . "&") (70 . 6)))) ;fit or splined
(command "_.select" ss "")
(setq ss3 (ssget "_p" '((-4 . "")))) ;lines and arcs

(if ss2
(progn
(setq n 0)
(repeat (sslength ss2)
(setq na (ssname ss2 n)
w (acet-pljoin-get-width2 na)
);setq
(command "_.explode" na)
(while (wcmatch (getvar "cmdnames") "*EXPLODE*") (command ""))
(command "_.pedit" (entlast) "_y" "_j" "_p" "")
(if (not (equal w 0.0))
(command "_w" w)
);if
(command "_x")
(setq ss (ssdel na ss)
ss (ssadd (entlast) ss)
);setq
(setq n (+ n 1));setq
);repeat
);progn then
);if
(command "_.convertpoly" "_light" ss "")
(if ss3
(progn
(setq n 0)
(repeat (sslength ss3)
(setq na (ssname ss3 n));setq
(command "_.pedit" na "_y" "_x")
(setq ss (ssdel na ss)
ss (ssadd (entlast) ss)
);setq
(setq n (+ n 1));setq
);repeat
);progn then
);if
(if (equal 0 (sslength ss))
(setq ss nil)
);if
(setq ss (acet-pljoin-ss-flt2 ss flt))


ss
);defun acet-pljoin-do-ss-pre-work


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;return the with of the heavy polyline provided in 'na'
(defun acet-pljoin-get-width2 ( na / e1 a B)

(if (and (setq e1 (entget na))
(equal (cdr (assoc 0 e1)) "POLYLINE")
);and
(progn
(setq a (cdr (assoc 40 e1))
b (cdr (assoc 41 e1))
);setq
(while (and (equal a B)
(setq na (entnext na))
(setq e1 (entget na))
(not (equal (cdr (assoc 0 e1)) "SEQEND"))
);and
(setq a (cdr (assoc 40 e1))
b (cdr (assoc 41 e1))
);setq
);while
);progn then
(setq a 0.0)
);if
a
);defun acet-pljoin-get-width

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin-ss-flt2 ( ss flt / n na e1 p1 p2 )
(if (and ss
(> (sslength ss) 0)
);and
(progn
(command "_.select" ss "")
(setq ss (ssget "_p" flt))
);progn then
(setq ss nil)
);if

ss
);defun acet-pljoin-ss-flt


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;prompt for a joinmode setting of "Fillet" or "Add"
(defun acet-pljoinmode2 ( / st )
(acet-pljoin-init-mode2)
(initget "Fillet Add Both _Fillet Add Both")
(setq st (getkword
(acet-str-format "\nEnter join type [Fillet/Add/Both] <%1>: " #acet-pljoinmode)
);getkword
);setq
(if st
(progn
(setq #acet-pljoinmode st)
(acet-setvar (list "ACET-PLJOINMODE" #acet-pljoinmode 2))
);progn
);if
);defun acet-pljoinmode

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun acet-pljoin-init-mode2 ()
(if (not #acet-pljoinmode)
(setq #acet-pljoinmode (acet-getvar '("ACET-PLJOINMODE" 2)))
);if
(if (not #acet-pljoinmode)
(progn
(setq #acet-pljoinmode "Both")
(acet-setvar (list "ACET-PLJOINMODE" #acet-pljoinmode 2))
);progn then
);if
#acet-pljoinmode
);defun acet-pljoin-init-mode

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;prompt for fuzz distance and/or pljoinmode setting.
;return list... (fuzz pljoinmode)
;
(defun acet-pljoin-get-fuzz-and-mode2 ( / st fuzz )
;;;;always say Both first
(progn
(setq #acet-pljoinmode "Both")
(acet-setvar (list "ACET-PLJOINMODE" #acet-pljoinmode 2))
);progn then
(if (not #acet-pljoin-fuzz)
(setq #acet-pljoin-fuzz 0.0)
);if
(if (assoc "OSMODE" (car acet:sysvar-list))
(setvar "OSMODE" (cadr (assoc "OSMODE" (car acet:sysvar-list))))
);if
(setq fuzz "")
(while (equal (type fuzz) 'STR)
;;;;;show status
(setq st (acet-pljoin-init-mode2))
(princ (acet-str-format "\n Join Type = %1" st))
(if (equal "Both" st)
(princ " (Fillet and Add) ")
);if
;;;
(initget "Jointype _Jointype" 4)
(setq fuzz (getdist
(acet-str-format "\nEnter fuzz distance or [Jointype] <%1>: " (rtos #acet-pljoin-fuzz))
);getdist
);setq
(cond
((not fuzz)
(setq fuzz #acet-pljoin-fuzz)
);cond #1
((equal "Jointype" fuzz)
(acet-pljoinmode2)
);cond #2
((equal (type fuzz) 'REAL)
(setq #acet-pljoin-fuzz fuzz)
);cond #3
);cond close
);while
(setvar "osmode" 0)

(list #acet-pljoin-fuzz #acet-pljoinmode)
);defun acet-pljoin-get-fuzz-and-mode


  • 0

#4 khunglong37

khunglong37

    biết pan

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

Đã gửi 29 January 2011 - 04:40 PM

Bác ketxu giải thích cách dùng lệnh nào hộ em với, em thấy dài quá mà không biết dùng lệnh nào

Cảm ơn bác ketxu, em đang thử xem, có gì em sẽ hỏi bác tiếp nhé.
Nhưng sử dụng là lệnh jp ah bác


  • 0

#5 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5685 Bài viết
Điểm đánh giá: 2606 (tuyệt vời)

Đã gửi 29 January 2011 - 10:48 PM

Srr bạn vì bạn nói mới bắt đầu học lisp, nên mình không nói rõ, vì cái defun c: là cái tối thiểu bạn cần biết khi bắt đầu viết hoặc sử dụng lisp :s_big:
Lệnh là jp, sau khi chọn các đối tượng bạn nhập vào khoảng cách nối lớn nhất (hoặc chọn 2 điểm trên màn hình) nhé. Chúc bạn thành công
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#6 khunglong37

khunglong37

    biết pan

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

Đã gửi 29 January 2011 - 11:44 PM

Em đã chạy lệnh của bác nhưng không ra cái gì cả, trong autolisp console thì nó hiện ra lỗi thế này :
error: misplaced dot on input
bác xem hộ em với. Tks bác nhiều

Srr bạn vì bạn nói mới bắt đầu học lisp, nên mình không nói rõ, vì cái defun c: là cái tối thiểu bạn cần biết khi bắt đầu viết hoặc sử dụng lisp :s_big:
Lệnh là jp, sau khi chọn các đối tượng bạn nhập vào khoảng cách nối lớn nhất (hoặc chọn 2 điểm trên màn hình) nhé. Chúc bạn thành công


  • 0

#7 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5685 Bài viết
Điểm đánh giá: 2606 (tuyệt vời)

Đã gửi 29 January 2011 - 11:49 PM

Có thể diễn đàn đang gặp lỗi, bạn thư load file này xem sao
Jp
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#8 khunglong37

khunglong37

    biết pan

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

Đã gửi 30 January 2011 - 12:02 AM

Em đã thử nhưng nó lại hiện ra lỗi này:
jp
Select objects: Specify opposite corner: 32 found
Select objects:
Join Type = Both (Fillet and Add)
Enter fuzz distance or [Jointype] <500.0000>: 5000
\; error: bad argument type: numberp: nil

và thỉnh thoảng nó nối cả 4 điểm thành hình vuông như thế này
Hình đã gửi

http://www.cadviet.c.../untitled_6.png

bác xem hộ em với. Tks bác

Có thể diễn đàn đang gặp lỗi, bạn thư load file này xem sao
Jp


  • 0

#9 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5685 Bài viết
Điểm đánh giá: 2606 (tuyệt vời)

Đã gửi 01 February 2011 - 09:00 PM

Oh,mình về quê,h mới đọc tin của bạn.Ở đây k có Cad n mình nhớ là lisp này dù báo lỗi n nó vẫn chạy mượt, còn việc nối 2 đường ngoài phạm vi với nhau thì cũng dễ hiểu, nó là máy,bạn cho ra sao thì nó làm như vậy,bạn cho ctrình 1 ôố fuzz quá lớn, số này như mình nói là kc lớn nhất để ctrình tìm điểm nối,bạn hãy cho nhỏ hơn kcách giữa 2 đường song song đi xem sao :s_big:
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#10 almodeus

almodeus

    biết vẽ arc

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

Đã gửi 11 February 2011 - 04:11 PM

từ cad 2008 đã có lệnh nối line mà không cần Lisp đâu...Lệnh Join (gõ J) rồi chon Line cần nối là được
  • 0

#11 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5685 Bài viết
Điểm đánh giá: 2606 (tuyệt vời)

Đã gửi 11 February 2011 - 09:25 PM

từ cad 2008 đã có lệnh nối line mà không cần Lisp đâu...Lệnh Join (gõ J) rồi chon Line cần nối là được

Bạn hok thực sự đọc yêu cầu của chủ topic rùi :)
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#12 almodeus

almodeus

    biết vẽ arc

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

Đã gửi 12 February 2011 - 08:51 PM

sorry, cai này tức là kết hợp Join với quét chọn multi nhưng quét chọn vậy tum lum lộn xộn...hì...viet lisp cung met
  • 0

#13 khunglong37

khunglong37

    biết pan

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

Đã gửi 14 February 2011 - 01:40 PM

Cảm ơn tất cả các bác, chúc mọi người một năm mới nhiều thành công

Bạn hok thực sự đọc yêu cầu của chủ topic rùi :)


  • 0

#14 sydaica

sydaica

    biết pan

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

Đã gửi 15 June 2011 - 04:55 PM

bạn cứ dùng lệnh join(viết tắt la J) rồi chọn các chi tiết rời , rồi ấn enter là xong.
  • 0