Lisp xuất tọa độ khép kính

;; free lisp from cadviet.com

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

;;;Chuong trinh danh so va lap bang toa do ho so thua dat dia chinh
;;;Bang toa do tao thanh block, duoc dat ten theo so thu tu 1, 2, 3...
;;;Chap nhan cac doi tuong la Region, Polyline, Line va Arc khep kin
;;;Written by Ssg - September 2008 - www.cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;PUBLIC FUNCTIONS
;;;-------------------------------------------------------------------------------
(Defun DTR(x) (/ (* x pi) 180) ) ;;;change degree to radian, return REAL
;;;-------------------------------------------------------------------------------
(defun lineP (p0 a r / p1) ;;;Line polar: point, degree angle, radius
    (setq p1 (polar p0 (dtr a) r))
    (command "line" p0 p1 "")
)
;;;-------------------------------------------------------------------------------
(defun linePX (p0 x) (lineP p0 0 x)) ;;;Horizontal line: length x, from p0
;;;-------------------------------------------------------------------------------
(defun linePY (p0 y) (lineP p0 90 y)) ;;;Vertical line: length y, from p0
;;;-------------------------------------------------------------------------------
(defun getVert (e / i L) ;;;Return list of all vertex from pline e
(setq i 0 L nil)
(vl-load-com)
(repeat (fix (+ (vlax-curve-getEndParam e) 1))
    (setq L (append L (list (vlax-curve-getPointAtParam e i))))
    (setq i (1+ i))
)
L
)
;;;-------------------------------------------------------------------------------
(defun wtxtMC (txt p h) ;;;Write text Middle Center, specify text, point, height
(entmake (list (cons 0  "TEXT") (cons 7 (getvar "textstyle"))
    (cons 1 txt) (cons 10 p) (cons 11 p) (cons 40 h) (cons 72 1) (cons 73  2)))
)
;;;-------------------------------------------------------------------------------
(defun Collect(e / e2 SS) ;;;Selection set from e to entlast
(setq SS (ssadd))
(ssadd e SS)
(while (setq e2 (entnext e)) (ssadd e2 SS) (setq e e2))
SS
)
;;;-------------------------------------------------------------------------------
(defun Collect1(e / ss)
;;;Selection set after e to entlast. If e nil, select all from fist entity of drawing.
(if (= e nil) (setq ss (collect (entnext)))
   (progn (setq ss (collect e)) (ssdel e ss))
)
)
;;;-------------------------------------------------------------------------------

;;;PRIVATE FUNCTIONS
;;;-------------------------------------------------------------------------------
(defun txt1(txtL / p1 p2 p3 p4 pL i) ;;;Write texts in 1 row
(setq
    p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
    p2 (polar p1 0 (* 6 h))
    p3 (polar p2 0 (* 8 h))
    p4 (polar p3 0 (* 8 h))
    pL (list p1 p2 p3 p4)
    i 0
)
(repeat 3
    (wtxtMC (nth i txtL) (nth i pL) h)
    (setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
(defun mesh1() ;;;Make 1 mesh unit
(linepy p0 (* -3 h))
(command "copy" "L" "" p0 (list (+ (car p0) (* 4 h)) (cadr p0)))
(command "array" "L" "" "r" 1 3 (* 8 h))
(linepx (polar p0 (* 1.5 pi) (* 3 h)) (* 20 h))
)
;;;-------------------------------------------------------------------------------


;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:VC( / h p et p0 p00 pvL oldos j pv num txtL ss bn)
;;;Vertex Co-ordinate

;;;GET TEXT HEIGHT
(if (not h0) (setq h0 1))
(setq h (getreal (strcat "\nChon chieu cao text <" (rtos h0) ">:")))
(if (not h) (setq h h0) (setq h0 h))
(setvar "osmode" 0)

;;;PICK & BASE POINT
(setq p (getpoint "\nPick 1 diem giua mien kin:"))
(command "boundary" p "")
(setq et (entlast))
(redraw et 3)
(setq
    p00 (getpoint "\nDiem chuan bang toa do (phia tren ben trai):")
    p0 p00
    pvL (reverse (getvert et))
    oldos (getvar "osmode")
)

;;;HEADER
(linepx p0 (* 20 h))
(mesh1)
(txt1 (list "TT" "X" "Y"))
(setq p0 (polar p0 (* 1.5 pi) (* 3 h)))

;;;MAKE RECORDS
(setq j 0)
(repeat (1- (length pvL))
    (mesh1)
    (setq
        pv (nth j pvL)
        num (itoa (1+ j))
        txtL (list num (rtos (car pv)) (rtos (cadr pv)) )
    )
    (txt1 txtL)
    ;(wtxtMC num (polar pv 0 h) h)
    (setq p0 (polar p0 (* 1.5 pi) (* 3 h)))
    (setq j (1+ j))
)

;;;MAKE BLOCK
(setq ss (collect1 et))
(command "erase" et "")
(setq bn "1")
(while (tblsearch "block" bn) (setq bn (itoa (1+ (atoi bn)))))
(command "block" bn p00 ss "")
(command "insert" bn p00 "" "" "")

;;;WRITE POINT NAME
(setq j 0)
(repeat (1- (length pvL))
    (setq
        pv (nth j pvL)
        num (itoa (1+ j))
    )
    (wtxtMC num (polar pv 0 h) h)
    (setq j (1+ j))
)

;;;FINISH
(setvar "osmode" oldos)
(princ)
)
;;;-------------------------------------------------------------------------------
vc.lsp
Đăng nhập
Đang hiển thị vc.lsp.