{Nhờ chỉnh sửa} Lisp xuất bảng kê tọa độ và khoảng cách

Nhờ các bạn sử lại lisp này giúp mình với
Khi lisp xuất ra thì côt (X) và (Y) bị ngược nhau nhờ đổi lại 2 cột này
Font chữ bị lỗi trong bản vẽ ben dưới minh có bản mẫu nhờ sửa lại như trong bản vẽ
Các điểm tên mốc không phải M1,M2 .... mà là 1,2....
Không co những đường line ngăn cách giữa nhưng hàng trên và dưới
Nếu được thì giúp mình thêm cái nữa la có thể viết them 1 đoạn lisp cho nó chạy ngược chiều kim đồng hồ luôn.
Như thế này:
Command: td1
Chon chieu cao text <1>:
So chu so thap phan <2>:
Nhap ban kinh vong tron <0.3>:
Bạn muốn chạy Nghịch(N)/Thuận(T): (thêm vào dòng này)

Code:

;; 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 and elleHCSC - 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 n j pv num txtL ss bn ntp)
  (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:"))
    (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 p02 "")
  (linepy p0 (- (distance p0 p02)))
  (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))
     "")
  (setq Lkqua nil)
  (wtxtMC "BAÛNG TOÏA ÑOÄ GOÙC RANH"
     (polar (polar p0 0 (* 16 h)) (* 0.5 pi) (* 2 h))
       (* 1.2 h) nil)
  (txt1 (setq Lkq (list "TT" "X (m)" "Y (m)" "S (m)")))
  (setq Lkqua (append Lkqua (list Lkq)))
  (setq p0 (polar p0 (* 1.5 pi) (* 3 h)))

;;;MAKE RECORDS
  (setq   j  0
   pt nil)
  (repeat n
    (setq
      pv  (nth j pvL)
      num (itoa (1+ j))
    )
    (if   pt
      (setq S (rtos (distance pt pv) 2 ntp))
      (setq S "")
    )
    (setq
      txtL (list (strcat "M" (rtos num 2 0)) (rtos (cadr pv) 2 ntp) (rtos (car pv) 2 ntp) S) ;;;;; Thay doi cac thong so o vi tri nay
      Lkqua (append Lkqua (list txtL))
    )
    (txt2 txtL)
    (setq p0 (polar p0 (* 1.5 pi) (* 2 h)))
    (setq pt pv)
    (setq j (1+ j))
    (if   (= j (- n 1))  (setq j 0))
  )

;;;MAKE BLOCK
  (setq ss (collect1 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
  (setvar "CLAYER" "stt")
  (setq j 0)
  (repeat (1- n)
    (setq
      pv  (nth j pvL)
      num (itoa (1+ j))
    )
    (wtxtMC num (polar pv 0 h) h t)
    (command "circle" pv cr0)
    (command "hatch" "S" (setq vtron (entlast)) "")
    (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 =M 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 CUA elleHCSC
;;;------------------------------------------------------------------------------------
(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 5)
         (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 5)
         (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)
  (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 i (1+ i))
  )
  ;; repeat k;
)
;;;--------------------------


Đây là bản vẽ



[You must be registered and logged in to see this link.]

Bạn xem cái lisp này có như ý bạn không nhé
Xem link ở dưới:
[You must be registered and logged in to see this link.]
Chúc thành công!

Cảm ơn Admin nhiều nhé.

mình đang cần lisp này nhưng sao tải về lại ko biết sử dụng thế amind oi

kj3mma đã viết:mình đang cần lisp này nhưng sao tải về lại ko biết sử dụng thế amind oi

Mở Autocad lên, gõ lệnh Ap rồi chọn đường dẫn đến file và Load nó lên.
Gõ lệnh: LBTDT rồi thực hiện theo câu lệnh.

admin có thể giúp mình viết 1 lisp tương tự theo bản vẽ của mình không ( trong đó có diện tích nhà đường nét đứt và diện tích đất nét màu xanh
[img][/img]
[img][/img]

Mình ko hiểu ý bạn trong 2 hình vẽ bạn đưa lên, vì cái lisp mình đã gửi cho bạn đã làm được các vấn đề đó.
Ở đây chỉ khác cách dùng để thế nào ra như vậy, mình mách nhỏ thế này có đúng ý bạn ko nhé:
1. Để có kích thước và vị trí đỉnh của lô đất (tất nhiên là các line bao lô đất phải là polyline kín) bạn tắt tất cả các layer nằm bên trong lô đất đi để thực hiện cho nó >> Xong
2. Bất các lảyer đó lên lại và thực hiện cho các lô nhà ở. >>> Xong
Nói tóm lại, là thực hiện cái lớn trước rồi đến cái nhỏ, và xoá những cái nào ko cần thể hiện, việc này rất đơn giản vì mình đã quản lý layer cho từng đối tượng tạo ra bằng các layer riêng biệt.
Chúc thành công.

ad cho em xin cái font trong lisp ấy đi

tannguyenicp đã viết:ad cho em xin cái font trong lisp ấy đi

Bạn search font trên mạng có nhiều lắm mà

Theo cái lisp của ro88 tôi được hình này. Nhưng muốn nhờ admin giúp in ra cái bảng kích thước như ảnh sau. Chỉ cần cạnh, không cần tọa độ. Cảm ơn Pác ADMIN!

nghiamdc đã viết:Theo cái lisp của ro88 tôi được hình này. Nhưng muốn nhờ admin giúp in ra cái bảng kích thước như ảnh sau. Chỉ cần cạnh, không cần tọa độ. Cảm ơn Pác ADMIN!

Hình nhỏ quá ko thấy gì hết bạn ơi    

a oi e muốn chọn chữ số thập phân cho tọa độ và khoảng cách riêng được không ạ. và đánh theo chiều thuận kim đồng hồ được không admin