[ Nhờ chỉnh sửa] Lisp xuất tọa độ

[vuminhchau 1]

:rolleyes: :rolleyes:

[wimax16vnn 2]

thanks vì lisp của bạn cái mình đang cần
mình có 1 yêu cầu nhỏ là bạn có thể chỉnh lại cho số tọa độ lấy làm tròn 2 số lẻ dc ko ( trong lisp lấy 3 số lẻ)
thank a lot

http://www.cadviet.com/upfiles/3/23835_xxx.lsp

[ro88 2]

các bác ơi, cho em hỏi tí là muốn sửa để phần toạ độ XY có 4 số sau dấu phẩy (,) thì làm thế nào ạ! cả thay đổi cột YX thành XY nữa! cảm ơn các bác

 

thanks vì lisp của bạn cái mình đang cần

mình có 1 yêu cầu nhỏ là bạn có thể chỉnh lại cho số tọa độ lấy làm tròn 2 số lẻ dc ko ( trong lisp lấy 3 số lẻ)

thank a lot

http://www.cadviet.com/upfiles/3/23835_xxx.lsp

 

Mình up cho các bạn lisp này theo yêu cầu cái này mình cũng sư tầm trên cadviet. nhờ rất nhiều người sửa giúp.

cái XY hay YX thì chịu khó sửa đi chứ mình ko biết.

Lệnh là TD1 nhé:

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=63922&pid=213751&st=0entry213751
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=63922&pid=199638&st=0entry199638
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=13203&st=3100
;; 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 - January 2009 - 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
)
;;; First point of List rearrangement
(defun relist(pt0 Lst / i rt)
  (setq i 0)
  (foreach pt Lst
(if (equal pt0 pt 0.001)
   (setq rt i))
(setq i (1+ i)))
  (append (append (member (nth rt Lst) Lst)
  	(cdr (reverse (cdr (member (nth rt Lst) (reverse Lst))))))
  	(list (nth rt Lst)))
)
;;;New Layer
(defun newlayer(a b c d)
(if (not (tblsearch "layer" a))
	(command "-layer" "n" a "c" b a "l" c a "lw" d a ""))
)
;;;-------------------------------------------------------------------------------
(defun wtxtMC (txt p h k)
;;;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)
  	(if k (cons 51 (DTR 18)) (cons 51 0))
	)
  )
)
;;;-------------------------------------------------------------------------------
(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 (* 7 h))
p3 (polar p2 0 (* 10 h))
p4 (polar p3 0 (* 9 h))
pL (list p1 p2 p3 p4)
i  0
  )
  (repeat 4
(wtxtMC (nth i txtL) (nth i pL) h t)
(setq i (1+ i))
  )
)
;;;-------------------------------------------------------------------------------
(defun txt2 (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 (* 7 h))
p3 (polar p2 0 (* 10 h))
p4 (polar p3 0 (* 9 h))
p4 (polar p4 (* 0.5 pi) h)
pL (list p1 p2 p3 p4)
i  0
  )
  (repeat 4
(wtxtMC (nth i txtL) (nth i pL) h t)
(setq i (1+ i))
  )
)
;;;-------------------------------------------------------------------------------
;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:TD1 (/ h p et p0 p00 p01 p02 pt pvL pvL1 n j pv num txtL ss bn ntp p11 p12 p13 p14)
  (setvar "cmdecho" 0)
;;;New layer check
  (newlayer "kichthuoc" 7 "continuous" "default")
  (newlayer "stt" 1 "continuous" "default")
  (newlayer "bangtd" 7 "continuous" "default")
;;;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))
;;;GET DECIMAL PRECISION
  (if (not ntp0)  (setq ntp0 2))
  (setq ntp (getint (strcat "\nSo chu so thap phan <" (itoa ntp0) ">:")))
  (if (not ntp)  (setq ntp ntp0)  (setq ntp0 ntp))
;;;GET CIRCLE RADIUS
  (if (not cr0)  (setq cr0 0.3))
  (setq cr (getreal (strcat "\nNhap ban kinh vong tron <" (rtos cr0) ">:")))
  (if cr (setq cr0 cr))

;;;PICK & BASE POINT
  (initget "Y")
  (setq save (getkword "\nBan co muon luu file? < Y / Enter for No >:"))

  (setq oldos (getvar "osmode")
	pdau (getpoint "\nPick diem dau tien (so thu tu = M1): " )
  ) 

  ;(while pdau
(setq p (getpoint "\nPick 1 diem giua mien kin:")
          	pvL nil pvL1 nil)
(command "boundary" p "")
(setq et (entlast)
         	pvL1 (reverse (getvert et))) 
(redraw et 3) 
(setq p00 (getpoint "\nDiem dat Bang TDGR:"))
(initget "T t N n")
(setq chieu (getkword "\nLua chon chieu ghi toa do < T/N >"))
(command "erase" et "")
(setq  p0 p00
    	p01  (polar p00 (* 1.5 pi) (* h 3))   
    	pvL  (relist pdau pvL1)
    	n	(length pvL)
    	p02	(polar p01 (* 1.5 pi) (+ (* h 3) (* (1- n) h 2)))
) 
(setvar "osmode" 0)
;;;HEADER
  (setvar "CLAYER" "bangtd")
  (linepx p0 (* 32 h))
  (command "copy" "L" "" "m" p00 p01 "")
  (setq Lkqua nil)
  (command "style" "Standard" ".Arial" "" "" "" "" "")
  (wtxtMC "B¶ng kª to¹ d«d vµ kho¶ng c¸ch"
  	(polar (polar p0 0 (* 16 h)) (* 0.5 pi) (* 4 h))
  	(* 1.2 h) nil)
  (wtxtMC "H? t?a d? VN-2000"
  	(polar (polar p0 0 (* 16 h)) (* 0.5 pi) (* 2 h))
  	(* 1.2 h) nil)
  (txt1 (setq Lkq (list "TT" "Y (m)" "X (m)" "S (m)")))
  (setq Lkqua (append Lkqua (list Lkq)))
  (setq p0 (polar p0 (* 1.5 pi) (* 3 h)))
;;;MAKE RECORDS
  (if (or (= chieu "N") (= chieu "n")) (setq pvL (reverse pvL)) )
  (setq	j  0
	pt nil)
  (repeat n
(setq
   pv  (nth j pvL)
   num (itoa (1+ j))
num (strcat "M" num)
)
(if	pt
   (setq S (rtos (distance pt pv) 2 ntp))
   (setq S "")
)
(setq
   txtL (list num (rtos (car pv) 2 ntp) (rtos (cadr pv) 2 ntp) S)
   Lkqua (append Lkqua (list txtL))
)
(txt2 txtL)
(setq p11 (polar p0 (* 1.5 pi) (* 2.5 h)))
(setq P12 (polar p11 0 (* 25 h)))
(setq P13 (polar p11 0 (* 31 h)))
(setq P14 (polar p11 0 (* 32 h)))
(command "LINE" p11 p12 "")
(command "LINE" p13 p14 "")
(setq p0 (polar p0 (* 1.5 pi) (* 2 h)))
(setq pt pv)
(setq j (1+ j))
(if	(= j (- n 1))  (setq j 0))
  )
  (command "LINE" p11 p14 "")
  (linepy p00 (- (distance p00 (polar p0 (* 1.5 pi) (* 0.5 h)) )))
  (command "copy" "L" "" "m"  p0
	(list (+ (car p0) (* 4 h)) (cadr p0))
	(list (+ (car p0) (* 14 h)) (cadr p0))
	(list (+ (car p0) (* 24 h)) (cadr p0))
	(list (+ (car p0) (* 32 h)) (cadr p0))
	"")
;;;WRITE POINT NAME
  (setvar "CLAYER" "stt")
  (setq j 0)
  (repeat (1- n)
(setq
   pv  (nth j pvL)
   num (itoa (1+ j))
num (strcat "M" num)
)
(wtxtMC num (polar pv 0 h) h t)
(command "circle" pv cr0)
(command "HATCH" "solid" "L" "")
(command "erase" vtron "")
(setq j (1+ j))
  )
;;;GHI CANH THUA
(setvar "CLAYER" "kichthuoc")
(ghicanh) 
;;;FINISH
(savef)
(setvar "osmode" oldos)
;(setq pdau (getpoint "\nPick diem dau tien (so thu tu = 1) :"))
  ;;; ) 
  (setvar "cmdecho" 1)
  (princ)
)
;;;-------------------------------------------------------------------------------
(defun savef() 
  (if save
(progn
   (setq file (open (setq tenfile (strcat (getvar "dwgprefix")
 	(vl-filename-base (vl-string-right-trim "\\" (getvar "dwgname"))) ".txt")) "a"))
   (foreach line Lkqua
	(setq line1 "")
	(foreach it line
  	(setq line1 (strcat line1 " " it)))
	(write-line line1 file)
   )
   (close file)
   (princ (strcat "\nDa luu thanh file " tenfile))
)
  )
)
;;;PHAN BO SUNG
;;;------------------------------------------------------------------------------------
(defun Text_canh_TCA (S p a )
;;;Entmake text S at p with angle A - Top Center
  (if (/= p nil)
(entmake (list
    	(cons 0 "TEXT")
    	(cons 62 2)
    	(cons 10 p)
    	(cons 40 h)
    	(cons 1 S)
    	(cons 50 a )
    	(cons 41 0.7)
    	(cons 7 (getvar "textstyle"))
    	(cons 72 1)
    	(cons 11 p)
    	(cons 73 3)
  	)
)
  )
)
;;;------------------------------------------------------------------------------------
(defun Text_canh_BCA (S p a )
;;;Entmake text S at p with angle A - Bottom Center
  (if (/= p nil)
(entmake (list
    	(cons 0 "TEXT")
    	(cons 62 2)
    	(cons 10 p)
    	(cons 40 h)
    	(cons 1 S)
    	(cons 50 a )
    	(cons 41 0.7)
    	(cons 7 (getvar "textstyle"))
    	(cons 72 1)
    	(cons 11 p)
    	(cons 73 1)
  	)
)
  )
)
;;;-------------------------------------------------------------------------------
(defun Ghicanh (/ i k p1 p2 dist rad x_mp y_mp mp mp1)
  (setq
i	0  
k	(1- (length pvL))
  )
  (repeat k
(setq
   p1   (nth i pvL)
   p2   (nth (+ i 1) pvL)
   dist (distance p1 p2)
   rad  (angle p1 p2)
   x_mp (* (+ (car p1) (car p2)) 0.5)
   y_mp (* (+ (cadr p1) (cadr p2)) 0.5)
   mp   (list x_mp y_mp)
)
(if	(and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
   (setq mp (polar mp (+ rad (* 0.5 pi)) (* 0.3 h)))
)
(if	(and (> rad (* 0.5 pi)) (<= rad (* 1.5 pi)))
   (progn
	(setq rad (+ rad pi))
	;(Text_canh_TCA (rtos dist 2 2) mp rad)
)
   ;(Text_canh_BCA (rtos dist 2 2) mp rad)
)
(setq mp1 (polar mp (angle p mp) (* 2 h)) )
(command "DIMALIGNED" p1 p2 mp1)
(setq i (1+ i))
  )
  ;; repeat k;
)
;;;--------------------------