Bảng toạ độ các đỉnh thửa đất

[thacvh 0]

Cám ơn bạn đã chia sẻ, dân địa chính cần cái này lắm, nhưng bạn post thiếu file gr.dwg nên chương trìng báo lỗi. Bạn hãy post file này lên đi. Thanks!

http://www.cadviet.com/upfiles/gkt1.dwg

[tnmtpc 207]

http://www.cadviet.com/upfiles/gkt1.dwg

Cám ơn bạn, bữa trước sử dụng lisp này, gõ lệnh gkt1, chương trình bào lỗi " không tìm thấy file gr.dwg" nên mình nghĩ do thiếu file này, sau khi tìm hiểu file bản vẽ của bạn thì mới hiểu được lisp hoạt động với điều kiện phải tạo thêm Style Name là txt.

Cám ơn bạn, tiện ích này hay. Còn cái nào liên quan đến thửa đất nói riêng, bản đồ nói chung Ko bạn, nếu có chia sẻ cho anh em chiêm ngưỡng

[thanhtri2301 0]

1)chọn đối tượng polyline khep kin

2) Tên điểm ,số thứ tự định 1,2,3

3) thể hiện cạnh

4) ghi bảng toạ độ ..

- Ngược chiều kim đồng hồ

********************

chia sẻ Anh e cùng nghiên cứu !

Tên lệng là " TD "

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

 

 

 

(defun *error* (msg)

(princ "error: ")

(princ msg)

(princ)

)

 

(defun Wdis (p1 p2 / dis ang point)

(setq dis (distance p1 p2))

(setq ang (angle p1 p2))

(if (and (> ang (/ Pi 2)) (< ang (* Pi 1.5)) )

(progn

(setq ang (+ Ang Pi))

(setq Point (polar p2 ang (/ dis 2.0)))

)

(setq Point (polar p1 ang (/ dis 2.0)))

)

(command "Text" "S" "TIMESBD" "c" point (/ TileBdHT 500) (* (/ ang Pi) 180) (rtos dis 2 2) )

)

(defun ssgetLayer( La1 La2 / ss)

(setq ss (ssget "X" (list

(cons -4 "

(cons -4 "

(cons 8 La1)

(cons 0 "LWPOLYLINE")

(cons -4 "AND>")

(cons -4 "

(cons 8 La1)

(cons 0 "LINE")

(cons -4 "AND>")

(cons -4 "

(cons 8 La2)

(cons 0 "LWPOLYLINE")

(cons -4 "AND>")

(cons -4 "

(cons 8 La2)

(cons 0 "LINE")

(cons -4 "AND>")

(cons -4 "OR>")

)

))

ss

)

(defun pointpl (name tn k / namem i bien t1 p1 diem)

(setq namem name)

(setq i 1)

(while (<= i k)

(progn

(setq bien (assoc tn namem))

(setq t1 (member bien namem))

(setq p1 (car t1))

(setq namem (cdr t1))

(setq diem (cdr p1))

(setq i (+ 1 i))

)

)

diem

)

(defun c:Td ( / i k luuxy st p xoa)

(setvar "cmdecho" 0)

(setq st (ssgetLayer "Ranh_toado" "Ranh_38") )

(if (/= st nil)

(progn

(if (null (tblsearch "style" "TIMESBD"))

(command "_style" "TIMESBD" "TIMESBD.ttf" "" "" "" "" ""))

(if (null (tblsearch "style" "VHELVEB"))

(command "_style" "VHELVEB" "VHELVEB.ttf" "" "" "" "" ""))

(if (null (tblsearch "style" "TIMESBI"))

(command "_style" "TIMESBI" "TIMESBI.ttf" "" "" "" "" ""))

(if (null (tblsearch "style" "VNTIMEB"))

(command "_style" "VNTIMEB" "VNTIMEB.ttf" "" "" "" "" ""))

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

(if (null (tblsearch "layer" "sohieu_diem"))

(command "_layer" "n" "sohieu_diem" ""))

(command "_layer" "c" "2" "sohieu_diem" "")

(if (null (tblsearch "layer" "bang_toado"))

(command "_layer" "n" "bang_toado" ""))

(command "_layer" "c" "7" "bang_toado" "")

(command "_layer" "c" "6" "Ranh_38" "")

(command "_layer" "c" "6" "Ranh_toado" "")

(setq r1 (getvar "USERR1"))

(setq TileBdHT (getreal (strcat "\nMau So Ti Le Cua BDHT" "(" (rtos r1 2 0) "):")))

(if (= TileBdHT nil)

(setq TileBdHT r1))

(setvar "USERR1" TileBdHT)

 

(setvar "blipmode" 0)

(setq old (getvar "osmode"))

(setvar "osmode" 0)

(setq p (getpoint "\n Pick"))

(if (/= p nil)

(command "-Boundary" "a" "b" "n" st "" "" p "" )

)

(setq luuxy (entget (entlast)))

(setq p (getpoint "\n Diem dat bang toa do :"))

(entdel (entlast))

(setq k (cdr (assoc 90 luuxy)))

(if (/= p nil)

(progn

(setq p01 p)

(setq p02 (mapcar '+ p '(10.0 0.0 0.0)))

(setq p03 (mapcar '+ p '(22.5 -2.5 0.0)))

(setq p04 (mapcar '+ p '(35.0 0.0 0.0)))

(setq p05 (mapcar '+ p '(45.0 0.0 0.0)))

(setq p06 (mapcar '+ p '(0.0 -5.0 0.0)))

(setq p07 (mapcar '+ p '(10.0 -2.5 0.0)))

(setq p08 (mapcar '+ p '(35.0 -2.5 0.0)))

(setq p09 (mapcar '+ p '(45.0 -5.0 0.0)))

(if (<= k 4)

(progn

(setq p10 (mapcar '+ p '(0.0 -22.0 0.0)))

(setq p11 (mapcar '+ p '(10.0 -22.0 0.0)))

(setq p12 (mapcar '+ p '(22.5 -22.0 0.0)))

(setq p13 (mapcar '+ p '(35.0 -22.0 0.0)))

(setq p14 (mapcar '+ p '(45.0 -22.0 0.0)))

)

(progn

(setq ty (* -1 (+ 10.0 (* k 3))))

(setq t0 (list 0.0 ty 0.0))

(setq t1 (list 10.0 ty 0.0))

(setq t2 (list 22.5 ty 0.0))

(setq t3 (list 35.0 ty 0.0))

(setq t4 (list 45.0 ty 0.0))

(setq p10 (mapcar '+ p t0))

(setq p11 (mapcar '+ p t1))

(setq p12 (mapcar '+ p t2))

(setq p13 (mapcar '+ p t3))

(setq p14 (mapcar '+ p t4))

)

)

(command "layer" "s" "bang_toado" "")

(command "Line" p01 p05 "")

(command "Line" p01 p10 "")

(command "Line" p02 p11 "")

(command "Line" p03 p12 "")

(command "Line" p04 p13 "")

(command "Line" p05 p14 "")

(command "Line" p07 p08 "")

(command "Line" p06 p09 "")

(command "Line" p10 p14 "")

(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ p '(22.5 2.0 0.0)) 1.25 0 "BAÛNG LIEÄT KEÂ TOÏA ÑOÄ GOÙC RANH")

(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ p '(5.0 -1.5 0.0)) 1.15 0 "Soá hieäu")

(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ p '(5.0 -3.5 0.0)) 1.15 0 "ñieåm")

(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ p '(22.5 -1.25 0.0)) 1.15 0 "Toïa ñoä")

(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ p '(16.25 -3.75 0.0)) 1.15 0 "X(m)")

(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ p '(28.75 -3.75 0.0)) 1.25 0 "Y(m)")

(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ p '(40.0 -2.5 0.0)) 1.25 0 "Caïnh")

)

)

(setq i 1)

(while (<= i k)

(progn

(setq toado (pointpl luuxy 10 i))

(setq x (rtos (car toado) 2 2))

(setq y (rtos (cadr toado) 2 2))

(command "layer" "s" "sohieu_diem" "")

(setq doi (list (* 0.2 (/ TileBdHT 500)) (* 0.2 (/ TileBdHT 500)) 0.0))

(command "Text" "S" "TIMESBD" (mapcar '+ toado doi) (/ TileBdHT 500) 0 i)

(command "donut" "0.0" (* 0.25 (/ TileBdHT 500)) toado "")

(setq tsh (list 5.0 (- (* -3 i) 4.5) 0.0))

(setq txx (list 16.25 (- (* -3 i) 4.5) 0.0))

(setq tyy (list 28.75 (- (* -3 i) 4.5) 0.0))

(setq tgc (list 40.0 (- (* -3 i) 3.0) 0.0))

(setq psh (mapcar '+ p tsh))

(setq pxx (mapcar '+ p txx))

(setq pyy (mapcar '+ p tyy))

(setq pgc (mapcar '+ p tgc))

(if (= i 1)

(progn

(setq toado1 toado)

(setq x1 (rtos (car toado1) 2 2))

(setq y1 (rtos (cadr toado1) 2 2))

)

)

(if (>= i 2)

(progn

(setq canh (distance toado0 toado))

(command "layer" "s" "bang_toado" "")

(command "Text" "S" "TIMESBD" "j" "M" pgc 1.2 0 (rtos canh 2 2) )

(command "layer" "s" "sohieu_diem" "")

(wdis toado0 toado)

)

)

(command "layer" "s" "bang_toado" "")

(command "Text" "S" "TIMESBD" "j" "M" psh 1.2 0 i)

(command "Text" "S" "TIMESBD" "j" "M" pxx 1.2 0 y)

(command "Text" "S" "TIMESBD" "j" "M" pyy 1.2 0 x)

(setq toado0 toado)

(setq i (+ i 1))

)

)

(command "layer" "s" "sohieu_diem" "")

(wdis toado toado1)

(setq canh (distance toado toado1))

(setq tsh (list 5.0 (- (* -3 (+ k 1)) 4.5) 0.0))

(setq txx (list 16.25 (- (* -3 (+ k 1)) 4.5) 0.0))

(setq tyy (list 28.75 (- (* -3 (+ k 1)) 4.5) 0.0))

(setq tgc (list 40.0 (- (* -3 (+ k 1)) 3.0) 0.0))

(setq psh (mapcar '+ p tsh))

(setq pxx (mapcar '+ p txx))

(setq pyy (mapcar '+ p tyy))

(setq pgc (mapcar '+ p tgc))

(command "layer" "s" "bang_toado" "")

(command "Text" "S" "TIMESBD" "j" "M" pgc 1.2 0 (rtos canh 2 2) )

(command "Text" "S" "TIMESBD" "j" "M" psh 1.2 0 "1")

(command "Text" "S" "TIMESBD" "j" "M" pxx 1.2 0 y1)

(command "Text" "S" "TIMESBD" "j" "M" pyy 1.2 0 x1)

(setvar "osmode" old)

) ;(end progn)

) ;(end if)

(if (= st nil)

(progn

(setvar "cmdecho" 1)

(alert "Khong co Layer Ranh_toado tren ban ve \n\nNhan OK de Lop Ranh_toado duoc tao")

(command "_layer" "N" "Ranh_toado " "C" "6" "Ranh_toado " "S" "Ranh_toado " "") )

)

)

[thanhgam2003 1]

sao khi minh load len rồi chạy lệnh, nó báo Unknown command "TD". Press F1 for help.

[xuandao0708 9]

Bác SSQ ơi cho em hỏi 1 chút, giữa lisp vc đầu và lisp vc sau có khác nhau 1 điểm là tọa độ cột X và cột Y được đổi chổ cho nhau. Vậy khi muốn thay đổi như thế thì em phải thay dòng lệnh nào, vì em không biết lisp nên có dow 2 lisp Vc về để so sánh thì 2 lisp có cấu trúc khác nhau? Em có 1 lisp cũng được chỉnh sữa rồi cũng tương tự như lisp VC của Bác nhưng cái lisp của em thì nó vẫn bị ngược cột tọa độ X và Y. Mong nhận đuợc sự hồi âm sớm nhất của Bác!

Đây là lisp của em. Và tiện thể Bác có thể giải thích dùm em vì sao mà font chử Bảng Tọa Độ Góc Ranh nó bị lỗi không ạ, em dùng Font VIN.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;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 = 1) :"))  

 (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 num (rtos (car pv) 2 ntp) (rtos (cadr pv) 2 ntp) S)
     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 = 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;
)
;;;--------------------------

[tdvn 53]

Bác SSQ ơi cho em hỏi 1 chút, giữa lisp vc đầu và lisp vc sau có khác nhau 1 điểm là tọa độ cột X và cột Y được đổi chổ cho nhau. Vậy khi muốn thay đổi như thế thì em phải thay dòng lệnh nào, vì em không biết lisp nên có dow 2 lisp Vc về để so sánh thì 2 lisp có cấu trúc khác nhau? Em có 1 lisp cũng được chỉnh sữa rồi cũng tương tự như lisp VC của Bác nhưng cái lisp của em thì nó vẫn bị ngược cột tọa độ X và Y. Mong nhận đuợc sự hồi âm sớm nhất của Bác!

Đây là lisp của em. Và tiện thể Bác có thể giải thích dùm em vì sao mà font chử Bảng Tọa Độ Góc Ranh nó bị lỗi không ạ, em dùng Font VIN.

Mình Thấy font lisp trên chạy bình thường. Tuy nhiên, số hiệu điểm được đánh nhiều hơn gấp đôi số cần có. Ví dụ có 4 đỉnh thì nó đánh từ 1 đến 8 nên từ điểm 5 lại trùng với 1. Mình nghỉ, kg biết bạn xuandao có chỉnh gì kg, nếu đây là lisp trích từ nguồn cadviet, tác giả nên chịu khó chỉnh lại trường hợp số hiệu điểm trên. Còn việc đổi x thành y hay ngược lại kg có gì khó

[hoamaivang 0]

Tôi có tìm thấy trên cadviệt file lsp nói về toạ độ trong cad.

Tôi đã download về dùng, nhưng khi dùng, tôi có thêm một số ý thay doi, mong các bạn giúp đỡ:

 

- Bỏ điều kiện chạy độ dài các cạnh.

- Bảng toạ độ thể hiện như file đính kèm - sau_khi_chay_lsp.dwg, (block, thể hiện tiếng Việt).

 

http://www.cadviet.com/upfiles/3/du_lieu_bn_dau.dwg

http://www.cadviet.com/upfiles/3/sau_khi_chay_lsp.dwg

 

Mong som nhan duoc su giup do tu cac ban

[hoamaivang 0]

Tôi có tìm thấy trên cadviệt file lsp nói về toạ độ trong cad.

Tôi đã download về dùng, nhưng khi dùng, tôi có thêm một số ý thay doi, mong các bạn giúp đỡ:

 

- Bỏ điều kiện chạy độ dài các cạnh.

- Bảng toạ độ thể hiện như file đính kèm - sau_khi_chay_lsp.dwg, (block, thể hiện tiếng Việt).

 

http://www.cadviet.com/upfiles/3/du_lieu_bn_dau.dwg

http://www.cadviet.com/upfiles/3/sau_khi_chay_lsp.dwg

 

Mong som nhan duoc su giup do tu cac ban

:( :( :lol: :lol:

Ui, chưa ai giúp mình vậy?

[hoamaivang 0]

:( :( :lol: :lol:

Ui, chưa ai giúp mình vậy?

:( ui, dạo này anh chị em đi đâu hết rùi vậy nhỉ?

[phamthanhbinh 3.146]

:( ui, dạo này anh chị em đi đâu hết rùi vậy nhỉ?

Hề hề hề,

Tranh thủ lúc mọi người đi vắng, mình sửa cái lisp của bác SSG theo ý bạn. Bạn dùng thử coi và nếu thấy Ok thì đừng quên nhấn thank cám ơn bác ấy nghen.

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


;;;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
;;;Free utility - www.cadviet.com - September 2008 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;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) (* 3 h)) (+ (cadr p0) (* 1.5 h)))
   p2 (polar p1 0 (* 9 h))
   p3 (polar p2 0 (* 12 h))
   p4 (polar p3 0 (* 11 h))
   pL (list p1 p2 p3 p4)
   i 0
)
(repeat 4
   (wtxtMC (nth i txtL) (nth i pL) h)
   (setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
(defun txt2(txtL / p1 p2 p3 p4 pL i) ;;;Write texts in 1 row
(setq
   p1 (list (+ (car p0) (* 3 h)) (+ (cadr p0) (* 1.5 h)))
   p2 (polar p1 0 (* 9 h))
   p3 (polar p2 0 (* 12 h))
   p4 (polar p3 0 (* 11 h))
p4 (polar p4 (* 0.5 pi) (* 1.5 h))
   pL (list p1 p2 p3 p4)
   i 0
)
(repeat 4
   (wtxtMC (nth i txtL) (nth i pL) h)
   (setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:VC( / h p et p0 p00 p01 p02 pt pvL n j pv num txtL ss bn)
;;;Vertex Co-ordinate
(command "undo" "be")
;;;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))

;;;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 (list (car p00) (- (cadr p00) (* 3 h)))
   p01 (polar p00 (* 0.5 pi) (* h 3))
   pvL (reverse (getvert et))
n (length pvL)
p02 (polar p01 (* 1.5 pi) (* (+ n 2) h 3))
   oldos (getvar "osmode")
)
(setvar "osmode" 0)

;;;HEADER
(linepx p0 (* 40 h))
(command "copy" "L" "" "m" p0 p01 p02 "")
(linepx (list (+ (car p00) (* 6 h)) (cadr p00)) (* 24 h))
(linepy p01 (* (+ n 2) -3 h))
(command "copy" "L" "" "m" p0 
   (list(+ (car p0) (* 6 h)) (cadr p0))
   ;;;;(list(+ (car p0) (* 16 h)) (cadr p0))
   (list(+ (car p0) (* 30 h)) (cadr p0))
   (list(+ (car p0) (* 40 h)) (cadr p0))
""
)
(linepy (list (+ (car p0) (* 18 h)) (+ (cadr p0) (* 3 h))) (* (1+ n) -3 h))
(wtxtMC "BANG LIET KE TOA DO GOC RANH" (list (+ (car p00) (* 20 h)) (+ (cadr p00) (* 6 h))) (* 1.5 h))
(wtxtMC "So hieu" (list (+ (car p00) (* 3 h)) (+ (cadr p00) h)) h)
(wtxtMC "diem" (list (+ (car p00) (* 3 h)) (- (cadr p00) h)) h)
(wtxtMC "S (m)" (list (+ (car p00) (* 35 h)) (cadr p00)) h)
(wtxtMC "TOA DO" (list (+ (car p00) (* 18 h)) (+ (cadr p00) (* 1.5 h))) h)
(txt1 (list " " "X (m)" "Y (m)" " "))
(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))) (setq S ""))
   (setq txtL (list num (rtos (cadr pv)) (rtos (car pv)) S))
   (txt2 txtL)
   (setq p0 (polar p0 (* 1.5 pi) (* 3 h)))
(setq pt pv)
   (setq j (1+ j))
(if (= j (- n 1)) (setq j 0))
)

;;;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- n)
   (setq
       pv (nth j pvL)
       num (itoa (1+ j))
   )
   (wtxtMC num (polar pv 0 h) h)
   (setq j (1+ j))
)
;;;FINISH
(setvar "osmode" oldos)
(command "undo" "e")
(princ)
)
;;;-------------------------------------------------------------------------------

Chúc bạn vui và nhớ đến CADVIET.

[hoamaivang 0]

Cảm ơn anh Bình đã bớt chút thời gian giúp em,

A BÌnh vui lòng kiểm tra lại dùm em chút, vì khi chay líp đó, vẫn không thấy thể hiện tiếng việt?

(mình có thể mặc định trong lisp tiếng việt kiểu Time new Roman được không anh?)

Em gửi kết quả, em chạy từ líp của anh nhé.

Mong sơm nhận được phản hồi của anh.

http://www.cadviet.com/upfiles/3/toado3.png

Chỉnh sửa Tháng 8 3, 2011 theo hoamaivang

[hoamaivang 0]

Cảm ơn anh Bình đã bớt chút thời gian giúp em,

A BÌnh vui lòng kiểm tra lại dùm em chút, vì khi chay líp đó, vẫn không thấy thể hiện tiếng việt?

(mình có thể mặc định trong lisp tiếng việt kiểu Time new Roman được không anh?)

Em gửi kết quả, em chạy từ líp của anh nhé.

Mong sơm nhận được phản hồi của anh.

http://www.cadviet.com/upfiles/3/toado3.png

[phamthanhbinh 3.146]

Cảm ơn anh Bình đã bớt chút thời gian giúp em,

A BÌnh vui lòng kiểm tra lại dùm em chút, vì khi chay líp đó, vẫn không thấy thể hiện tiếng việt?

(mình có thể mặc định trong lisp tiếng việt kiểu Time new Roman được không anh?)

Em gửi kết quả, em chạy từ líp của anh nhé.

Mong sơm nhận được phản hồi của anh.

http://www.cadviet.c...es/3/toado3.png

Hề hề hề,

Trước hết xin lỗi bạn vì lâu không trả lời. Thực ra yêu cầu của bạn với mình cũng khá là khó do không rành lắm về font tiếng Việt.

Sau khi tìm hiểu thì thấy hình như cái yêu cầu của bạn không thực hiện được do font Time New Romans này không hỗ trợ tiếng Việt khi dùng unikey thì phải.

Mày mò một hồi thì mình thấy có thể sử dụng font khác để hiển thị tiếng Việt trong Cad. Vì vậy nếu bạn chấp nhận thì mình sẽ thử xem sao.

Chúc bạn vui....

[vunguyenchan 0]

Quá hay.nhưng có bạn nào sửa lại dùm mình chút nha.chạy tọa độ và ghi chiều dài cạnh thì đwowjc rồi.mà mình chỉ muốn ghi 3 số ở phần sau dấu chấm ở phần tọa độ.và hai số ở phần ghi khoảng cách.nếu co thể ghi thêm dòng BẢNG GHI TỌA ĐỘ VN 2000 càng tốt.mình có mấy lisp nhwng toàn chạy ngwowjc chiều kim đồng hồ.Xin nhờ swj giúp đỡ của các bạn.mail mình là nmk.081985@yahoo.com.vn http://www.cadviet.com/upfiles/3/105707_2_1.dwg

[phamthanhbinh 3.146]

Quá hay.nhưng có bạn nào sửa lại dùm mình chút nha.chạy tọa độ và ghi chiều dài cạnh thì đwowjc rồi.mà mình chỉ muốn ghi 3 số ở phần sau dấu chấm ở phần tọa độ.và hai số ở phần ghi khoảng cách.nếu co thể ghi thêm dòng BẢNG GHI TỌA ĐỘ VN 2000 càng tốt.mình có mấy lisp nhwng toàn chạy ngwowjc chiều kim đồng hồ.Xin nhờ swj giúp đỡ của các bạn.mail mình là nmk.081985@yahoo.com.vn http://www.cadviet.com/upfiles/3/105707_2_1.dwg

 

Hề hề hề,

Nhắc bạn lần sau không được post 3 bài liên tiếp có nội dung giống nhau như vậy. Nếu bạn còn tiếp tục như vậy sẽ bị xóa tất cả các bài post đó.

về uê cầu của bạn có thể làm như sau:

1/- Thay dòng chữ bạn muốn vào đoạn code:

(wtxtMC "BANG LIET KE TOA DO GOC RANH"

2/- Thay đoạn code: (setq S (rtos (distance pt pv))Thành (setq S (rtos (distance pt pv) 2 2)

3/- Thay đoạn code:(list num (rtos (cadr pv)) (rtos (car pv))Thành(list num (rtos (cadr pv) 2 3) (rtos (car pv) 2 3)

Chúc bạn vui.

[vunguyenchan 0]

thanks.phamthanhbinh.

[vunguyenchan 0]

MÌNH LÀM NHƯ BẠN RỒI.PHẦN DƯỚI THÌ OK.NHUNG MÌNH SỬA LẠI THÀNH BẢNG LIỆT KÊ TOẠ ĐỘ VN2000 THÌ ĐOẠN CODE KHÔNG HIỂU CÁCH BỎ DẤU.TOÀN BÁO LỖI.XIN KHÔNG ĐÁNH ĐƯỢC CHỮ CÓ DẤU. BẠN HỔ TRỢ LẠI DÙM MÌNH.THANHKS.

[cs2 0]

 

Chương trình hôm nọ vẽ bảng gọi là "cho vui" thôi, chỉ có thể dùng với các bảng ngắn ngắn, số lượng dữ liệu ít. Trường hợp của bạn số lượng dữ liệu khá nhiều. Cách thức bài bản hơn là xuất tọa độ các điểm cũng như tên điểm sang Excel, sau đó tùy ý xử lý và insert lại vào Cad. Cách này có ưu điểm nổi bật là bạn có thể dùng các công cụ Excel để xử lý dữ liệu cho nhiều mục đích khác nhau.

Tên lệnh là EP (Export Points). Sau khi export, chương trình sẽ tự khởi động Excel và open file.

 

Các điểm lưu ý:

- Text ghi thứ tự điểm phải có tọa độ x, y (của điểm insert) trùng với x, y của point (có thể khác z). Nếu không, chương trình tìm không thấy text sẽ mặc định gán số thứ tự là 0! Bản vẽ bạn gởi có vài điểm như vậy.

- Lisp không có khả năng can thiệp vào cầu trúc file của *.xls. Mặc dù lưu ở dạng *.xls nhưng bản chất của nó vẫn là text file, các field được phân biệt bằng 1 dấu tab. Tuy vậy, trình Excel vẫn hiểu và open được loại file này.

- Khi save, Excel sẽ hỏi "Do you want keep the workbook in this format?”. Nếu bạn muốn file được chuyển thành “*.xls thật sự” thì phải trả lời “No”, sau đó save đè lên file có hiện có là xong.

 

;;;**********************************************************;;;This program export coordinate of points and ordinal numbers to Excel;;;Each ordinal number must be the same x, y as correlative point_;;;otherwise it is assigned "0" value.;;;The file save as *.xls but data structure still are text file.;;;If you want convert them to actual *.xls file, when save Excel ask:_;;;"Do you want keep the workbook in this format?", you must answer "No".;;;Written by Ssg - December 2007 - www.cadviet.com;;;**********************************************************;;;--------------------------------------------------------------------(defun ss2Lp(ssp / Lp i e p) ;;;Convert ss of points to list of 3Dpoints(setq i 0 Lp nil)(repeat (sslength ssp)     (setq        e (ssname ssp i)        p (cdr (assoc 10 (entget e)))        Lp (append Lp (list p))        i (1+ i)    ))Lp);;;-------------------------------------------------------------------------------(defun C:EP(/ ssp Lp Ld fn f p sst txt rec L1) ;;;Export Points(setq    ssp (ssget '((0 . "POINT")))    Lp (ss2Lp ssp)    Ld nil    fn (getfiled "title" "" "xls" 1)    f (open fn "w"))(princ "TT\tX\tY\tZ" f)(foreach p Lp    (if (setq sst (ssget "x" (list (cons 0 "TEXT") (cons -4 "=,=,*") (cons 10 p))))        (setq txt (cdr (assoc 1 (entget (ssname sst 0)))))        (setq txt "0")    )    (setq        rec (cons (atoi txt) p)        Ld (append Ld (list rec))    ))(setq Ld (vl-sort Ld '(lambda (x y) (< (car x) (car y)))))(foreach L1 Ld    (princ (strcat "\n" (rtos (car L1)) "\t" (rtos (cadr L1)) "\t"                        (rtos (caddr L1)) "\t" (rtos (cadddr L1))) f) )(close f)(alert "Finish export! Program will start Excel and open data file...")(command "start" (strcat "excel " fn))  );;;-------------------------------------------------------------------------------

bác ssg ơi. nhờ bác hướng dẫn kỹ hơn chút xíu. em cài xong rồi, sử dụng lệnh ep rồi, rồi làm sao nữa bác? mong bác chỉ dùm cho.

[love cad 0]

các bác ơi! giúp với.

em st được 1 lisp xuất tọa độ rất ok nhưng nó chạy ngược kim đồng hồ! bác nào sửa dùm em tí cho nó chạy cheo chiều kim đồng hồ nhé.

em cám ơn thật nhiều.http://www.cadviet.com/upfiles/3/66250_hsle.lsp

[phamthanhbinh 3.146]

các bác ơi! giúp với.

em st được 1 lisp xuất tọa độ rất ok nhưng nó chạy ngược kim đồng hồ! bác nào sửa dùm em tí cho nó chạy cheo chiều kim đồng hồ nhé.

em cám ơn thật nhiều.http://www.cadviet.com/upfiles/3/66250_hsle.lsp

 

Hề hề hề,

Không down được lisp. Bạn nên post nó vào trang upload khác và gửi đường link lên đây. Trang upload của diễn đàn dạo này bì lỗi nhiều lắm.

[love cad 0]

Đây bác ạ.

Bác giúp dùm em nhé.

Cảm ơn nhìu.

http://www.mediafire.com/download/gnfy7bnrb9chv3c/hsle.LSP

[nhoclangbat 392]

- ái chà, cái lsp này y chang lsp ở cơ quan nhoc ko khác 1 tẹo, khác mỗi cái tên lệnh ^^, còn nguồn gốc ai viết thì nhoc ko pit, chỉ pit từ khi đi làm đã có sẵn rùi.

- bạn có thể ghé thăm topic http://www.cadviet.com/forum/topic/111130-listp-bang-toa-do-vn2000/

- cũng có bạn yêu cầu, nhoc cũng lấy cái lsp này đăng lên nhưng bạn đó mún sữa đi xíu nữa, nhoc cũng mới sữa xong có phần chọn lựa thuận hay ngược chiều đồng hồ, bạn thử xem sao ^^

P/s: nhoc đang PR sản phẩm mới edit cần nhận xét, các anh đừng ném gạch nhoc hen :P

[love cad 0]

Mình đã thử rồi, ko hiểu sao mình hay bị lỗi "ban chua chon dung dinh thua dat\nban chay lai lenh tu dau hen thong cam ^^!!".

Lỗi này trong 1 thửa đất khi chọn đỉnh thửa này bị lỗi đỉnh kia không lỗi, có trường hợp 3 đỉnh bị lỗi còn 1 đỉnh chọn được. có trường hợp các đỉnh phía Bắc bị lỗi còn phía Nam chọn được!

ko biết mình làm sai thủ thuật hay lsp còn chưa hoàn thiện bạn xem giúp mình tí nữa nhé.

Mình thì cần pick các đỉnh thửa phía Bắc trước.

thanks.

[nhoclangbat 392]

- hi thank bạn đã test hộ nhoc, nói thật với bản đầu tiên nhoc sữa thì nhoc cũng hay gặp lỗi như bạn, nên nhoc cố chỉnh lại, sau đó có test 5 6 lần với nhiều trường hợp thấy ko lỗi nữa nên nhoc mới post lên, ko ngờ vẫn còn lỗi ^^, nhoc cũng nghi nghi là nó còn thiếu gì đó, cũng mong mấy a đi ngang xem nhộ nhoc nó sót chỗ nào, cái bảng báo lỗi đó là nhoc viết để thông báo người dùng trường hợp bạn pick 1 điểm ko thuộc khu đất, ai ngờ pick trúng mà vẫn bị báo ^^.

- để nhoc xem kỹ lại  điều kiện kiểm tra dữ liệu đầu vào có lỗi gì ko.

- có gì bạn qua topic bên kia theo dõi hộ nhoc hen ^^.

P/s: anh PTB có ghé ngang rãnh xem bắt lỗi hộ nhoc với ^^, cái lsp này hơi dài nên có khi nhoc chưa kiểm soát đc hết  :P

[thanhduan2407 272]

Nhoclangbat đưa code lên đây đi. Hay là code ở....trang kia?