TỔNG HỢP LISP CAD: LISP CẮT DIM, CHỈNH DIM, CĂN CHỈNH TEXT, CHUYỂN ĐỔI TEXT, THAY ĐỔI MÀU SẮC ĐỐI TƯỢNG, NHÂN VỚI 1 SỐ, CỘNG VỚI 1 SỐ, THÊM TIẾP NGỮ ĐẦU CUỐI ( Mr Hiển 0971653821)
(prompt" ***************************************************\n")
(prompt" ** **\n")
(prompt" ** CHUONG TRINH TONG HOP AUTOLISP **\n")
(prompt" ** TONG CONG TY DUONG SAT VIET NAM **\n")
(prompt" ** CONG TY CP TVDT&XDGTVT **\n")
(prompt" ** DC: PHONG CAU 2 - DT:04.7717920 **\n")
(defun RAD (degree)
(setq radian (/ (* degree 3.141592654) 180))
radian
)
(defun DEG (Rad)
(setq degree (/ (* rad 180) 3.141592654))
degree
)
(defun tangent (Rad)
(setq tang (/ (sin rad) (cos rad)))
tang
)
(defun DXF (code elist)
(cdr (assoc code elist))
)
;--------------------------------------Tao under Line--------------------------------------------------------
(defun c:UU( / sset ssl temp ed old new )
(text_uu_ssget)
(setq ssl (sslength sset))
(while (> ssl 0)
(progn
(setq temp (ssname sset (setq ssl (1- ssl))))
(setq ed (entget temp))
(setq old (cons 1 (DXF 1 ed))
new (cons 1 (strcat "%%u" (DXF 1 ed)))
ed (subst new old ed)
)
(entmod ed)
)
(princ)
)
);defun UU
(defun text_uu_ssget ( / ssl nsset temp ed )
(setq sset (ssget))
(setq ssl (sslength sset)
nsset (ssadd)
)
(print ssl)
(while (> ssl 0)
(progn
(setq temp (ssname sset (setq ssl (1- ssl))))
(setq ed (entget temp))
(if (= (DXF 0 ed) "TEXT") (ssadd temp nsset))
)
)
(setq ssl (sslength nsset)
sset nsset
)
(print ssl)
(princ)
(print)
);defun u_ssget
;--------------------------------------Bo under Line--------------------------------------------------------
(defun c:NU( / sset ssl temp ed old new )
(text_uu_ssget)
(setq ssl (sslength sset))
(while (> ssl 0)
(progn
(setq temp (ssname sset (setq ssl (1- ssl))))
(setq ed (entget temp))
(setq old (cons 1 (DXF 1 ed))
new (cons 1 (substr (DXF 1 ed) 4))
ed (subst new old ed)
)
(entmod ed)
)
(princ)
)
);defun UU
(defun text_uu_ssget ( / ssl nsset temp ed )
(setq sset (ssget))
(setq ssl (sslength sset)
nsset (ssadd)
)
(print ssl)
(while (> ssl 0)
(progn
(setq temp (ssname sset (setq ssl (1- ssl))))
(setq ed (entget temp))
(if (= (DXF 0 ed) "TEXT") (ssadd temp nsset))
)
)
(setq ssl (sslength nsset)
sset nsset
)
(print ssl)
(princ)
(print)
);defun u_ssget
;--------------------------------------Them tiep dau ngu-----------------------------------------------------
(defun c:TD( / sset ssl temp ed old new )
(text_uu_ssget)
(setq tdd (getstring "Nhap tiep dau can dieu chinh:"))
(setq ssl (sslength sset))
(while (> ssl 0)
(progn
(setq temp (ssname sset (setq ssl (1- ssl))))
(setq ed (entget temp))
(setq old (cons 1 (DXF 1 ed))
new (cons 1 (strcat tdd (DXF 1 ed)))
ed (subst new old ed)
)
(entmod ed)
)
(princ)
)
);defun TD
;--------------------------------------Them tiep cuoi ngu-----------------------------------------------------
(defun c:TC( / sset ssl temp ed old new )
(text_uu_ssget)
(setq tcd (getstring "Nhap tiep cuoi can dieu chinh:"))
(setq ssl (sslength sset))
(while (> ssl 0)
(progn
(setq temp (ssname sset (setq ssl (1- ssl))))
(setq ed (entget temp))
(setq old (cons 1 (DXF 1 ed))
new (cons 1 (strcat (DXF 1 ed) tcd))
ed (subst new old ed)
)
(entmod ed)
)
(princ)
)
);defun TC
;--------------------------------------Tao goc nghieng cho text-------------------------------------------------
(defun c:TN( / sset ssl temp ed old new )
(text_uu_ssget)
(setq ssl (sslength sset))
(if (> ssl 0)
(setq ob_angle (getreal "Cho goc nghieng moi cua text : "))
)
(while (> ssl 0)
(progn
(setq temp (ssname sset (setq ssl (1- ssl))))
(setq ed (entget temp))
(setq old (cons 51 (DXF 51 ed))
new (cons 51 (tangent (rad ob_angle)))
ed (subst new old ed)
)
(entmod ed)
)
)
(princ)
);defun TN
;--------------------------------------Doi chu hoa sang chu thuong va nguoc lai----------------------------------
(defun c:CA( / sset ssl temp ed old new )
(text_uu_ssget)
(initget 1 "U u L l")
(setq ssl (sslength sset))
(if (> ssl 0)
(setq sw (getkword "Loai chu can dieu chinh [U/L] : ")))
(while (> ssl 0)
( if (or (= sw "U") (= sw "u"))
(progn
(setq temp (ssname sset (setq ssl (1- ssl))))
(setq ed (entget temp))
(setq old (cons 1 (DXF 1 ed))
new (cons 1 (strcase (DXF 1 ed)))
ed (subst new old ed)
)
(entmod ed)
)
);if
( if (or (= sw "l") (= sw "L"))
(progn
(setq temp (ssname sset (setq ssl (1- ssl))))
(setq ed (entget temp))
(setq old (cons 1 (DXF 1 ed))
new (cons 1 (strcase (DXF 1 ed) T))
ed (subst new old ed)
)
(entmod ed)
)
);if
);while
(princ)
);defun CA
;--------------------------------------Can chinh chu theo phuong ngang----------------------------------
(defun c:VA( / sset ssl temp ed old new )
(setq sset (ssget))
(setq ssl (sslength sset)
nsset (ssadd)
)
(print ssl)
(princ "entities found. ")
(print)
;(text_u_ssget)
(setq ssl (sslength sset))
(if (> ssl 0)
(setq pt1 (getpoint "New aligned point of the selected entities : ")))
(while (> ssl 0)
(progn
(setq temp (ssname sset (setq ssl (1- ssl))))
(setq ed (entget temp))
;;;TEXT
(if (= (DXF 0 ed) "TEXT")
(progn
(setq old (nth (xdtt 10 ed) ed)
new (list (nth 0 old) (nth 1 old) (cadr pt1) (nth 3 old))
ed (subst new old ed)
)
(entmod ed)
)
)
;;;BLOCK
(if (= (DXF 0 ed) "INSERT")
(progn
(setq old (nth (XDTT 10 ED) ed))
(setq new (list (nth 0 old) (nth 1 old) (cadr pt1) (nth 3 old)))
(setq y1 (nth 2 old))
(setq ed (subst new old ed))
(entmod ed)
(setq en (entnext (DXF -1 ed)))
(while (/= (DXF 0 (entget en)) "SEQEND")
(progn
(setq ed (entget en))
(setq old (nth (XDTT 10 ED) ed))
(setq y2 (nth 2 old))
(setq dy (- y2 y1))
(setq new (list (nth 0 old) (nth 1 old) (+ (cadr pt1) dy) (nth 3 old)))
(setq ed (subst new old ed))
(entmod ed)
(setq en (entnext en))
);progn
);while
(entupd en)
);progn
);if BLOCK
)
)
(setq pt1 nil)
(princ)
);defun
;--------------------------------------Can chinh chu theo phuong dung-----------------------------------
(defun c:HA( / sset ssl temp ed old new )
(setq sset (ssget))
(setq ssl (sslength sset)
nsset (ssadd)
)
(print ssl)
(princ "entities found. ")
(print)
;(text_u_ssget)
(setq ssl (sslength sset))
(if (> ssl 0)
(setq pt1 (getpoint "New aligned point of the selected entities : ")))
(while (> ssl 0)
(progn
(setq temp (ssname sset (setq ssl (1- ssl))))
(setq ed (entget temp))
;;;TEXT
(if (= (DXF 0 ed) "TEXT")
(progn
(setq old (nth (xdtt 10 ed) ed)
new (list (nth 0 old) (car pt1) (nth 2 old) (nth 3 old))
ed (subst new old ed)
)
(entmod ed)
)
)
;;;BLOCK
(if (= (DXF 0 ed) "INSERT")
(progn
(setq old (nth (XDTT 10 ED) ed))
(setq new (list (nth 0 old) (nth 1 old) (cadr pt1) (nth 3 old)))
(setq y1 (nth 2 old))
(setq ed (subst new old ed))
(entmod ed)
(setq en (entnext (DXF -1 ed)))
(while (/= (DXF 0 (entget en)) "SEQEND")
(progn
(setq ed (entget en))
(setq old (nth (XDTT 10 ED) ed))
(setq y2 (nth 2 old))
(setq dy (- y2 y1))
(setq new (list (nth 0 old) (+ (car pt1) dy) (nth 2 old) (nth 3 old)))
(setq ed (subst new old ed))
(entmod ed)
(setq en (entnext en))
);progn
);while
(entupd en)
);progn
);if BLOCK
)
)
(setq pt1 nil)
(princ)
);defun
;----------------------------------------------------------------------------------------------------------
(defun CDXF (tt elist)
(car (nth tt elist))
)
;CDXF - xac dinh thu tu cua tieu danh sach
(defun xdtt (code elist)
(setq i 0)
(while (/= code (cdxf i elist))
;(progn
(setq i (+ 1 i))
);while
)
;-----------------------------------------------------------------------------------------------------------
(defun block_u_ssget ( / ssl nsset temp ed )
(setq sset (ssget))
(setq ssl (sslength sset)
nsset (ssadd)
)
(print ssl)
(while (> ssl 0)
(progn
(setq temp (ssname sset (setq ssl (1- ssl))))
(setq ed (entget temp))
(if (= (DXF 0 ed) "INSERT") (ssadd temp nsset))
)
)
(setq ssl (sslength nsset)
sset nsset
)
(print ssl)
(princ)
(print)
);defun block_u_ssget
;-------------------------------------------Thay doi ty le chen cua block-----------------------------------
(defun c:BC( / sset ssl temp ed old new )
(block_u_ssget)
(setq ssl (sslength sset))
(if(> ssl 0) (setq sca (getreal "\nCho ty le chen moi : ")))
(while (> ssl 0)
(progn
(setq temp (ssname sset (setq ssl (1- ssl))))
(setq ed (entget temp))
(progn
(setq old (cons 41 (DXF 41 ed))
new (cons 41 (* sca (DXF 41 ed)))
ed (subst new old ed)
)
(setq old (cons 42 (DXF 42 ed))
new (cons 42 (* sca (DXF 42 ed)))
ed (subst new old ed)
)
(setq x1 (nth 0 (DXF 10 ed)))
(setq y1 (nth 1 (DXF 10 ed)))
)
(entmod ed)
(setq en (entnext (DXF -1 ed)))
(while (/= (DXF 0 (entget en)) "SEQEND")
(progn
(setq ed (entget en))
(setq old (cons 40 (DXF 40 ed))
new (cons 40 (* sca (DXF 40 ed)))
)
(setq ed (subst new old ed))
(setq x2 (nth 0 (DXF 11 ed)))
(setq dx (- x2 x1))
(setq y2 (nth 1 (DXF 11 ed)))
(setq dy (- y2 y1))
(setq old (nth (XDTT 11 ED) ed))
(setq new (list (nth 0 old) (+ x1 (* sca dx)) (+ y1 (* sca dy)) (nth 3 old)))
(setq ed (subst new old ed))
(entmod ed)
(setq en (entnext en))
);progn
);while
(entupd en)
);progn
);while
(princ)
);defun BC
(princ)
;-------------------------------------------Cat duong kich thuoc-------------------
(DEFUN C:Cd (/ CMD SS LTH DEM PT DS KDL N70 GOCX GOCY PT13 PT14 PTI PT13I PT14I
PT13N PT14N O13 O14 N13 N14 OSM OLDERR PT10 PT11)
(SETQ CMD (GETVAR "CMDECHO"))
(SETQ OSM (GETVAR "OSMODE"))
(SETQ OLDERR *error*
*error* myerror)
(PRINC "Please select dimension object!")
(SETQ SS (SSGET))
(SETVAR "CMDECHO" 0)
(SETQ PT (GETPOINT "Point to trim or extend:"))
(SETQ PT (TRANS PT 1 0))
(COMMAND "UCS" "W")
(SETQ LTH (SSLENGTH SS))
(SETQ DEM 0)
(WHILE (< DEM LTH)
(PROGN
(SETQ DS (ENTGET (SSNAME SS DEM)))
(SETQ KDL (CDR (ASSOC 0 DS)))
(IF (= "DIMENSION" KDL)
(PROGN
(SETQ PT10 (CDR (ASSOC 10 DS)))
(SETQ PT11 (CDR (ASSOC 11 DS)))
(SETQ PT13 (CDR (ASSOC 13 DS)))
(SETQ PT14 (CDR (ASSOC 14 DS)))
(SETQ N70 (CDR (ASSOC 70 DS)))
(IF (OR (= N70 32) (= N70 33) (= N70 160) (= N70 161))
(PROGN
(SETQ GOCY (ANGLE PT10 PT14))
(SETQ GOCX (+ GOCY (/ PI 2)))
)
)
(SETVAR "OSMODE" 0)
(SETQ PTI (POLAR PT GOCX 2))
(SETQ PT13I (POLAR PT13 GOCY 2))
(SETQ PT14I (POLAR PT14 GOCY 2))
(SETQ PT13N (INTERS PT PTI PT13 PT13I NIL))
(SETQ PT14N (INTERS PT PTI PT14 PT14I NIL))
(SETQ O13 (ASSOC 13 DS))
(SETQ O14 (ASSOC 14 DS))
(SETQ N13 (CONS 13 PT13N))
(SETQ N14 (CONS 14 PT14N))
(SETQ DS (SUBST N13 O13 DS))
(SETQ DS (SUBST N14 O14 DS))
(ENTMOD DS)
)
)
(SETQ DEM (+ DEM 1))
)
)
(COMMAND "UCS" "P")
(SETVAR "CMDECHO" CMD)
(SETVAR "OSMODE" OSM)
(setq *error* OLDERR) ; Restore old *error* handler
(PRINC)
)
;--------------------------------------dieu chinh dim------------------------------------
(DEFUN C:BD (/ CMD SS LTH DEM PT DS KDL N70 GOCX GOCY PT13 PT14 PTI
PT10 PT10I PT10N O10 N10 PT11 PT11N O11 N11 KC OSM OLDERR)
(SETQ CMD (GETVAR "CMDECHO"))
(SETQ OSM (GETVAR "OSMODE"))
(SETQ OLDERR *error*
*error* myerror)
(PRINC "Please select dimension object!")
(SETQ SS (SSGET))
(SETVAR "CMDECHO" 0)
(SETQ PT (GETPOINT "Point to trim or extend:"))
(SETQ PT (TRANS PT 1 0))
(COMMAND "UCS" "W")
(SETQ LTH (SSLENGTH SS))
(SETQ DEM 0)
(WHILE (< DEM LTH)
(PROGN
(SETQ DS (ENTGET (SSNAME SS DEM)))
(SETQ KDL (CDR (ASSOC 0 DS)))
(IF (= "DIMENSION" KDL)
(PROGN
(SETQ PT13 (CDR (ASSOC 13 DS)))
(SETQ PT14 (CDR (ASSOC 14 DS)))
(SETQ PT10 (CDR (ASSOC 10 DS)))
(SETQ PT11 (CDR (ASSOC 11 DS)))
(SETQ N70 (CDR (ASSOC 70 DS)))
(IF (OR (= N70 32) (= N70 33) (= N70 160) (= N70 161))
(PROGN
(SETQ GOCY (ANGLE PT10 PT14))
(SETQ GOCX (+ GOCY (/ PI 2)))
)
)
(SETVAR "OSMODE" 0)
(SETQ PTI (POLAR PT GOCX 2))
(SETQ PT10I (POLAR PT10 GOCY 2))
(SETQ PT10N (INTERS PT PTI PT10 PT10I NIL))
(SETQ KC (DISTANCE PT10 PT10N))
(SETQ O10 (ASSOC 10 DS))
(SETQ N10 (CONS 10 PT10N))
(SETQ DS (SUBST N10 O10 DS))
(SETQ PT11N (POLAR PT11 (ANGLE PT10 PT10N) KC))
(SETQ O11 (ASSOC 11 DS))
(SETQ N11 (CONS 11 PT11N))
(SETQ DS (SUBST N11 O11 DS))
(ENTMOD DS)
)
)
(SETQ DEM (+ DEM 1))
)
)
(COMMAND "UCS" "P")
(SETVAR "CMDECHO" CMD)
(SETVAR "OSMODE" OSM)
(setq *error* OLDERR)
(PRINC)
)
;---------------------------------------Nhan so voi mot so can nhan them---------------------
(defun c:ns()
(setvar "CMDECHO" 0)
(princ "\n PROCEDURE BY XTK2 - ADCC")
(setq pre (getint "\nSo chu so sau dau phay?"))
(command "luprec" pre)
(SETQ SET (SSGET))
(setq co (getreal "\nGia tri can so nhan:"))
(SETQ QUANT (SSLENGTH SET))
(SETQ INDEX 0)
(WHILE (< INDEX QUANT)
(IF
(AND (= "TEXT" (CDR (ASSOC 0 (SETQ A (ENTGET (SSNAME SET INDEX)))))))
(PROGN
(setq s (entget (SSNAME SET INDEX)))
(setq otext (assoc 1 s))
(setq ot (cdr otext))
(setq ot (read (substr ot 1 )))
(setq nt (cons 1 (rtos (* ot co))))
(setq s (subst nt otext s))
(entmod s)
)
)
(setq index (+ index 1))
)
(command "luprec" "4")
)
;---------------------------------------Cong so voi mot so can cong them---------------------
(defun c:cs()
(setvar "CMDECHO" 0)
(princ "\n PROCEDURE BY XTK2-ADCC")
(setq pre (getint "\nSo chu so sau dau phay?"))
(command "luprec" pre)
; (SETQ SET (SSGET))
(setq co (getreal "\nGia tri can cong them:"))
(SETQ SET (SSGET))
(SETQ QUANT (SSLENGTH SET))
; (prompt (strcat "\nBan da chon tat ca: " quant " so"))
(SETQ INDEX 0)
(WHILE (< INDEX QUANT)
(IF
(AND(= "TEXT" (CDR (ASSOC 0 (SETQ A (ENTGET (SSNAME SET INDEX)))))))
(PROGN
(setq s (entget (SSNAME SET INDEX)))
(setq otext (assoc 1 s))
(setq ot (cdr otext))
(setq ot (read (substr ot 1 )))
(setq nt (cons 1 (rtos (+ ot co))))
(setq s (subst nt otext s))
(entmod s)
)
)
(setq index (+ index 1))
)
)
;------------------------------------Thay doi cac mau---------------------------------------
(defun c:1()
(setq s (ssget))
(command"chprop" "p" "" "c" 1 "")
)
(defun c:2()
(setq s (ssget))
(command"chprop" "p" "" "c" 2 "")
)
(defun c:3()
(setq s (ssget))
(command"chprop" "p" "" "c" 3 "")
)
(defun c:4()
(setq s (ssget))
(command"chprop" "p" "" "c" 4 "")
)
(defun c:5()
(setq s (ssget))
(command"chprop" "p" "" "c" 5 "")
)
(defun c:6()
(setq s (ssget))
(command"chprop" "p" "" "c" 6 "")
)
(defun c:7()
(setq s (ssget))
(command "chprop" "p" "" "c" 7 "")
)
(defun c:8()
(setq s (ssget))
(command "chprop" "p" "" "c" 8 "")
)
(defun c:9()
(setq s (ssget))
(command"chprop" "p" "" "c" 9 "")
)
;------------------------------------Cac cach zoom---------------------------------------
(defun c:n() (command "dim1" "new"))
(defun c:za() (command "zoom" "a"))
(defun c:ze() (command "zoom" "e"))
(defun c:zz () (command "zoom" "p"))
(defun c:zd () (command "zoom" "d"))
(defun c:xz () (command "zoom" "1.5x"))
(defun c:zx() (command "zoom" "0.6x"))
(defun c:c() (ssget) (command "copy" "p" "" "m"))
(defun c:t1() (command "tilemode" "1"))
(defun c:y() (command "open"))
(defun c:sa() (command "qsave"))
(defun c:lf() (command "layoff"))
(defun c:ln() (command "layon"))
(defun c:lio() (command "layiso"))
(defun acad_helpdlg (helpfile topic)
(help helpfile topic)
)
Hữu ích
Trả lờiXóa