Acadpgp.LSP
(setvar
"DIMASSOC"
2)
(setvar
"OSNAPCOORD"
1)
(setvar
"CMDECHO"
0)
(defun c:cc (/)(command ".circle")(princ))
(defun c:c (/ ss)(setq ss (ssget))(if ss (command ".copy" ss "" "M"))(princ))
(defun c:r (/)(command ".rectang")(princ))
(defun c:a (/)(command ".arc")(princ))
(defun c:aa (/)(command ".area")(princ))
(defun c:al (/)(command ".align")(princ))
(defun c:ch (/)(command ".chamfer")(princ))
(defun c:dda (/)(command ".dimdisassociate")(princ))
(defun c:di (/)(command ".dist")(princ))
(defun c:dv (/)(command ".divide")(princ))
(defun c:div (/)(command ".divide")(princ))
(defun c:dro (/)(command ".draworder")(princ))
(defun c:e (/)(command ".erase")(princ))
;(defun c:t (/)(command ".text")(princ))
(defun c:el (/)(command ".ellipse")(princ))
(defun c:ex (/)(command ".extend")(princ))
(defun c:ext (/)(command ".extrude")(princ))
(defun c:f (/)(command ".fillet")(princ))
(defun c:l (/)(command ".line")(princ))
(defun c:li (/)(command ".list")(princ))
(defun c:mp (/)(command ".matchprop")(princ))
(defun c:me (/)(command ".measure")(princ))
(defun c:mi (/)(command ".mirror")(princ))
(defun c:o (/)(command ".offset")(princ))
(defun c:op (/)(command ".options")(princ))
(defun c:po (/ p)
(initget "ddpType")
(while (setq p (getpoint "\nPick a Point
(if (= p "pType")
(command ".PType")
(progn
; (setvar "cmdecho" 1)
(command ".point" p)
; (setvar "cmdecho" 0)
)
)
(initget "ddpType")
)
(princ)
)
(defun c:pa (/)(command ".pastespec")(princ))
(defun c:pe (/)(command ".pedit")(princ))
(defun c:pl (/)(command ".pline")(princ))
(defun c:pol (/)(command ".polygon")(princ))
(defun c:ren (/)(command ".regen")(princ))
(defun c:reg (/)(command ".region")(princ))
(defun c:ri (/)(command ".reinit")(princ))
(defun c:rev (/)(command ".revcloud")(princ))
(defun c:rr (/)(command ".rotate")(princ))
(defun c:sk (/)(command ".sketch")(princ))
(defun c:sc (/)(command ".scale")(princ))
(defun c:spl (/)(command ".spline")(princ))
(defun c:spe (/)(command ".splinedit")(princ))
(defun c:su (/)(command ".subtract")(princ))
(defun c:un (/)(command ".union")(princ))
(defun c:tr (/)(command ".trim")(princ))
(defun c:uu (/)(command ".redo")(princ))
(defun c:uci (/)(command ".ucsicon")(princ))
;(defun c:ucs (/)(command ".ucs")(princ))
(defun c:we (/)(command ".wedge")(princ))
;(defun c:x (/)(command ".explode" (ssget))(princ))
(defun c:xl (/)(command ".xline")(princ))
(defun c:wp (/)(command ".wipeout")(princ))
(princ)
C - BH.LSP
; RECREATE HATCH BOUNDARY
;Analyse from dxfcode 91 to 75
(setq ss (ssget (list (cons 0 "HATCH")))
i 0
);setq
(if ss
(progn
(setq ssl (sslength ss) ssall (ssadd) ent (entlast))
(setvar "CMDECHO" 0)
(command ".undo" "begin")
(repeat ssl
(setq hat (ssname ss i))
(exhatchboundary hat)
(setq i (1+ i))
);repeat
(command ".undo" "end")
(while ent
(setq ent (entnext ent))
(if ent (setq ssall (ssadd ent ssall)))
);while
(sssetfirst nil ssall)
);progn
);if ss
(princ)
);defun
(defun exhatchboundary (hat / loop hl nloops dxf i loopsl field ss sss newhat highlightss)
(setq hl (entget hat)
)
(if (/= (cdr(assoc 0 hl)) "HATCH")(exit))
(setq nloops (cdr (assoc 91 hl)))
;devide hl in sub list begin with 92
(setq i -1)
(while (/= dxf 91)
(setq i (1+ i))
(setq field (nth i hl))
(setq dxf (car field))
);while
; each loop store in a list call loop
;all loops store in loopsl
;
(setq loopsl (list)
loop (list))
;----------------------------------------
(while (/= dxf 75)
(setq i (1+ i))
(setq field (nth i hl))
(setq dxf (car field))
(if (= 92 dxf)
(progn
(if loop (setq loopsl(append loopsl (list loop)))
);if loop (append loopsl (list loop))
(setq loop (list))
);progn
);(if (= 92 dxf)
(if (and(/= dxf 97)(/= dxf 75)(/= dxf 330))
(setq loop (append loop (list field)))
);(if (and(/= dxf 97)(/= dxf 75)(/= dxf 330))
);while
(setq loopsl(append loopsl (list loop)))
;+++++++++++++++++++++++++++++++++++++++
;iterate through each loops in loopsl
(setq ss (ssadd))
(foreach loop loopsl
(setq sss (drawhatchloop loop))
(if sss (setq ss (ssjoin ss sss)))
);foreach loop loopsl
! ss
);defun
(defun hatchboundary (hat / loop hl nloops dxf i loopsl field ss sss)
(setq hl (entget hat)
)
(if (/= (cdr(assoc 0 hl)) "HATCH")(exit))
(setq nloops (cdr (assoc 91 hl)))
;devide hl in sub list begin with 92
(setq i -1)
(while (/= dxf 91)
(setq i (1+ i))
(setq field (nth i hl))
(setq dxf (car field))
);while
; each loop store in a list call loop
;all loops store in loopsl
;
(setq loopsl (list)
loop (list))
;----------------------------------------
(while (/= dxf 75)
(setq i (1+ i))
(setq field (nth i hl))
(setq dxf (car field))
(if (= 92 dxf)
(progn
(if loop (setq loopsl(append loopsl (list loop)))
);if loop (append loopsl (list loop))
(setq loop (list))
);progn
);(if (= 92 dxf)
(if (and(/= dxf 97)(/= dxf 75)(/= dxf 330))
(setq loop (append loop (list field)))
);(if (and(/= dxf 97)(/= dxf 75)(/= dxf 330))
);while
(setq loopsl(append loopsl (list loop)))
;+++++++++++++++++++++++++++++++++++++++
;iterate through each loops in loopsl
(setq ss (ssadd))
(foreach loop loopsl
;draw loop, then get the new entity
(setq sss (drawhatchloop loop))
(if sss (setq ss (ssjoin ss sss)))
);foreach loop loopsl
);defun
(defun drawhatchloop (loop / pline ss)
(setq btype (cdr (assoc 92 loop)))
;2 types of loops
;1 - Loop created from lines and arcs
;2 - Loop created of lwpolyline
(setq bit2 (rem (fix(/ btype 2)) 2))
(if (= bit2 0)
(setq ss (line-arcloop loop));line and arc
(setq pline (polylineloop loop)
ss (ssadd pline));polyline datalist
)
! ss
)
(defun polylineloop (loop / ent i l dxf lwpline)
(setq lwpline (list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
;(cons 67 0)
;(cons 410 "Model")
;(cons 8 "0")
(cons 100 "AcDbPolyline")
(cons 90 (cdr(assoc 93 loop)))
(cons 70 1)
(cons 43 0.)
(cons 38 0.)
(cons 39 0.)
)
);setq
(foreach l loop
(if (= 10 (car l))
(progn
(setq lwpline (append lwpline (list l
(cons 40 0)
(cons 41 0)
)
)
)
);progn
(if (= 42 (car l)) (setq lwpline (append lwpline (list l))))
);if
);foreach
(setq lwpline (append lwpline (list (cons 210 (list 0. 0. 1.)))))
(entmake lwpline)
(setq ent (entlast))
! ent
);defun
(defun line-arcloop (loop / ss i n dl rec dxf ent)
(setq ss (ssadd))
(setq n (length loop)
i -1)
(while (< i (1- n))
(setq dl (list))
(setq i (1+ i)
rec (nth i loop)
dxf (car rec)
)
(if (= dxf 72)
(progn
(setq dxf 0)
(while (and dxf (/= dxf 72))
(setq dl (append dl (list rec)))
(setq i (1+ i)
rec (nth i loop)
dxf (car rec)
)
);(while (/= dxf 72)
;Get dline
(setq ent (drawdline dl)
ss (ssadd ent ss))
(setq i (1- i)
dxf 0)
);progn
);(if (= dxf 72)
);while
(command ".PEDIT" "M" ss "")
(command "Y" "j" "" "")
(setq ent (entlast))
(setq ss (ssadd))
(while ent
(setq ent (entnext ent))
(if ent (setq ss (ssadd ent ss)))
);defun
! ss
);defun
(defun drawdline (dl / ent el 72code cclw)
(setq 72code (cdr (assoc 72 dl)))
(if (= 72code 1) ;Line
(progn
(setq el (list (cons 0 "LINE")
(assoc 10 dl)
(assoc 11 dl)
)
);setq
(entmake el)
)
(if (= 72code 2)
(progn
(setq cclw (cdr (assoc 73 dl)))
(if (= 0 cclw)
(progn
(setq sa (cdr(assoc 50 dl))
sa (- (+ pi pi) sa)
ea (cdr(assoc 51 dl))
ea (- (+ pi pi) ea)
)
(setq el (list (cons 0 "ARC")
(assoc 10 dl)
(assoc 40 dl)
(cons 50 ea)
(cons 51 sa)
)
)
(entmake el)
)
(progn
(setq el (list (cons 0 "ARC")
(assoc 10 dl)
(assoc 40 dl)
(assoc 50 dl)
(assoc 51 dl)
)
);setq
(entmake el)
);progn
);if cclw = 0
);progn
);if Arc
);if
(setq ent (entlast))
! ent
);defun
(defun ssjoin (ss1 ss2 / l1 e ss i)
;Join all the avaiable entities in two selection set to one selection set
(setq ss (ssadd))
(setq l1 (sslength ss1)
i -1)
(repeat l1 (setq i (1+ i))
(setq e (ssname ss1 i))
(if (entget e)(setq ss (ssadd e ss)));if
);repeat
(setq l2 (sslength ss2)
i -1)
(repeat l2 (setq i (1+ i))
(setq e (ssname ss2 i))
(if (entget e)(setq ss (ssadd e ss)));if
);repeat
! ss
);
(princ)
C - PVD.LSP
;SMOOTHING PLINE
;as posted to the autodesk newsgroup by
;Brian Hailey, on or around 4/23/03
;Function to weed unneeded vertices in a LWpolyline, usually
;used for contours.....
;
elist)
(command "_.undo" "begin")
(setq dist (getdist "\nmax dist between verts: ")
ang (getreal "\nmax angle between segs: ")
track 0
)
;;vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvvvvvvvvvvvvvv
;; added by CAB 09/07/04 to allow select of ALL plines in drawing
(prompt "\nSelect lwpolys to weed or Enter to select all: ")
(cond ((SETQ sel (SSGET '((0 . "LWPOLYLINE"))))) ; user picked dimensions
((SETQ sel (SSGET "X" '((0 . "LWPOLYLINE"))))) ; all dimensions
) ;_ end of if
;;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^
(while (< track (sslength sel))
(setq polys (entget (ssname sel track))
temp polys
temp (while (/= (car (nth 0 temp)) 10)
(setq temp (cdr temp))
)
temp (reverse temp)
temp (while (/= (car (nth 0 temp)) 42)
(setq temp (cdr temp))
)
temp (reverse temp)
)
(setq plist nil
plist (append plist
(list (nth 0 temp) (nth 1 temp) (nth 2 temp) (nth 3 temp)))
pt1 (cdr (nth 0 temp))
pt2 (cdr (nth 4 temp))
pt3 (cdr (nth 8 temp))
cnt 0
)
(while (nth (+ cnt 8) temp)
(setq pt1 (cdr (nth cnt temp))
pt2 (cdr (nth (+ cnt 4) temp))
pt3 (cdr (nth (+ cnt 8) temp))
)
(if ;(and (< (+ (distance pt1 pt2) (distance pt2 pt3)) dist)
(< (abs (- (angle pt1 pt2) (angle pt2 pt3)))(* (/ ang 180.0) pi))
(setq temp (append (list (nth 0 temp) (nth 1 temp)
(nth 2 temp) (nth 3 temp)
)
(member (nth 8 temp) temp)
)
)
(setq plist (append plist (list (nth 4 temp) (nth 5 temp)
(nth 6 temp) (nth 7 temp)
)
)
temp (cddddr temp)
)
)
)
(setq plist (append plist (list (nth 4 temp) (nth 5 temp)
(nth 6 temp) (nth 7 temp)
)
)
)
(setq elist (append (list (assoc 0 polys)
(assoc 100 polys)
(assoc 67 polys)
(assoc 410 polys)
(assoc 8 polys)
(cons 100 "AcDbPolyline")
(cons 90 (/ (length plist) 4))
(assoc 70 polys)
)
(if (assoc 43 polys)
(list
(assoc 43 polys)
(assoc 38 polys)
(assoc 39 polys)
)
(list
(assoc 38 polys)
(assoc 39 polys)
)
)
)
)
;;vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv vvvvvvvvvvvvvvvvv
;; added by CAB 08/24/04 to include the following info if it exist
(if (assoc 6 polys) ; Line Type
(setq elist (append elist (list (assoc 6 polys))))
)
(if (assoc 48 polys) ; Line Type Scale
(setq elist (append elist (list (assoc 48 polys))))
)
(if (assoc 62 polys) ; Color
(setq elist (append elist (list (assoc 62 polys))))
)
(setq elist (append elist plist (list (assoc 210 polys))))
;;^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^^
(entmake elist)
(entdel (ssname sel track))
(setq track (1+ track))
)
(command "_.undo" "end")
(princ)
)
(prompt "\nPolyline Weeder Loaded, Enter PVD to run.")
(princ)
C-0 Sca Ht MM Xk TT Lalt GG Xpl SS.lsp
;Sca Ht MM Xk TT Lalt GG 0 Xpl
(defun c:ht (/) (hatchlayer))
(defun c:mm (/) (doublemirror))
(defun c:xk (/) (xaukim))
(defun c:tt (/) (trongtam))
(defun c:lalt (/) (listAllLinetype))
(defun c:gg (/) (GroupToggle))
(defun C:0 ()
(Command "layer" "M" "0" ^C^C)
(princ)
);defun
(defun C:xpl ()
(begin)
(setq vp (getpoint "\nPick the Vanishing Point")) ;get the vanishing point
(setq pt2 (getpoint "\nPick the Point to Vanish from" vp)) ;get the point to vanish from
(while (not (null Pt2)) ;loop until no point to vanish from
(command "line" vp pt2 "") ;draw the lines
(setq pt2 (getpoint "\nPick the Point to Vanish from" vp))) ;reset the point to vanish from
(end)
(princ) ;prevent echo
)
(defun c:ss (/ tilemode cvp)
(setq tilemode (getvar "TILEMODE")
cvp (getvar "CVPORT")
)
(if (= tilemode 1)
(progn
(setvar "LTSCALE" 1)
(setvar "TILEMODE" 0)
;(setvar "DIMSCALE" 1)
);progn
(if (= cvp 1)(setvar "TILEMODE" 1)(command ".PSPACE"));if
);if
(princ)
)
; DOUBLE MIRROR
(defun DoubleMirror (/ osm obs bp ep1 ep2 x1 y1 x0 y0)
(setq osm (getvar "osmode"))
(prompt "\nDouble Mirror :\n")
(setq obs (ssget))
(begin)
(setvar "osmode" 47)
(setq bp (getpoint "Nhap diem goc : ")
ep1 (getpoint bp "\nNhap diem cuoi cua 1 trong 2 mirror lines: ")
)
(while (equal bp ep1) (setq ep1 (getpoint bp "\n2 diem trung nhau !\nNhap lai diem cuoi cua 1 trong 2 mirror lines: ")));while
(setq x1 (- (car ep1) (car bp))
y1 (- (cadr ep1) (cadr bp))
x0 (car bp) y0 (cadr bp)
)
(setq ep2 (list (+ x0 y1) (- y0 x1)))
(setvar "osmode" 0)
(setvar "orthomode" 0)
(Command ".copy" obs "" '(0 0) '(0 0)
".mirror" obs "" bp ep1 "y"
"copy" obs "" '(0 0) '(0 0)
".mirror" obs "" bp ep2 "y"
".mirror" obs "" bp ep1 "")
(setvar "osmode" osm)
(end)
); MISSION COMPLETE.
(defun hatchlayer (/ sshat) ;Chuong trinh chuyen toan bo cac doi tuong hatch sang layer hatch
(Command ".layer" "new" "Hatch" "")
(setq sshat (ssget (list (cons 0 "HATCH"))))
(if sshat
(progn
(command ".change" sshat "" "P" "La" "Hatch" "")
(command ".draworder" sshat "" "back")
)
)
(princ)
)
(defun xaukim (/ ss l i ent entlist el elname nee cp sp ep dxf cpl)
;xau kim ...
(begin)
(setq cpl (list))
(setq ss (ssget '((-4 . "
(0 . "Circle")
(0 . "Ellipse")
(0 . "Arc")
(0 . "Line")
(0 . "LWPolyline")
(-4 . "or>")
)
)
)
(setq l (sslength ss)
i 0
)
(repeat l
(setq ent (ssname ss i))
(setq entlist (append entlist (list ent)))
(setq i (1+ i))
)
(foreach ent entlist
(setq el (entget ent))
(setq elname (cdr (assoc 0 el)))
(cond
(
(or (equal "CIRCLE" elname)
(equal "ARC" elname)
(equal "ELLIPSE" elname)
)
(setq cp (assoc 10 el))
(setq cp (li_extr cp '(1 2)))
(setq cpl (app cpl cp))
)
(
(equal "LWPOLYLINE" elname)
(setq i 0
cp (list 0 0)
)
(foreach dxf el
(if (= (car dxf) 10)
(setq i (1+ i)
cp (suml (list cp (li_extr dxf '(1 2))))
)
)
)
(setq cp (v_div_r cp i))
(setq cpl (app cpl cp))
)
(
(equal "LINE" elname)
(setq sp (li_extr (assoc 10 el) '(1 2)))
(setq ep (li_extr (assoc 11 el) '(1 2)))
(setq cp (suml (list ep sp)))
(setq cp (v_div_r cp 2))
(setq cpl (app cpl cp))
)
) ;cond
) ;foreach
(command ".ucs" "w")
(setq nee (getpoint "\nCho diem xau kim "))
(if (not nee)
(setq nee (nth 0 cpl))
)
(setq i -1)
(foreach ent entlist
(setq i (1+ i))
(setq cp (nth i cpl))
(command ".move" ent "" cp nee)
)
(command ".ucs" "p")
(princ)
(end)
)
(defun trongtam (/ ss l i ent entlist el elname nee cp sp ep dxf cpl clayer)
;trong tam polyline, circle, ellip...
(begin)
(setq cpl (list))
(setq ss (ssget '((-4 . "
(0 . "Circle")
(0 . "Ellipse")
(0 . "LWPolyline")
(-4 . "or>")
)
)
)
(setq l (sslength ss)
i 0
)
(repeat l
(setq ent (ssname ss i))
(setq entlist (append entlist (list ent)))
(setq i (1+ i))
)
(foreach ent entlist
(setq el (entget ent))
(setq elname (cdr (assoc 0 el)))
(cond
(
(or (equal "CIRCLE" elname)
(equal "ELLIPSE" elname)
)
(setq cp (assoc 10 el))
(setq cp (li_extr cp '(1 2)))
(setq cpl (app cpl cp))
)
(
(equal "LWPOLYLINE" elname)
(setq i 0
cp (list 0 0)
)
(foreach dxf el
(if (= (car dxf) 10)
(setq i (1+ i)
cp (suml (list cp (li_extr dxf '(1 2))))
)
)
)
(setq cp (v_div_r cp i))
(setq cpl (app cpl cp))
)
) ;cond
) ;foreach
(command ".ucs" "w")
(setq clayer (getvar "Clayer"))
(command ".layer" "m" "Pointing" "")
(setq i -1)
(foreach ent entlist
(setq i (1+ i))
(setq cp (nth i cpl))
(command ".point" cp)
)
(command ".ucs" "p")
(setvar "clayer" clayer)
(princ)
(end)
)
(defun listAllLinetype (/ lt ltli)
(setq lt (tblnext "ltype" T) ltli (list))
(while lt
(setq lt (cdr (assoc 2 lt)))
(setq ltli (append ltli (list lt)))
(setq lt (tblnext "ltype"))
);while
(setq ob (car (entsel)))
(foreach lt ltli
(command ".copy" ob "" '(0 0) '(0 -10))
(setq ob (entlast))
(command ".change" ob "" "p" "lt" lt "")
)
)
;+++++++++++++++++++++++++++++++++++++++++++++
;+++++++++++++++++++++++++++++++++++++++++
(defun GroupToggle (/)
(setq pickst (getvar "Pickstyle"))
(cond
((= pickst 1) (setq pickst 0
prom "\nGroup off"))
((= pickst 2) (setq pickst 3
prom "\nGroup on"))
((= pickst 3) (setq pickst 2
prom "\nGroup off"))
((= pickst 0) (setq pickst 1
prom "\nGroup on"))
)
(prompt prom)
(setvar "pickstyle" pickst)
(princ)
)
;April 3th 2005
;;;;; Chuong trinh chua hoan thien
(defun scaleAll (/ scf)
(begin)
(setq scf (getreal "Nhap gia tri scale factor : "))
(while (setq ss (ssget))
(command ".scale" ss "" pause scf)
)
(end)
(princ)
)
(princ)
C-Ca Ra Ta Dx Br Cr Cd Pj.LSP
;Ca Ra Ta Dx Br Cr Cd Pj
(defun c:ra (/) (rotateArray))
(defun c:ta (/) (textArray))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:dx (/) (doixungtam))
(defun c:br (/) (break))
(defun c:cr (/) (copyrotate))
(defun c:cd (/) (copydupplicate))
(defun c:pj (/) (peditjoin))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; DOI XUNG TAM
(defun doixungtam (/ osm obs bp ep1 ep2 x1 y1 x0 y0)
(setq osm (getvar "osmode"))
(prompt "\nDoi xung tam :\n")
(setq obs (ssget))
(begin)
(setvar "osmode" 47)
(setq bp (getpoint "Nhap diem tam doi xung : "))
(setq x0 (car bp) y0 (cadr bp))
(setq ep1 (list (+ x0 1) y0))
(setq ep2 (list x0 (+ y0 1)))
(setvar "osmode" 0)
(setvar "orthomode" 0)
(Command ".copy" obs "" '(0 0) '(0 0)
".mirror" obs "" bp ep1 "y"
".mirror" obs "" bp ep2 "y")
(setvar "osmode" osm)
(end)
); MISSION COMPLETE.
;July 29
; Command ------------ Command ---------------- Command;
(defun break (/ en po)
(setq en (car (entsel)))
(sssetfirst nil (ssadd en))
(setq po (getpoint "Nhap diem break point ..."))
(setvar "CMDECHO" 1)
(command ".break" en po po)
(princ)
)
(defun copyrotate (/ s);copy and rotate
(setvar "cmdecho" 1)
(prompt "\nCopy and rotate objects\n")
(setq s (ssget))
(begin)
(command ".copy" s "" '(0 0) '(0 0))
(command ".rotate" s "")
(while (> (getvar "cmdactive") 0) (command pause))
(end)
);defun
(defun copydupplicate (/ s);copy DUPPLICATE
(setvar "cmdecho" 1)
(prompt "\nDupplicate objects\n")
(setq s (ssget))
;(begin)
(command ".copy" s "" '(0 0) '(0 0))
;(end)
);defun
; Command ------------ Command ---------------- Command;
;------------------------------------------------------
; Array --------------- Array ------------------ Array;
(defun copyArray (/ ss uvec bp d dp op a tp prebp);Copy Array...
(setq ss (ssget))
(begin)
(setq bp (getpoint "\nNhap diem basepoint: ")
op bp
uvec (getpoint bp "\nNhap huong array : ")
d (distance bp uvec)
uvec (v_minus_v uvec bp)
uvec (unitvec uvec)
count 1
)
(initget 128)
(while (/= 0 (setq dp (getdist (strcat "\nCho khoang cach di chuyen
(rtos d)
"><"
(itoa count)
"> "))))
;(prompt (strcat " - \t " (itoa count)))
(if (null dp) (setq tp (v_plus_v bp (v_x_r uvec d)))
(if (numberp dp) (setq d dp tp (v_plus_v bp (v_x_r uvec d)))
;if dp la string
(if (or (= "u" dp)(= "U" dp))
(if (> count 1)
(progn
(command "undo" "b")
(setq count(- count 1))
(setq bp prebp)
(initget 128)
)
)
);if dp = u
);if numberp dp
);if null dp
(if tp
(progn
(setq count (1+ count))
(command ".undo" "M")
(command ".copy" ss "" '(0 0) '(0 0))
(command ".move" ss "" bp tp)
(setq prebp bp
bp tp
tp nil)
(initget 128)
)
)
);while
(end)
);defun
;19/4/2005 - Copyright by HongLinh !!!
(defun RotateArray (/ ss op a ap);Rotate Array...
(setq ss (ssget))
(begin)
(setq op (getpoint "\nNhap diem tam quay: ")
a 90
)
(while (/= 0
(setq ap
(getdist
(strcat "\nCho goc quay
(rtos a) "> "))))
(if ap (setq a ap))
(if a
(progn
(command ".copy" ss "" '(0 0) '(0 0))
(command ".rotate" ss "" op a)
)
)
);while
(end)
(princ)
);defun
;21/4/2005 - Copyright by HongLinh !!!
;Spent too much time to make "technical" lisp
;Those lisp aren't effective. They are just tricky skills
;Chuyen sang to chuc ban ve voi cac font chu va cac style
;Cung voi viec thong ke thep ...
(defun TextArray (/ let nlet ent el ip bp pent nent pel nel)
(begin)
(setq ent (car (cle_entsel (list "TEXT")))
el (entget ent))
(setq let (cdr (assoc 1 el)))
(setq bp (getpoint "\nCho diem base point : ")
ip nil flag T)
(while (and (not (equal ip bp)) bp)
(setq let (nextletter let))
(setq nel (list (assoc 0 el)
(assoc 8 el)
(assoc 67 el)
(assoc 410 el)
(assoc 10 el)
(assoc 40 el)
(cons 1 let)
(assoc 50 el)
(assoc 41 el)
(assoc 51 el)
(assoc 7 el)
(assoc 71 el)
(assoc 72 el)
(assoc 11 el)
(assoc 210 el)
(assoc 73 el)
)
) ;(subst '(1 . nlet) '(1 . let) el)
(entmake nel)
(setq nent (entlast))
(entupd nent)
(if flag
(progn(command ".move" nent "" bp pause)(setq flag nil));(whilecmdactive) ; pause BP pause)
(command ".move" nent "" bp pause)
);if
(setq ip (getvar "lastpoint"))
) ;while
(if bp (entdel nent))
(end)
);defun
;Chuong trinh pedit-join
(defun peditjoin (/ ss flag)
(prompt "Select object for generate PEDIT - Join command.\n")
(setq ss (ssget '((-4 . "
(setq ssle (sslength ss)
i 0
)
(setq obj (ssname ss i)
el (entget obj)
name (cdr (assoc 0 el)))
(while (and (= name "LWPOLYLINE") (< i (1- ssle)))
(setq i (1+ i))
(setq obj (ssname ss i)
el (entget obj)
name (cdr (assoc 0 el)))
);while
(if (= name "LWPOLYLINE") (setq flag 0) (setq flag 1));if
(command ".PEDIT" "M" ss "")
(if (= flag 1) (command "Y"))
(command "j" "" "")
(princ)
);defun
(princ)
C-Pra Print All.LSP
(defun c:pra (/)(printall))
(defun PrintAll (/ ss ent el x1 x2 y1 y2 i ssl j p plist x y
ll ur dx dy ori oldpickbox)
(begin)
(setq oldpickbox (getvar "pickbox"))
(setvar "pickbox" 20)
(setq ss (ssget ":E" '((0 . "LWPOLYLINE") (8 . "Defpoints") (-4 . "
;(setq ss (ssget '((0 . "LWPOLYLINE") (8 . "Defpoints") (62 . 2))))
(if ss
(progn
;-----------------------------
(setq ssl (sslength ss)
i -1)
(repeat ssl (setq i (1+ i))
(setq ent (ssname ss i)
el (entget ent)
)
(setq plist (assoc_all 10 el)
j -1
x nil y nil x1 nil x2 nil y1 nil y2 nil)
(repeat 4 (setq j (1+ j))
(setq p (nth j plist)
x (car p)
y (cadr p))
(if x1 (if (> x1 x) (setq x1 x)) (setq x1 x))
(if x2 (if (< x2 x) (setq x2 x)) (setq x2 x))
(if y1 (if (> y1 y) (setq y1 y)) (setq y1 y))
(if y2 (if (< y2 y) (setq y2 y)) (setq y2 y))
);repeat
(setq dx (- x2 x1)
dy (- y2 y1))
(if (> dx dy) (setq ori "L") (setq ori "P"))
(setq ll (list x1 y1)
ur (list x2 y2)
)
; Plot --------------------------------------------
(command ".plot" "Y")
;Detailed plot configuration? [Yes/No]
(command "" ;Enter a layout name or [?]
"" ;Enter an output device name or [?]
"" ;Enter paper size or [?]
"" ;Enter paper units [Inches/Millimeters]
ori ;Enter drawing orientation [Portrait/Landscape]
"N" ;Plot upside down? [Yes/No]
"W" ;Enter plot area [Display/Extents/Limits/View/Window]
ll ;Enter lower left corner of window <62733.645790,22243.164135>
ur ;Enter upper right corner of window <88917.267283,40756.835898>:
"F" ;Enter plot scale (Plotted Millimeters=Drawing Units) or [Fit]
"C" ;Enter plot offset (x,y) or [Center]
)
(while (/= 0 (getvar "cmdactive"))
(command "")
)
; "" ;Plot with plot styles? [Yes/No]
; "" ;Enter plot style table name or [?] (enter . for none)
; "" ;Plot with lineweights? [Yes/No]
; "" ;Scale lineweights with plot scale? [Yes/No]
; "" ;Plot paper space first? [Yes/No]
; "" ;Hide paperspace objects? [Yes/No]
; "" ;Write the plot to a file [Yes/No]
; "" ;Save changes to page setup [Yes/No]?
; "" ;Proceed with plot [Yes/No]
; ;Effective plotting area: 199.75 wide by 248.60 high
; ;Plotting viewport 1.
; )
; Plot --------------------------------------------
);repeat
);progn ------- if ss
);if
(setvar "pickbox" oldpickbox)
(end)
);defun
(defun assoc_all (code entl / licode el)
(setq licode (list))
(foreach el entl
(if
(= (car el) code)
(setq licode (append licode (list (cdr el))))
);if
);foreach
! licode
)
(defun whilecmdactive ()
(setvar "cmdecho" 1)
(while (> (getvar "cmdactive") 0) (command pause))
(setvar "cmdecho" 0)
);defun
(princ)
C-Reo.LSP
;Date modified Jan 30th 2008
;Date modified Jan 23th 2008
;Date modified Jan 21th 2008
;Date modified Dec 18th 2007
;Date modified Dec 17th 2007
;(prompt "\nNew LispCommand: REO (Reodots Distribution)")
(begin)
; (setq prePDMODE (getvar "PDMODE")
; )
; (setvar "PDMODE" 1);this command would invoke the regen command
(ReoDotsDistribute)
; (setvar "PDMODE" prePDMODE)
(end)
)
(defun ReoDotsDistribute (/ flag pline disotribute_string No Pitch offsetpoint offsetpo1 offsetpo2
offsetid offsetpointlist offsetdistance dimscale dimfactor
el entname offsetpline lastent offsetplineEList
ss_x_pline ss_div_points ss_reodots li n)
;(begin)
;1. Select the lwpolyline
(setq pline (car(cle_entsel '("LINE" "ARC" "LWPOLYLINE"))))
(if (null pline)(exit))
(setq pline (cdr(assoc -1 (entmake (entget pline)))))
(setq el (entget pline)) ;pline sometime is not pline
(setq entname (cdr (assoc 0 el)))
(if (= "LINE" entname)(trimline pline))
(if (= "LWPOLYLINE" entname)(trimpline pline))
;2. If true, then ask for the distribute law
(setq distribute_string (getstring nil "Specify the [Number]F[fi]@[Pitch] of reo dots: "))
(if (= distribute_string "")(exit))
;3. If true, then divide the flow into 2 case + determined 2 offset points
;3.1 determine the No or the Pitch
(setq li (translateDistributestring distribute_string))
(setq No (car li)
fi (cadr li)
pitch (caddr li))
;3.2 determine 2 offset points
;(setvar "cmdecho" 1)
(if (= "LINE" entname)(setq offsetpointlist(getoffsetpointsLine pline)))
(if (= "ARC" entname)(setq offsetpointlist(getoffsetpointsArc pline)))
(if (= "LWPOLYLINE" entname)(setq offsetpointlist (getoffsetpointsPline pline)))
(setq offsetpo1 (car offsetpointlist))
(setq offsetpo2 (cadr offsetpointlist))
(setq dimscale (getvar "DIMSCALE")
dimfactor (getvar "DIMLFAC")
)
(setq offsetdistance (max (/ fi dimfactor 2)(* dimscale 0.6)))
(prompt "Use Tab key to change the position of the Reo Dots up and down: ")
;the while loop, begin with the first offset point:
(setq offsetID 1)
(while (null flag)
;refresh all the variable
(if (= offsetID 0)(setq offsetID 1 offsetpoint offsetpo1)(setq offsetID 0 offsetpoint offsetpo2))
(if ss_reodots (command ".erase" ss_reodots ""))
(setq ss_reodots (ssadd))
;...
;4. Offset the lwpolyline, then, xplode it to the ss_x_pline
(setq lastent (entlast))
(sssetfirst)
(command ".offset")
(command offsetdistance)
(command pline)
(command offsetpoint)
(command "")
(setq offsetpline (entlast))
(if (equal offsetpline lastent)
(prompt "Can not offset the selected object. ReoDotDistributor Fail")
(progn
(setq offsetplineElist (entget offsetpline))
(if (= "LWPOLYLINE" (cdr (assoc 0 (entget offsetpline))))
(command ".explode" offsetpline)
);if = Lwpolyline ...
(if (getvar "CMDACTIVE")(command ^C^C))
(setq ss_x_pline (ss_ob lastent))
;5. Draw the reo dots
;5.1 Draw the reo dots at each vertices of the pline
(setq ss_reodots (DrawReoDotsOnPlineVertexs offsetplineEList fi))
;5.2 Draw the reo dots on each segment
(if (> No 0) (setq ss (DrawReoDot_with_No (- No (sslength ss_reodots)) ss_x_pline fi))
(setq ss (DrawReoDot_with_Pitch pitch ss_x_pline fi))
);.......................................................
(setq ss_reodots (ssjoin ss_reodots ss))
(command ".erase" ss_x_pline "")
);progn if offset successfully done
)
;Readkey
(setq key (grread))
(if (/= 9 (cadr key))(setq flag T))
);while null flag
;highlight the reo_dots selection set ss_reodots
(setq n (sslength ss_reodots))
(prompt (strcat "\nThe true Number of ReoDots = " (itoa n)))
(if (> n 0)
(progn
(sssetfirst ss_reodots ss_reodots)
(prompt ". The ReoDots moved to the Previous SelectionSet")
)
);if .......
; + delete the temporary point and entities already done in the subprocedure
;(end)
;(princ)
(entdel pline)
)
(defun translateDistributestring (distributestring / No fi pitch
prefix str strl i letteri flag)
;split the distributestring with f and @ as delimiter
(setq prefix ""
str ""
strl (strlen distributestring)
i 1
No 0 pitch 0 fi 10 ;default value of fi = 10
)
(while (< i (+ 2 strl))
(if (= i (1+ strl))(setq flag T)
(setq letteri (substr distributestring i 1)
letteri (strcase letteri))
)
(if (= letteri "F")(setq flag T))
(if (= letteri "@")(setq flag T))
(if (= letteri "A")(setq flag T))
(if (and flag (/= "" str))
(progn
(if (= prefix "")(setq No (atoi str)))
(if (= prefix "f")(setq fi (atoi str)))
(if (= prefix "@")(setq pitch (atoi str)))
)
;else flag = nil
(setq str (strcat str letteri))
)
(if flag (setq str ""))
(setq flag nil);reset flag
(if (= letteri "F")(setq prefix "f"))
(if (= letteri "@")(setq prefix "@"))
(if (= letteri "A")(setq prefix "@"))
(setq i (1+ i))
);while
! (list No fi pitch)
);defun
(defun GetoffsetpointsLine (line / offsetpo1 offsetpo2 vertex1 vertex2)
(setq el (entget line))
(setq vertex1 (cdr(assoc 10 el))
vertex2 (cdr(assoc 11 el))
)
(getoffsetpoints vertex1 vertex2)
);defun
(defun GetoffsetpointsArc (arc / offsetpo1 offsetpo2 vertex1 vertex2 startangle endangle centerpo radius
midpoint midangle v)
(setq el (entget arc))
(setq startAngle (cdr(assoc 50 el))
endAngle (cdr(assoc 51 el))
radius (cdr(assoc 40 el))
centerpo (cdr(assoc 10 el))
)
(setq x (* radius (cos startangle))
y (* radius (sin startangle))
vertex1 (v_plus_v centerpo (list x y 0))
)
(setq x (* radius (cos endangle))
y (* radius (sin endangle))
vertex2 (v_plus_v centerpo (list x y 0))
)
(setq v (v_x_r (v_minus_v vertex2 vertex1) 0.5))
(setq midangle (/ (+ endangle startangle) 2))
(if (> startangle endangle) (setq midangle (+ midangle pi)))
(setq x (* radius (cos midangle))
y (* radius (sin midangle))
midpoint (v_plus_v centerpo (list x y 0))
)
(setq vertex1 (v_plus_v midpoint v))
(setq vertex2 (v_minus_v midpoint v))
;(command ".line" vertex1 vertex2 "")
(getoffsetpoints vertex1 vertex2)
);defun
(defun GetoffsetpointsPline (pline / ent el lastent entname offsetpointlist ss)
(setq el (entget pline))
(setq lastent (entlast))
(entmake el)
(command ".explode" (entlast))
(setq ent (entlast) el (entget ent))
(setq entname (cdr (assoc 0 el)))
(if (= "LINE" entname)(setq offsetpointlist(getoffsetpointsLine ent))
(setq offsetpointlist(getoffsetpointsArc ent))
);if
(setq ss (ss_ob lastent))
(command ".erase" ss "")
! offsetpointlist
);defun
(defun getoffsetpoints (vertex1 vertex2 / offsetpo1 offsetpo2 midpo v12 dimscale)
(setq dimscale (getvar "DIMSCALE"))
(setq midpo (v_x_r (v_plus_v vertex1 vertex2) 0.5))
(setq v12 (v_minus_v vertex2 vertex1))
(setq offsetpo1 (v_x_v v12 (list 0 0 1))
offsetpo1 (v_x_r (unitvec offsetpo1) (* 2 dimscale))
offsetpo1 (v_plus_v offsetpo1 midpo)
)
(setq offsetpo2 (v_x_v v12 (list 0 0 -1))
offsetpo2 (v_x_r (unitvec offsetpo2) (* 2 dimscale))
offsetpo2 (v_plus_v offsetpo2 midpo)
)
;(command ".line" offsetpo1 offsetpo2 "")
! (list offsetpo1 offsetpo2)
);defun getoffsetpoints
(defun v_x_v (v1 v2 / n v i j k x1 x2 y1 y2 itemi);tich co huong cua hai vector
(setq n (min (length v1)(length v2))
i 0
v (list))
(while (< i n)
(setq j (1+ i))
(if (= j n)(setq j 0))
(setq k (1+ j))
(if (= k n)(setq k 0))
(setq x1 (nth j v1)
y1 (nth k v1)
x2 (nth j v2)
y2 (nth k v2)
itemi (- (* x1 y2)(* x2 y1))
)
(setq v (append v (list itemi)))
(setq i (1+ i))
);while i < n
! v
);defun
(defun DrawReoDotsOnPlineVertexs (plineEl fi / previousPoint currentPoint pointlist
n i pointlist d reodot ss entname
x y radius startangle endangle centerpo vertex1 vertex2)
(setq entname (cdr(assoc 0 plineEl)))
(if (= entname "LWPOLYLINE")(setq vertexlist (assoc_all 10 plineEl)))
(if (= entname "LINE")(setq vertexlist (list(cdr(assoc 10 plineEl)))
vertexlist (append vertexlist (list (cdr(assoc 11 plineel))))
)
);if
(if (= entname "ARC")
(progn
(setq startAngle (cdr(assoc 50 plineel))
endAngle (cdr(assoc 51 plineel))
radius (cdr(assoc 40 plineel))
centerpo (cdr(assoc 10 plineel))
)
(setq x (* radius (cos startangle))
y (* radius (sin startangle))
vertex1 (v_plus_v centerpo (list x y))
)
(setq x (* radius (cos endangle))
y (* radius (sin endangle))
vertex2 (v_plus_v centerpo (list x y))
)
(setq vertexlist (list vertex1 vertex2))
);progn
);if
(setq n (length vertexlist)
i 0
pointlist (list)
)
(while (< i n)
(setq currentPoint (nth i vertexlist))
(if previousPoint
(progn
(setq d (distance currentpoint previouspoint))
(if (< d (* fi 2 (/ 1 (getvar "DimlFac"))
)
)
(progn
(setq currentpoint (v_plus_v currentpoint previouspoint)
currentpoint (v_x_r currentpoint 0.5)
);setq
)
;else: previouspoint is validated
(setq pointlist (append pointlist (list previouspoint)))
);if d < 5fi
)
);if previouspoint
(setq previouspoint currentpoint)
(setq i (1+ i))
);while
(setq pointlist (append pointlist (list previouspoint)))
(setq n (length pointlist)
i 0
ss (ssadd))
(while (< i n)
(setq currentpoint (nth i pointlist))
(setq reodot (drawReoDot currentpoint fi))
(setq ss (ssadd reodot ss))
(setq i (1+ i))
);while
! ss
);defun
(defun drawReoDot (point fi / dimscale dimfactor reodot plineel
asseenfi v1 v2)
(setq dimscale (getvar "DIMSCALE")
dimfactor (getvar "DIMLFAC")
)
(setq fi (* 1 dimscale))
;(setq fi (/ fi dimfactor));>> fi as seen in the dimension = fi
;(setq asseenfi (/ fi dimscale))
;(if (< asseenfi 0.8)(setq fi (* 0.8 dimscale)));min fi = 1.6 * dimscale
(setq r (* fi 0.25)
v1 (v_plus_v point (list 0 r))
v2 (v_plus_v point (list 0 (* -1 r)))
)
;create the pline
(setq plineEl (list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
;(cons 67 0);indicate entity is in model space or paper space
;(cons 410 "Model")
(cons 8 "RT") ;the layer (interestingly, new layer will be create
;if layername ain't match with any existed layer
(cons 100 "AcDbPolyline")
(cons 90 2);number of vertices
(cons 70 1) ; the closed flag
(cons 43 fi) ; the constant width
(cons 38 0)
(cons 39 0)
(cons 62 256)
(cons 10 v1) ; the first vertex
(cons 40 fi)
(cons 41 fi)
(cons 42 1) ; the first bulge
(cons 10 v2) ;the second vertex
(cons 40 fi)
(cons 41 fi)
(cons 42 1) ;the second bulge
(list 210 0. 0. 1.)
)
);setq
(entmake plineEl)
(setq reodot (entlast))
;error will raise if the entmake fails
);defun
(defun DrawReoDot_with_No (No ss_x_pline fi / dimscale dimfactor i n lengthList nlist
l sumlength lastent ni ss_div_points point ss_reodots reodot
ent el)
(setq ss_reodots (ssadd))
(if (> No 0)
(progn
(setq dimscale (getvar "DIMSCALE")
dimfactor (getvar "DIMLFAC")
)
;Thursday 12 December 2007
(setq lastent (entlast))
(setq n (sslength ss_x_pline))
(setq i 0 sumlength 0 lengthlist (list) nlist (list))
(while (< i n)
(setq ent (ssname ss_x_pline i))
(setq l 0)
(setq entname (cdr(assoc 0 (entget ent))))
(if (= entname "LINE")(setq l (linelength ent))
(if (= entname "ARC")(setq l (arclength ent))
)
)
;sometime, undesired object would happen after explode pline
;>> some time ss_x_pline contain not only line arc
(setq lengthlist (append lengthlist (list l)))
(setq sumlength (+ sumlength l))
(setq i (1+ i))
);while
(setq i 0)
(while (< i n)
(setq ent (ssname ss_x_pline i))
(setq l (nth i lengthlist))
(setq ni (* (/ l sumlength) (+ n No)))
(setq ni (round ni))
(setq nlist (append nlist (list ni)))
;...
(if (> ni 1) (command ".divide" ent ni))
(setq i (1+ i))
);while
(setq ss_div_point (ss_ob lastent))
(setq n (sslength ss_div_point))
(setq i 0)
(while (< i n)
(setq ent (ssname ss_div_point i))
(setq el (entget ent)
point (cdr(assoc 10 el))
)
(setq reodot (drawReoDot point fi))
(setq ss_reodots (ssadd reodot ss_reodots))
(entdel ent)
(setq i (1+ i))
);while
);progn
);if No > 0
! ss_reodots
);defun
(defun arclength (arc / el startangle endangle radius l a)
(setq el (entget arc))
(setq startAngle (cdr(assoc 50 el))
endAngle (cdr(assoc 51 el))
radius (cdr(assoc 40 el))
)
(setq a (- endangle startangle))
(if (> startangle endangle)(setq a (+ (* 2 pi) a)))
(setq l (abs(* radius a)))
! l
);defun
(defun linelength (line / sp ep l el)
(setq el (entget line)
sp (cdr (assoc 10 el))
ep (cdr (assoc 11 el))
)
(setq l (distance sp ep))
);defun
(defun DrawReoDot_with_Pitch (Pitch ss_x_pline fi / dimscale dimfactor
lastent ss_reodots ent el entname n i endpoint1 endpoint2 lastpoint xent
x y radius startangle endangle centerpo d1 d2 d)
(setq dimscale (getvar "DIMSCALE")
dimfactor (getvar "DIMLFAC")
)
(setq ss_reodots (ssadd))
;Thursday 12 December 2007
(if (> pitch 0)
(progn
(setq lastent (entlast))
(setq n (sslength ss_x_pline))
(setq i 0)
(while (< i n)
(setq ent (ssname ss_x_pline i)
el (entget ent)
entname (cdr(assoc 0 el))
)
(if (or(= entname "LINE")(= entname "ARC"));for some reason, complicated polyline
;would off set to some unexpected thing
(PROGN
;-----------------------------------------------------------------------------
(setq pitch (/ pitch dimfactor))
(setq xent (entlast))
(command ".measure" ent pitch)
(setq lastpoint (entlast))
(if (not (equal xent lastpoint));measure success
;if not >> mean object isnot that long
(progn
;compare lastpoint and the endpoint of the ent
(if (= entname "LINE")(setq endpoint1(cdr(assoc 10 el))endpoint2(cdr(assoc 11 el)))
;else
(progn
(setq startAngle (cdr(assoc 50 el))
endAngle (cdr(assoc 51 el))
radius (cdr(assoc 40 el))
centerpo (cdr(assoc 10 el))
)
(setq x (* radius (cos startangle))
y (* radius (sin startangle))
endpoint1 (v_plus_v centerpo (list x y))
)
(setq x (* radius (cos endangle))
y (* radius (sin endangle))
endpoint2 (v_plus_v centerpo (list x y))
)
);else
); if ... detemine the endpoint of the line or arc
(setq d1 (distance endpoint1 (cdr(assoc 10 (entget lastpoint)))))
(setq d2 (distance endpoint2 (cdr(assoc 10 (entget lastpoint)))))
(setq d (min d1 d2))
;then, if d is small enough, then, delete lastpoint because lastpoint is
;too near the endpoint which is usually have a reodot on it
(if (< d (* 0.4 pitch))(entdel lastpoint))
);progn
);if
);PROGN
);IF ENTNAME = LINE OR ARC
(setq i (1+ i))
);while
(setq ss_reodots (ss_ob lastent))
(setq n (sslength ss_reodots) i 0)
(while (< i n)
(setq ent (ssname ss_reodots i)
el (entget ent)
point (cdr(assoc 10 el))
)
(drawReoDot point fi)
(entdel ent)
(setq i (1+ i))
);while
(setq ss_reodots (ss_ob lastent))
);progn if pith > 0
);if pitch > 0
! ss_reodots
);defun
(defun trimline (line / lineEl sp ep u)
(setq lineEl (entget line))
(setq sp (cdr (assoc 10 lineEl)))
(setq ep (cdr (assoc 11 lineEl)))
(setq u (unitvec (v_minus_v ep sp))
u (v_x_r u 30)
sp (v_plus_v sp u)
ep (v_minus_v ep u)
)
(setq lineEl (subst (cons 10 sp)(assoc 10 lineEl) lineEl))
(setq lineEl (subst (cons 11 ep)(assoc 11 lineEl) lineEl))
(entmod lineEl)
(entupd line)
);defun
(defun trimPline (pline / closeflag plineEl vertices bulist sp ep bu u)
(setq plineEl (entget pline))
(setq closeflag (cdr (assoc 70 plineEl)))
(if (/= closeflag 1)
(progn
(setq vertices (assoc_all 10 plineEl))
(setq bulist (assoc_all 42 plineEl))
;1st The startpoint
(setq sp (car vertices))
(setq ep (cadr vertices))
(setq bu (car bulist))
(if (= bu 0)
(progn
(setq u (unitvec (v_minus_v ep sp))
u (v_x_r u 30)
sp (v_plus_v sp u)
)
)
(progn
)
);if bu = 0
(setq plineEl (subst (cons 10 sp)(assoc 10 plineEl) plineEl))
(setq plineEl (reverse plineEl)
vertices (reverse vertices)
bulist (reverse bulist)
)
(setq sp (car vertices))
(setq ep (cadr vertices))
(setq bu (car bulist))
(if (= bu 0)
(progn
(setq u (unitvec (v_minus_v ep sp))
u (v_x_r u 30)
sp (v_plus_v sp u)
)
)
(progn
)
);if bu = 0
(setq plineEl (subst (cons 10 sp)(assoc 10 plineEl) plineEl))
(setq plineEl (reverse plineEl))
(entmod plineEl)
(entupd pline)
; .....
);progn
);if closeflag
);defun
(princ)
C-Tra Tf.lsp
(defun c:tra (/)(trimall))
(defun c:tf (/)(trimfence))
;Trim fence
(defun trimfence (/ f_off pl)
(begin)
(Prompt "Draw a polyline to trim ...")
(command ".pline")
(whilecmdactive)
(setq f_off (getreal "Nhap gia tri fence offset (Default = 0.1) ... "))
(if (null f_off) (setq f_off 0.1))
(setq pl (entlast))
(pltrim_all pl)
(entdel pl)
(end)
(princ)
)
(defun trimAll (/ ss ssle ss_ssiname ssil ssi ss_elist pl f_off i el elas elasel osm key)
(begin)
;Chon mot tap hop cac polyline
(Prompt "Select a set of Polyline")
(setq ss (ssget '((0 . "LWPOLYLINE"))))
(setq osm (getvar "Osmode"))
(setvar "Osmode" 0)
(setq elas (entlast))
;Tao mot tap cac elist cua moi polyline trong ss
(setq ssle (sslength ss)
i -1
ss_elist (list))
(repeat ssle (setq i (1+ i))
(setq ssi (ssname ss i)
ssil (entget ssi)
ssiname (car (assoc 0 ssil))
)
(setq ss_elist (append ss_elist (list ssil)))
);repeat
(setq tm (getvar "tilemode") cv (getvar "cvport"))
(if (or (and (= tm 0) (/= cv 1)) (= tm 1));Dang o trong khong gian mo hinh
(setq default_f_off 0.1)
(setq default_f_off 0.01))
(setq key "In"
f_off "In")
(while (not (or (null f_off) (numberp f_off)))
(Initget "In Out")
(setq f_off (getreal
(strcat "\nNhap gia tri fence offset <"
(rtos default_f_off)
" " key "> ... ")))
(if (or (= f_off "In") (= f_off "Out")) (setq key f_off))
(if (null f_off) (setq f_off default_f_off))
)
;Voi moi elist thuoc ss_elist, tao pl moi, dung lenh trim all cat toan bo nhung gi nam trong
(foreach el ss_elist
(entmake el)
(setq pl (entlast))
(entupd pl)
(pltrim_all pl)
(command ".erase" pl "")
);foreach
(setq elas (entnext elas))
(while elas
(setq elasel (entget elas))
(if (= (cdr (assoc 0 elasel)) "LWPOLYLINE")
(setq ss (ssadd elas ss))
);if
(setq elas (entnext elas)))
(command ".Pedit" "m" ss "" "j" 0 "")
(setvar "Osmode" osm)
(end)
)
; TRIM TOOLS ; TRIM TOOLS ; TRIM TOOLS ; TRIM TOOLS ; TRIM TOOLS
;---------------------------------------------------------------
; TRIM TOOLS
;+++++++++++++++++++++++++++++++++++++++++
(defun pltrim_all (pl1 / pl2 po elpl1 elpl2
po_l1 po_l2 po1 po2 in out i
closeflag ofsdi)
;++++++++++++++++++++++++++++++
(command ".UCS" "W")
(setq elpl1 (entget pl1))
(setq po_l1 (assoc_all 10 elpl1))
(setq in (inside_po pl1 0.1)
out (cadr in)
in (car in)
)
(setq closeflag (cdr (assoc 70 elpl1)))
(if (= 1 closefla1)
(setq po_l1 (app po_l1 (car po_l1)))
)
(setvar "cmdecho" 0)
(if (= key "Out") (setq po out) (setq po in))
(setvar "cmdecho" 1)
(setq ofsdi (getvar "Offsetdist"))
(command ".offset" f_off pl1)
(command po "")
(setq pl2 (entlast))
(setq elpl2 (entget pl2))
(setq po_l2 (assoc_all 10 elpl2))
(setq closeflag (cdr (assoc 70 elpl2)))
(if (= 1 closeflag)
(setq po_l2 (app po_l2 (car po_l2)))
)
(command ".trim" pl1 "")
(setq i 0)
(repeat (1- (length po_l2))
(setq
po1 (nth i po_l2)
i (1+ i)
po2 (nth i po_l2)
)
(print po1)
(print po2)
(command "f" po1 po2 "")
) ;repeat
(command "") ;end trim
;(progn (command ".erase" "wp")(foreach po po_l1 (command po))(command "" ""));end erase
(command ".erase" pl2 "")
(setvar "Offsetdist" ofsdi)
(command ".UCS" "P")
;++++++++++++++++++++++++++++++++++++++++++++++
);defun pltrim_all
(princ)
Fix AutoCAD Drawing.LSP
(command
"-scalelistedit"
"reset"
"y"
^C^C)
(vl-vbarun "FlattenAll")
)
(defun c:FixBoldText (/ ss n tx txel c10 c11 typename z10 z11)
;(begin)
;Attribute are also applicable
(setq tx (entnext) flag T)
(while (= t flag )
(setq txel (entget tx)
typename (cdr(assoc 0 txel))
);setq
(if (or (= typename "TEXT")(= typename "LINE")(= typename "MTEXT")(= typename "ATTDEF")(= typename "ATTRIB")(= typename "INSERT")(= typename "BLOCK"))
(progn
(setq c10 (assoc 10 txel)
c11 (assoc 11 txel)
z10 (cadddr c10)
z11 (cadddr c11)
)
(if (null z11)(setq z11 0))
(if (< (abs z11 ) 0.0001) (setq z11 0))
(if (< (abs z10 ) 0.0001) (setq z10 0))
(setq newc10 (list (car c10) (cadr c10)(caddr c10) z10))
(setq newc11 (list (car c11) (cadr c11)(caddr c11) z11))
(setq txel (subst newc10 c10 txel))
(setq txel (subst newc11 c11 txel))
(entmod txel)
);progn
);if typename = "TEXT", "MTEXT" ...
(setq tx (entnext tx))
(if (null tx) (setq flag 0))
);repeat
;(end)
); defun
(princ)