Đến nội dung


Hình ảnh
- - - - -

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


  • Please log in to reply
100 replies to this topic

#61 phongks82

phongks82

    biết zoom

  • Members
  • Pip
  • 12 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 04 November 2008 - 03:34 PM

chào anh . em rất cần lisp này nhưng em không chạy được . anh lam ơn chỉ từng bước và lệnh chạy cho em nha. CHúc anh vui và thành công trong công việc
  • 0

#62 phongks82

phongks82

    biết zoom

  • Members
  • Pip
  • 12 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 07 November 2008 - 10:33 PM

[quote name='ssg' date='Nov 1 2008, 9:05' post='39485']
Không phải nhiêu khê như vậy, các bạn xem ở đây, cực kỳ đơn giản:

http://www.cadviet.c...showtopic=1787"

Tóm lại một cách ngắn gọn:
1. Copy code trên diễn đàn, mở trình Notepad (trình soạn thảo văn bản đơn giản, luôn luôn có sẵn trên máy khi cài đặt Windows) paste vào, save as dạng *.lsp (tên file * đặt tuỳ ý thích)
2. Trong Acad, gõ lệnh appload, chỉ định file *.lsp nói trên và bấm Load - Close. Nếu việc load thành công, Acad sẽ báo "*.lsp successfully loaded". Nếu muốn AutoCAD tự động load lisp khi khởi động, dùng Startup Suite như đã hướng dẫn trong link trên.
3. Tên lệnh của lisp, nếu tác giả không nói rõ là các ký tự nằm kề liền sau (defun C:
Cụ thể, với đoạn chương trình lập bảng toạ độ của ssg là VC. Sau đó, chương trình yêu cầu cái gì thì đáp ứng cái ấy.

Good luck!

Chào anh SSG em chẳng hiểu em làm sai ở đâu mà khi làm theo yêu cầu của anh vẫn thông báo ở dòng lệnh là Unknown command "VC". Press F1 for help. mặc dù em không làm sai bước nào theo hướng dẫn của anh cả. Nhưng có điều này em không hiếu tại sao copy code trên diễn đàn về paste vào Notepad thì code không sắp xếp theo trình tự như anh viết trên diễn đàn mà nó tạo thành 1 hàng ngang liền mạch. Em sợ lỗi này cho nên tại dòng lệnh không hiểu.Có cách nào khắc phục điều này không anh . ANh chỉ giùm em nha. Mong nhận được sự hồi âm của anh . CHúc anh mạnh khỏe và thành đạt trong cuộc sống.
  • 0

#63 chuot8x_online

chuot8x_online

    Chưa sử dụng CAD

  • Members
  • Pip
  • 3 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 08 November 2008 - 12:17 AM

Lisp có đủ 4 yêu cầu trên:


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


;;;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) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 8 h))
p3 (polar p2 0 (* 12 h))
p4 (polar p3 0 (* 10 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) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 8 h))
p3 (polar p2 0 (* 12 h))
p4 (polar p3 0 (* 10 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

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

;;;HEADER
(linepx p0 (* 38 h))
(command "copy" "L" "" "m" p00 p01 p02 "")
(linepy p0 (* (+ n 1) -3 h))
(command "copy" "L" "" "m" p0
(list(+ (car p0) (* 4 h)) (cadr p0))
(list(+ (car p0) (* 16 h)) (cadr p0))
(list(+ (car p0) (* 28 h)) (cadr p0))
(list(+ (car p0) (* 38 h)) (cadr p0))
""
)

(txt1 (list "TT" "X (m)" "Y (m)" "S (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)
(princ)
)
;;;-------------------------------------------------------------------------------



Góp ý:
Nếu có nhờ ai viết lisp, bạn nên nêu rõ và đủ các yêu cầu ngay từ đầu. Làm lần đầu không ngại nhưng sửa đi sửa lại... ngán lắm!




Rất cảm ơn bác SSG đã nhiệt tình giúp đỡ. Nhưng E có một yêu cầu nhỏ nữa được không ạ? trả là lisp của bác kết quả trả về tọa độ x,y là 4 số thập phân sau dấu phẩy, vậy muốn nó chỉ 1 hoặc 2 hoặc 3 số thập phân thôi thì phải làm thế nào ạ?
  • 0

#64 ssg

ssg

    biết lệnh adcenter

  • Vip
  • PipPipPipPipPipPipPip
  • 1228 Bài viết
Điểm đánh giá: 1087 (rất tốt)

Đã gửi 08 November 2008 - 02:08 PM

Chào anh SSG em chẳng hiểu em làm sai ở đâu mà khi làm theo yêu cầu của anh vẫn thông báo ở dòng lệnh là Unknown command "VC". Press F1 for help. mặc dù em không làm sai bước nào theo hướng dẫn của anh cả. Nhưng có điều này em không hiếu tại sao copy code trên diễn đàn về paste vào Notepad thì code không sắp xếp theo trình tự như anh viết trên diễn đàn mà nó tạo thành 1 hàng ngang liền mạch. Em sợ lỗi này cho nên tại dòng lệnh không hiểu.Có cách nào khắc phục điều này không anh . ANh chỉ giùm em nha. Mong nhận được sự hồi âm của anh . CHúc anh mạnh khỏe và thành đạt trong cuộc sống.


Nếu gặp trường hợp paste vào Notepad bị như trên, bạn paste vào Word cũng được, nhớ chọn canh lề bên trái, nó sẽ sắp xếp y như bạn thấy trên diễn đàn. Bấm saveas, trong hộp "File name" gõ đủ tên file và phần loại .lsp, trong hộp "Save as type" chọn "Plain text (*.txt). Sau đó, trình Word có hỏi gì cũng mặc nó, cứ bấm OK bạn sẽ có file *.lsp
Đó là nói chung cho những lần sau, còn lần này bạn có thể download trực tiếp file lsp từ đây:

http://www.cadviet.c.../BangToaDo2.zip
  • 0

#65 ssg

ssg

    biết lệnh adcenter

  • Vip
  • PipPipPipPipPipPipPip
  • 1228 Bài viết
Điểm đánh giá: 1087 (rất tốt)

Đã gửi 08 November 2008 - 02:10 PM

Rất cảm ơn bác SSG đã nhiệt tình giúp đỡ. Nhưng E có một yêu cầu nhỏ nữa được không ạ? trả là lisp của bác kết quả trả về tọa độ x,y là 4 số thập phân sau dấu phẩy, vậy muốn nó chỉ 1 hoặc 2 hoặc 3 số thập phân thôi thì phải làm thế nào ạ?

Trình lisp không liên quan đến việc ấy, nó theo thiết lập Units trong bản vẽ của bạn. Bạn dùng lệnh Units, trong Precision chọn mấy số thập phân tuỳ ý thích.
  • 0

#66 cadcadcad

cadcadcad

    Chưa sử dụng CAD

  • Members
  • Pip
  • 2 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 21 December 2008 - 07:46 AM

http://www.cadviet.c.../BangToaDo2.zip
Bác ơi em là dân địa chính. Bác viết L này tuyệt quá, em fải thank bác nhiều nhiều, Bác quả là siêu hiii, em vote bác làm Đại ca dẫn đầu. Thank thêm một lần nữa! từ nay em đỡ khổ rồi, vì em toàn dùng tay thôi, h có L này của bác em Công nghiệp đc rồi. Chúc bác luôn khoẻ
  • 0

#67 chuot8x_online

chuot8x_online

    Chưa sử dụng CAD

  • Members
  • Pip
  • 3 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 22 December 2008 - 11:14 PM

Trình lisp không liên quan đến việc ấy, nó theo thiết lập Units trong bản vẽ của bạn. Bạn dùng lệnh Units, trong Precision chọn mấy số thập phân tuỳ ý thích.


em đã thử nhưng ko dc bác ah!
  • 0

#68 ssg

ssg

    biết lệnh adcenter

  • Vip
  • PipPipPipPipPipPipPip
  • 1228 Bài viết
Điểm đánh giá: 1087 (rất tốt)

Đã gửi 23 December 2008 - 08:25 AM

em đã thử nhưng ko dc bác ah!

Hơi vô lý! Thôi được, bạn thử dùng cái này xem:

http://www.cadviet.c.../BangToaDo3.zip
  • 1

#69 chuot8x_online

chuot8x_online

    Chưa sử dụng CAD

  • Members
  • Pip
  • 3 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 07 January 2009 - 09:20 AM

Hơi vô lý! Thôi được, bạn thử dùng cái này xem:

http://www.cadviet.c.../BangToaDo3.zip



Cám ơn bác SSG nhiều nhiều! cái lisp này thì ok rồi quá tuyệt!
Chúc bác năm mới An Khang Thịnh Vượng! có nhiều đóng góp cho Diễn Đàn!!!!
  • 0

#70 dacvien2007

dacvien2007

    biết vẽ polygon

  • Members
  • PipPip
  • 75 Bài viết
Điểm đánh giá: 10 (tàm tạm)

Đã gửi 07 January 2009 - 09:51 AM

Nhờ anh giúp viết bổ sung cho lisp đánh toạ độ đỉnh thửa đất , nó thể hiện thêm các cạnh đến cm 0,00 m vào
các cạnh qua các đỉnh của hình thể thửa đất
Rất cám ơn và mong tin.

  • 0

#71 ssg

ssg

    biết lệnh adcenter

  • Vip
  • PipPipPipPipPipPipPip
  • 1228 Bài viết
Điểm đánh giá: 1087 (rất tốt)

Đã gửi 07 January 2009 - 03:48 PM

Nhờ anh giúp viết bổ sung cho lisp đánh toạ độ đỉnh thửa đất , nó thể hiện thêm các cạnh đến cm 0,00 m vào
các cạnh qua các đỉnh của hình thể thửa đất
Rất cám ơn và mong tin.

Không hiểu ý bạn là gì! Ssg rất "lơ mơ" về các khoản có dính đến chữ "địa" (trắc địa, địa chính, địa hình...). Bạn diễn đạt sao cho ssg hiểu, ssg sẽ giúp bạn nếu việc đó nằm trong khả năng.
Và như ssg đã phát biểu nhiều lần trên diễn đàn, file *.dwg minh hoạ tự nó sẽ nói lên nhiều điều, không cần giải thích dài dòng.
  • 0

#72 elleHCSC

elleHCSC

    biết lệnh copy

  • Members
  • PipPipPip
  • 119 Bài viết
Điểm đánh giá: 98 (tàm tạm)

Đã gửi 07 January 2009 - 04:03 PM

Không hiểu ý bạn là gì! Ssg rất "lơ mơ" về các khoản có dính đến chữ "địa" (trắc địa, địa chính, địa hình...). Bạn diễn đạt sao cho ssg hiểu, ssg sẽ giúp bạn nếu việc đó nằm trong khả năng.
Và như ssg đã phát biểu nhiều lần trên diễn đàn, file *.dwg minh hoạ tự nó sẽ nói lên nhiều điều, không cần giải thích dài dòng.


Khiếp bác Ssg sao lại sợ chữ "địa" thế, có gì đâu mà...cái mà Ssg sợ đúng hơn là sợ mọi người diễn đạt cho ssg không thấu đáo hết ý của họ muốn thôi mà...

đây là cái mẫu mà sẽ nhiều "ông" trắc địa sẽ hỏi xem làm sao dùng lisp mà được vầy...
http://www.cadviet.com/upfiles/HS.dwg

Vẫn dựa trên cái VC của ssg đã post trước đây, elleHCSC cũng đã thêm 1 chút vào cái VC của ssg để cho ra cái cạnh như ý của dacvien2007 hỏi nhưng chửa có xong..cuối năm bận quá, ssg chỉnh thêm nhé...

;;;------------------------------------------------------------------------------------
(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 (getTh))
(cons 1 S)
(cons 50 a)
(cons 41 0.7)
(cons 51 (DTR 18))
(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 (getTh))
(cons 1 S)
(cons 50 a)
(cons 41 0.7)
(cons 51 (DTR 18))
(cons 7 (getvar "textstyle"))
(cons 72 1)
(cons 11 p)
(cons 73 1)
)
)
)
)
;;;-------------------------------------------------------------------------------
(defun Ghicanh (e / h i pvL k p1 p2 dist rad x_mp y_mp mp)
(setq
h (getth)
i 0
pvL (reverse (getvert e))
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;
)
;;;-------------------------------------------------------------------------------

  • 0
Share for all, all will share !

--------------------
HTTP://WWW.HCSC.VN
HTTP://WWW.HCSC.COM.VN

#73 ssg

ssg

    biết lệnh adcenter

  • Vip
  • PipPipPipPipPipPipPip
  • 1228 Bài viết
Điểm đánh giá: 1087 (rất tốt)

Đã gửi 07 January 2009 - 05:30 PM

Ssg hiểu rồi, cám ơn bạn!
Đây là "chương trình hợp tác" Chào Mừng Năm Mới 2009 của ssg và elleHCSC. Các bạn dùng, check thử và cho ý kiến để hoàn thiện thêm:


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;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
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;WELCOME TO NEW YEAR 2009
;;;WISH ALL CADVIET MEMBERS AND FAMILY
;;;HAVE HAPPY, HEALTH AND PROSPEROUS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;




;;;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 (* 8 h))
p3 (polar p2 0 (* 12 h))
p4 (polar p3 0 (* 10 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) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 8 h))
p3 (polar p2 0 (* 12 h))
p4 (polar p3 0 (* 10 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 ntp)
;;;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))

;;;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))

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

;;;HEADER
(linepx p0 (* 38 h))
(command "copy" "L" "" "m" p00 p01 p02 "")
(linepy p0 (* (+ n 1) -3 h))
(command "copy" "L" "" "m" p0
(list(+ (car p0) (* 4 h)) (cadr p0))
(list(+ (car p0) (* 16 h)) (cadr p0))
(list(+ (car p0) (* 28 h)) (cadr p0))
(list(+ (car p0) (* 38 h)) (cadr p0))
""
)

(txt1 (list "TT" "X (m)" "Y (m)" "S (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) 2 ntp)) (setq S ""))
(setq txtL (list num (rtos (cadr pv) 2 ntp) (rtos (car pv) 2 ntp) 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))
(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))
)

;;;GHI CANH THUA
(ghicanh et)
(command "erase" et "")

;;;FINISH
(setvar "osmode" oldos)
(princ)
)
;;;-------------------------------------------------------------------------------



;;;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 51 (DTR 18))
(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 51 (DTR 18))
(cons 7 (getvar "textstyle"))
(cons 72 1)
(cons 11 p)
(cons 73 1)
)
)
)
)
;;;-------------------------------------------------------------------------------
(defun Ghicanh (e / i pvL k p1 p2 dist rad x_mp y_mp mp)
(setq
i 0
pvL (reverse (getvert e))
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;
)
;;;--------------------------

  • 0

#74 thacvh

thacvh

    Chưa sử dụng CAD

  • Members
  • Pip
  • 3 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 19 March 2009 - 03:21 PM

Cảm ơn các bác đã chia sẻ tri thức của mình cho mọi người sử dụng. Mình cũng nhờ các bác mà giải quyết được một số vấn đề. Mình có 1 cái lisp dùng để ghi kích thứơc cạnh thửa đất trên bản đồ địa chinh liều mình gửi lên đây các bác xem sử dụng được không nhé, hiện tại mình đang sử dụng tốt.
(defun hhctd (pt bang dc / a ptm)
(command "ucs" "")
(setq a (/ (* bang 180) pi))
(setq ptm (list 0 dc))
(command "UCS" "O" pt)
(command "UCS" "z" a)
(setq ptm (trans ptm 1 0))
(command "UCS" "")
(setq ptm ptm)
)
(defun et( pt3 dcen ang dit ha / pp)
(setq pp (list (cons 0 "TEXT")(cons 8 "POLY")(cons 62 2)(cons 41 0.8)
(cons 51 0.0)(cons 7 "TXT")(cons 71 0)(cons 72 1)(cons 73 ha)
(cons 210 '(0.0 0.0 1.0))(cons 10 '(0.0 0.0))
(cons 11 pt3)(cons 40 dcen)(cons 1 dit)
(cons 50 ang)
))
(entmake pp)
)
(defun etm( pt3 dcen ang dit ha / pp)
(setq pp (list (cons 0 "TEXT")(cons 8 "POLY")(cons 62 50)(cons 41 0.8)
(cons 51 0.0)(cons 7 "TXT")(cons 71 0)(cons 72 1)(cons 73 ha)
(cons 210 '(0.0 0.0 1.0))(cons 10 '(0.0 0.0))
(cons 11 pt3)(cons 40 dcen)(cons 1 dit)
(cons 50 ang)
))
(entmake pp)
)
;;;;;;;;;;;;
(defun reierror (s)
(if (/= s "Function cancelled")
(princ (strcat "Error: " s))
)
(setq *error* olderr)
(close fp)
)
(defun c:gnha1( / ee l ll ss el n i pt1 pt2 )
(setq olderr *error* *error* rierror)
(setq ee nil ss ())
(setq dcen (getvar"dimcen"))
(setq dc (+ (* dcen 0.32) dcen) )
(setq ee (bpoly (getpoint"\nchon tam diem:")))
(setq rr ee)
(if (/= ee nil)
(progn
(setq ee (entnext ee))
(setq el (entget ee))
(setq l (cdr (assoc 0 el)))
(while (/= l "SEQEND")
(setq ll (cdr (assoc 10 el)))
(setq ll (list ll))
(setq ss (append ss ll))
(setq ee (entnext ee))
(setq el (entget ee))
(setq l (cdr (assoc 0 el)))
)
(setq ll (nth 0 ss))
(setq ll (list ll))
(setq ss (append ss ll))
(setq n (length ss))
(setq i 0)
(setq n (- n 1))
(while (< i n)
(setq ha 1)
(setq pt1 (nth i ss))
(setq pt2 (nth (+ i 1) ss))
(setq pt3 (pt_mid pt1 pt2))
(setq dit (rtos (distance pt1 pt2) 2 2))
(setq ang (angle pt1 pt2))
(setq bang ang)
(if (and (< ang 5.289) (> ang 2.08)) (progn
(setq ha 3)
(setq pt3 (hhctd pt3 ang dc))
);end progn
(progn
(setq pt3 (hhctd pt3 ang dcen))
);end progn
)
(if (> ang 4.71)(setq ang (- ang pi)))
(if (and (<= ang 4.71)(> ang 2.09))(setq ang (+ ang pi)))
(et pt3 dcen ang dit ha)
(setq i (+ i 1))
);end while
); end progn
);end if
(command "erase" rr "")
(redraw)
(setq ee nil ss ())
(Princ)
)
(defun c:gnha( / ee l ll ss el n i pt1 pt2 )
(setq olderr *error* *error* rierror)
(setq ee nil ss ())
(setq dcen (getvar"dimcen"))
(setq dc (* dcen 0.32))
(setq ee (bpoly (getpoint"\nchon tam diem:")))
(setq rr ee)
(if (/= ee nil)
(progn
(setq ee (entnext ee))
(setq el (entget ee))
(setq l (cdr (assoc 0 el)))
(while (/= l "SEQEND")
(setq ll (cdr (assoc 10 el)))
(setq ll (list ll))
(setq ss (append ss ll))
(setq ee (entnext ee))
(setq el (entget ee))
(setq l (cdr (assoc 0 el)))
)
(setq ll (nth 0 ss))
(setq ll (list ll))
(setq ss (append ss ll))
(setq n (length ss))
(setq i 0)
(setq n (- n 1))
(while (< i n)
(setq ha 1)
(setq pt1 (nth i ss))
(setq pt2 (nth (+ i 1) ss))
(setq pt3 (pt_mid pt1 pt2))
(setq dit (rtos (distance pt1 pt2) 2 2))
(setq ang (angle pt1 pt2))
(setq bang ang)
(if (and (< ang 5.289) (> ang 2.08)) (progn
(setq ha 3)
(setq pt3 (hhctd pt3 ang dc))
);end progn
)
(if (> ang 4.71)(setq ang (- ang pi)))
(if (and (<= ang 4.71)(> ang 2.09))(setq ang (+ ang pi)))
(et pt3 dcen ang dit ha)
(setq i (+ i 1))
);end while
); end progn
);end if
(command "erase" rr "")
(redraw)
(setq ee nil ss ())
(Princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun taolp ( pt / ee l ll ss el n)
(setq ee nil ss ())
(setq ee (bpoly pt))
(setq rr ee)
(if (/= ee nil)
(progn
(setq ee (entnext ee))
(setq el (entget ee))
(setq l (cdr (assoc 0 el)))
(while (/= l "SEQEND")
(setq ll (cdr (assoc 10 el)))
(setq ll (list ll))
(setq ss (append ss ll))
(setq ee (entnext ee))
(setq el (entget ee))
(setq l (cdr (assoc 0 el)))
)
(setq ll (nth 0 ss))
(setq ll (list ll))
(command "erase" rr "")
(setq ss (append ss ll))
); end progn
(setq ss nil)
);end if
)


(defun c:GKT1()
;;; (c:txt)
(setq olderr *error* *error* rierror)
(setq dem 0)
(setq dcen (getvar "DIMCEN"))
(setq ppt1 (getpoint "\nChon goc duoi: "))
(setq ppt2 (getcorner ppt1 "\nChon goc tren: "))
(setq $$19 (ssget "c" ppt1 ppt2 (list (cons 0 "LINE"))))
(setq l (sslength $$19))
(setq i 0)
(repeat l
(setq ss (ssname $$19 i))
(setq assolist (entget ss))
(setq pt1 (cdr (assoc 10 assolist)))
(setq pt2 (cdr (assoc 11 assolist)))
(setq pt3 (pt_mid pt1 pt2))
(setq dit (rtos (distance pt1 pt2) 2 2))
(setq ang (angle pt1 pt2))
(if (> ang 4.71)(setq ang (- ang pi)))
(if (and (<= ang 4.71)(> ang 2.09))(setq ang (+ ang pi)))
(etm pt3 dcen ang dit 1)
(setq i (1+ i))
)
(setq $$19 nil)
(command "insert" "gr" pt1 (/ dcen 3) "" "")
(command "insert" "gr" pt2 (/ dcen 3) "" "")
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; HAM TRA VE GIA TRI MID CUA HAI DIEM;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun pt_mid( pt1 pt2 / x1 x2 y1 y2 x3 y3 pt3)
(setq x1 (car pt1) y1 (cadr pt1))
(setq x2 (car pt2) y2 (cadr pt2))
(setq x3 (+ x1 (/ (- x2 x1) 2 )))
(setq y3 (+ y1 (/ (- y2 y1) 2 )))
(setq pt3 (list x3 y3))
)
(princ)
  • 0

#75 tnmtpc

tnmtpc

    biết dimcontinue

  • Members
  • PipPipPipPipPip
  • 370 Bài viết
Điểm đánh giá: 206 (khá)

Đã gửi 19 March 2009 - 04:08 PM

Cảm ơn các bác đã chia sẻ tri thức của mình cho mọi người sử dụng. Mình cũng nhờ các bác mà giải quyết được một số vấn đề. Mình có 1 cái lisp dùng để ghi kích thứơc cạnh thửa đất trên bản đồ địa chinh liều mình gửi lên đây các bác xem sử dụng được không nhé, hiện tại mình đang sử dụng tốt.

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!
  • 0

#76 thacvh

thacvh

    Chưa sử dụng CAD

  • Members
  • Pip
  • 3 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 23 March 2009 - 10:15 AM

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.c...pfiles/gkt1.dwg
  • 1

#77 tnmtpc

tnmtpc

    biết dimcontinue

  • Members
  • PipPipPipPipPip
  • 370 Bài viết
Điểm đánh giá: 206 (khá)

Đã gửi 23 March 2009 - 07:49 PM

http://www.cadviet.c...pfiles/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
  • 0

#78 thanhtri2301

thanhtri2301

    Chưa sử dụng CAD

  • Members
  • Pip
  • 1 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 01 January 2010 - 11:27 PM

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 " "") )
)
)
  • 0

#79 thanhgam2003

thanhgam2003

    biết vẽ ellipse

  • Members
  • PipPip
  • 55 Bài viết
Điểm đánh giá: 1 (bình thường)

Đã gửi 05 January 2010 - 10:28 AM

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

#80 xuandao0708

xuandao0708

    biết lệnh scale

  • Members
  • PipPipPip
  • 140 Bài viết
Điểm đánh giá: 8 (bình thường)

Đã gửi 07 January 2010 - 10:24 PM

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;
)
;;;--------------------------

  • 0