Đến nội dung


Hình ảnh
* - - - - 1 Bình chọn

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


  • Please log in to reply
27 replies to this topic

#1 Truong_AAn

Truong_AAn

    biết dimradius

  • Members
  • PipPipPipPipPip
  • 314 Bài viết
Điểm đánh giá: 68 (tàm tạm)

Đã gửi 12 May 2012 - 03:06 PM

Nguyên văn yêu cầu giúp này mình lấy từ inbox của mình đươc gửi từ bạn boycodonxxxx. Vì mình không rành về lisp nên đưa qua đây mong các bạn giúp bạn boycodonxxxx nhé. Chắc bạn ấy chưa rành cách viết bài trên diễn đàn anh em thông cảm
em có cái lisp xuất tọa độ này nhưng mà nó lại chạy ngược chiều kim đồng hồ, em muốn nó chạy số thứ tự theo cùng chiều kim đồng hồ. Nếu anh biết thì giúp em vói nha. thank anh nhiều.
các bước thực hiện xuất bảng tọa độ trong auto lisp:
đầu tiên vẽ một hình kín bất kỳ, sau đó dùng lệnh "Bo" để bo lại. tiếp theo dùng lệnh xxx, nó hỏi "Text the hien tren ban ve ty le: (500)minh nhấn enter luôn, tiếp theo nhấn phím B, tiếp đến nhấn phím T rồi chọn vào hình vùa bo, nó hỏi có khép vòng không thì nhấn C. cuối cùng thì pick vào vị trí đặt bảng tọa độ.
đây là code lisp:

Dưới đây là đoạn code auto lisp.


;================GHI DU LIEU=====================
(defun C:XXx (/ kt r s s1 s2 s3 n h hd f pt TileBd)
(setq old (getvar "OSMODE"))
;(setq text (getvar "TEXTSTYLE"))
(setvar "OSMODE" 1)
;(setvar "TEXTSTYLE" "Vnariahb")
(command "UNDO" "BE" "")
(setq r (getvar "USERR1"))
(if (= r 0) (setq r 500))
(setq TileBd (getint (strcat "\nText the hien tren ban ve ty le (" (rtos r 2 0) "):")))
(if (= TileBd nil) (setq TileBd r))
(setvar "USERR1" TileBd)
(setq h (* (/ TileBd 1000.0) 1.5) hd (/ h 2.2))
(setq kt (getstring "\nXuat so lieu ra file(F) hay ban ve( ? <B>:"))
(if (= kt nil) (setq kt "F"))
(if (= "F" (strcase kt))
(output1 h)
(progn
(setq kt (getstring "\nChon diem(D) hay doi tuong(T) ? :"))
(if (= kt nil) (setq kt "D"))
(if (= "D" (strcase kt)) (output2 h hd) (output3 h hd))
)
)
(setvar "textstyle" oldtext)
(setvar "cmdecho" 1)
)
===============XUAT RA FILE======================
(defun output1 (h / ktra s s1 s2 s3 n f pt)
(grclear)
(command "undo" "be")
(setq oldOsmode (getvar "osmode"))
(setvar "osmode" 1)
(setvar "cmdecho" 0)
(setq LayerOld (getvar "clayer"))
(if (null (tblsearch "layer" "text_mia"))
(command "_layer" "m" "text_mia" ""))
(command "_layer" "s" "text_mia" "")
(command "_layer" "c" "50" "text_mia" "")
(setq ktra (getstring "\nCo the hien mia len ban ve khong ? :"))
(if (= ktra "") (setq ktra "C"))
;(if (= "C" (strcase ktra)) (setq h (getreal "\nNhap chieu cao text: ")))
(setq s (findfile "XY.dat"))
(setq f (open s "w"))
(setq n 0)
(princ "\nBan chon diem mia theo thu tu tang dan. Nhan ENTER de tiep tuc!")
(getstring)
(if f (write-line " &#167;i&#211;m X(m) Y(m)" f))
(if f (write-line " " f))
(if f
(progn
(while (/= (setq pt (getpoint "\nPick diem: ")) nil)
(setq n (1+ n) s1 (rtos n 2 0)
s3 (rtos (car pt) 2 3)
s2 (rtos (cadr pt) 2 3))
(setq s1 (trinhbay s1 9)
s2 (trinhbay s2 16)
s3 (trinhbay s3 16))
(write-line (strcat s1 s2 s3) f)
(if (= "C" (strcase ktra))
(progn
(command "text" pt h 0 (strcat " " (rtos n 2 0)))
(setvar "osmode" 0)
(command "line" (list (- (car pt) (/ h 4.0)) (cadr pt) 0)
(list (+ (car pt) (/ h 4.0)) (cadr pt) 0) "")
(command "line" (list (car pt) (- (cadr pt) (/ h 4.0)) 0)
(list (car pt) (+ (cadr pt) (/ h 4.0)) 0) "")
(setvar "osmode" 1)
)
)
);while
(close f)
);progn
(princ (strcat "Khong tim ra hoac khong mo duoc file " s))
);if
(setvar "osmode" oldOsmode)
(setvar "clayer" layerOld)
(princ)
)
===============XUAT RA MAN HINH=================
(defun output2 (h hd / khep yesno dem s s0 s1 s2 s3 ss i n pt pt0 p kt)
(grclear)
(setq oldosmode (getvar "osmode"))
(setvar "osmode" 1)
(command "undo" "be")
(setq LayerOld (getvar "clayer"))
;(setq h (getreal "\nNhap chieu cao text: "))
(setq i 0 n 0 dem 0 pt0 nil)
(if (null (tblsearch "layer" "Sohieu"))
(command "_layer" "m" "Sohieu" "")
(progn
(setq ss (ssget "x" '((8 . "ToadoXY"))))
(command "erase" ss "")
(setq ss (ssget "x" '((8 . "Sohieu"))))
(command "erase" ss "")
(command "regen")
)
)
(while (/= (setq pt (getpoint "\nPick diem: ")) nil)
(if (= dem 0) (setq khep pt))
(if (/= pt0 nil) (setq kt (rtos (distance pt0 pt) 2 2)))
(if (null (tblsearch "layer" "Sohieu"))
(command "_layer" "m" "Sohieu" ""))
(command "_layer" "s" "Sohieu" "")
(command "_layer" "c" "7" "Sohieu" "")
;(if (and (< n 90) (equal i 0))
; (progn
; (setq n (1+ n) s1 (chr n))
; (command "text" pt h 0 (strcat " " s1))
; (command "donut" 0 hd pt "")
; )
; (progn
; (if (>= n 90) (setq n 64 i (1+ i)))
; (setq n (1+ n) s1 (strcat (chr n) (rtos i 2 0)))
; (command "text" pt h 0 (strcat " " s1))
; (command "donut" 0 hd pt "")
; )

(setq n (1+ n) s1 (strcat " " (rtos n 2 0)))
(command "text" pt h 0 s1)
(command "donut" 0 hd pt "")
(setq pt0 pt
s3 (rtos (car pt) 2 3)
s2 (rtos (cadr pt) 2 3)
s0 " To&#185; &#167;&#233; VN-2000 "
s "&#167;i&#211;m X (m) Y (m) C&#185;nh (m)")
(setvar "osmode" 0)
(if (null (tblsearch "layer" "ToadoXY"))
(command "_layer" "m" "ToadoXY" ""))
(command "_layer" "s" "ToadoXY" "")
(command "_layer" "c" "7" "ToadoXY" "")
(command "_layer" "off" "ToadoXY" "y" "")
(command "text" "j" "br" (list 1 (* dem (/ -5 3.0)) 0) 1 0 s1)
(command "text" "j" "br" (list (/ 36 3) (* dem (/ -5 3.0)) 0) 1 0 s2)
(command "text" "j" "br" (list (/ 70 3) (* dem (/ -5 3.0)) 0) 1 0 s3)
;(command "text" "j" "bl" (list (/ 112.0 3) (* dem (/ -5 3.0)) 0) 1 0 )
(if (/= pt0 nil)
(command "text" "j" "br" (list (/ 96 3) (* (- dem 0.5) (/ -5 3.0)) 0) 1 0 kt)
)
(setvar "osmode" 1)
(setq dem (1+ dem))
);while
(setq yesno (strcase (getstring "\nCo khep diem khong (C/K)? :")))
(if (= yesno "") (setq yesno "C"))
(setvar "osmode" 0)
(if (= yesno "C")
(progn
(setq kt (rtos (distance khep pt0) 2 2))
(command "text" "j" "br" (list 1 (* dem (/ -5 3.0)) 0) 1 0 " 1")
(command "text" "j" "br" (list (/ 96 3) (* (- dem 0.5) (/ -5 3.0)) 0) 1 0 kt)
(setq dem (1+ dem))
)
)
(setq dem (1+ dem))
(command "rectang" (list -2 5.5 0) (list 35.5 (+ 3 (* dem (/ -5 3.0))) 0))
(command "line" (list 2.65 5.5 0) (list 2.65 (+ 3 (* dem (/ -5 3.0))) 0) "")
(command "line" (list 13.5 5.5 0) (list 13.5 (+ 3 (* dem (/ -5 3.0))) 0) "")
(command "line" (list 24.5 5.5 0) (list 24.5 (+ 3 (* dem (/ -5 3.0))) 0) "")
;(command "line" (list 35.5 5.5 0) (list 35.5 (+ 3 (* dem (/ -5 3.0))) 0) "")
(command "line" (list -2 2.5 0) (list 35.5 2.5 0) "")
(command "text" "j" "bl" (list -1.5 6.5 0) 2 0 s0)
(command "text" "j" "bl" (list -1.5 3 0) 1 0 s)
(setvar "clayer" layerOld)
(setvar "osmode" 1)
(setq p (getpoint "\nChon diem chen bang liet ke toa do:"))
(setvar "osmode" 0)
(setq ss (ssget "x" '((8 . "ToadoXY"))))
(command "move" ss "" (list -2.0 (+ 3 (* dem (/ -5 3.0))) 0) p)
(command "scale" ss "" p h)
(command "_layer" "on" "ToadoXY" "")
(setvar "osmode" oldosmode)
(command "undo" "e")
(princ)
)
;;;=============CLICK VAO LAYER==================
(defun output3 (h hd / kyhieu stt dem ss s s0 s1 s2 s3 i j n pt pt0 p kt yesno)
(grclear)
(setq oldcmdecho (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq oldosmode (getvar "osmode"))
(setvar "osmode" 0)
(command "undo" "be")
(setq LayerOld (getvar "clayer"))
(setq i 0 n 0 dem 0)
;(setq h (getreal "\nNhap chieu cao text: "))
(if (tblsearch "layer" "ToadoXY")
(progn
(setq ss (ssget "x" '((8 . "ToadoXY"))))
(command "erase" ss "")
(setq ss (ssget "x" '((8 . "Sohieu"))))
(command "erase" ss "")
(command "regen")
)
(progn
(command "_layer" "m" "Sohieu" "m" "ToadoXY" "")
(command "_layer" "c" "7" "Sohieu" "c" "7" "ToadoXY" "")
)
)

(setq j 0 pt0 nil kyhieu "" stt 0 khep nil kt nil)
(princ "\nChon doi tuong")
(setq oldob (entget (car (entsel))))
(while (< j (length oldob))
(if (or (= (car (nth j oldob)) 10)
(= (car (nth j oldob)) 11))
(progn
(setq pt (cdr (nth j oldob)) stt (1+ stt))
(if (/= pt0 nil) (setq kt (rtos (distance pt0 pt) 2 2)))
(command "_layer" "s" "Sohieu" "")
(if (or (/= (equal khep pt) T) (= stt 1))
;(if (and (< n 90) (equal i 0))
; (progn
; (setq n (1+ n) s1 (chr n))
; (command "text" pt h 0 (strcat " " s1))
; (command "donut" 0 hd pt "")
; (princ khep) (princ pt)
; )
; (progn
; (if (>= n 90) (setq n 64 i (1+ i)))
; (setq n (1+ n) s1 (strcat (chr n) (rtos i 2 0)))
; (command "text" pt h 0 (strcat " " s1))
; (command "donut" 0 hd pt "")
; )

(progn
(setq n (1+ n) s1 (strcat " " (rtos n 2 0)))
(command "text" pt h 0 s1)
(command "donut" 0 hd pt "")
)
)
(if (= pt0 nil) (setq kyhieu s1 khep pt))
(setq pt0 pt
s3 (rtos (car pt) 2 3)
s2 (rtos (cadr pt) 2 3)
s0 " To&#185; &#167;&#233; VN-2000 "
s "&#167;i&#211;m X (m) Y (m) C&#185;nh (m)")
(command "_layer" "s" "ToadoXY" "off" "ToadoXY" "Y" "")
(command "text" "j" "br" (list (/ 96 3) (* (- dem 0.5) (/ -5 3.0)) 0) 1 0 kt)
(if (and (= (equal khep pt) T) (> stt 1))
(command "text" "j" "br" (list 1 (* dem (/ -5 3.0)) 0) 1 0 kyhieu)
(command "text" "j" "br" (list 1 (* dem (/ -5 3.0)) 0) 1 0 s1)
)
(command "text" "j" "br" (list (/ 36 3) (* dem (/ -5 3.0)) 0) 1 0 s2)
(command "text" "j" "br" (list (/ 70 3) (* dem (/ -5 3.0)) 0) 1 0 s3)
;(command "text" "j" "bl" (list (/ 112.0 3) (* dem (/ -5 3.0)) 0) 1 0 )
(if (/= pt0 nil)
(command "text" "j" "br" (list (/ 96 3) (* (- dem 0.5) (/ -5 3.0)) 0) 1 0 kt)
)
(setq dem (1+ dem))
);progn
);if
(setq j (1+ j))
);while
(setq yesno (strcase (getstring "\nCo khep diem khong (C/K)? :")))
(if (= yesno "") (setq yesno "C"))

(setvar "osmode" 0)
(if (= yesno "C")
(progn
(setq kt (rtos (distance khep pt0) 2 2))
(command "text" "j" "br" (list 1 (* dem (/ -5 3.0)) 0) 1 0 " 1")
(command "text" "j" "br" (list (/ 96 3) (* (- dem 0.5) (/ -5 3.0)) 0) 1 0 kt)
(setq dem (1+ dem))
)
)
(setq dem (1+ dem))
(command "rectang" (list -2 5.5 0) (list 35.5 (+ 3 (* dem (/ -5 3.0))) 0))
(command "line" (list 2.65 5.5 0) (list 2.65 (+ 3 (* dem (/ -5 3.0))) 0) "")
(command "line" (list 13.5 5.5 0) (list 13.5 (+ 3 (* dem (/ -5 3.0))) 0) "")
(command "line" (list 24.5 5.5 0) (list 24.5 (+ 3 (* dem (/ -5 3.0))) 0) "")
;(command "line" (list 35.5 5.5 0) (list 35.5 (+ 3 (* dem (/ -5 3.0))) 0) "")
(command "line" (list -2 2.5 0) (list 35.5 2.5 0) "")
(command "text" "j" "bl" (list -1.5 6.5 0) 2 0 s0)
(command "text" "j" "bl" (list -1.5 3 0) 1 0 s)
(setvar "clayer" layerOld)
(setvar "osmode" 1)

(setq p (getpoint "\nChon diem chen bang liet ke toa do:"))
(setvar "osmode" 0)
(setq ss (ssget "x" '((8 . "ToadoXY"))))
(command "move" ss "" (list -2.0 (+ 3 (* dem (/ -5 3.0))) 0) p)
(command "scale" ss "" p h)
(command "_layer" "on" "ToadoXY" "")
(setvar "osmode" oldosmode)
(command "undo" "e")
(princ)
)

  • 0
Hình đã gửi
----------------------------------------------------------------------------------//-------------------------------------------------------------------------------------

#2 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5682 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 12 May 2012 - 03:41 PM

Bạn cũng chưa rành về nội quy box yêu cầu viết - sửa lisp ?
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#3 Truong_AAn

Truong_AAn

    biết dimradius

  • Members
  • PipPipPipPipPip
  • 314 Bài viết
Điểm đánh giá: 68 (tàm tạm)

Đã gửi 12 May 2012 - 03:46 PM

Bạn cũng chưa rành về nội quy box yêu cầu viết - sửa lisp ?

Mình tham gia diễn đàn cũng mời được hơn tháng nên thật sự cũng chưa rành không biết đưa code vào tutorial thế nào cả có gì ketxu hướng dẫn thêm và giúp bạn kia sửa lisp nha thnk
  • 0
Hình đã gửi
----------------------------------------------------------------------------------//-------------------------------------------------------------------------------------

#4 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5682 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 12 May 2012 - 03:57 PM

Có hết ở chữ ký của mình đó bạn ạ :)
P/s : k có cad, mình đọc qua thấy hình như lisp chạy theo thứ tự điểm lúc vẽ, k liên quan đến chiều quay cả ?
  • 1

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#5 Doan Van Ha

Doan Van Ha

    biết lệnh adcenter

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 5448 Bài viết
Điểm đánh giá: 2624 (tuyệt vời)

Đã gửi 12 May 2012 - 04:05 PM

Nguyên văn yêu cầu giúp này mình lấy từ inbox của mình đươc gửi từ bạn boycodonxxxx. Vì mình không rành về lisp nên đưa qua đây mong các bạn giúp bạn boycodonxxxx nhé. Chắc bạn ấy chưa rành cách viết bài trên diễn đàn anh em thông cảm
em có cái lisp xuất tọa độ này nhưng mà nó lại chạy ngược chiều kim đồng hồ, em muốn nó chạy số thứ tự theo cùng chiều kim đồng hồ. Nếu anh biết thì giúp em vói nha. thank anh nhiều.
các bước thực hiện xuất bảng tọa độ trong auto lisp:
đầu tiên vẽ một hình kín bất kỳ, sau đó dùng lệnh "Bo" để bo lại. tiếp theo dùng lệnh xxx, nó hỏi "Text the hien tren ban ve ty le: (500)minh nhấn enter luôn, tiếp theo nhấn phím B, tiếp đến nhấn phím T rồi chọn vào hình vùa bo, nó hỏi có khép vòng không thì nhấn C. cuối cùng thì pick vào vị trí đặt bảng tọa độ.
đây là code lisp:

Bạn Truong_AAn: ngoài chuyện không cho vào thể code thì bạn còn mắc thêm 1 lỗi nữa là đặt tiêu đề topic không đúng.
Sửa cho bạn boycodonxxxx đây. Lần sau có hỏi gì thì cứ post lên CV, chứ không cần nhắn tin đâu boycodonxxxx nhé (trừ những trường hợp quá đặc biệt), vì CV là trí tuệ tập thể.

(defun C:XXx (/ kt r s s1 s2 s3 n h hd f pt TileBd)
(setq old (getvar "OSMODE"))
;(setq text (getvar "TEXTSTYLE"))
(setvar "OSMODE" 1)
;(setvar "TEXTSTYLE" "Vnariahb")
(command "UNDO" "BE" "")
(setq r (getvar "USERR1"))
(if (= r 0) (setq r 500))
(setq TileBd (getint (strcat "\nText the hien tren ban ve ty le (" (rtos r 2 0) "):")))
(if (= TileBd nil) (setq TileBd r))
(setvar "USERR1" TileBd)
(setq h (* (/ TileBd 1000.0) 1.5) hd (/ h 2.2))
(setq kt (getstring "\nXuat so lieu ra file(F) hay ban ve( ? <B>:"))
(if (= kt nil) (setq kt "F"))
(if (= "F" (strcase kt))
(output1 h)
(progn
(setq kt (getstring "\nChon diem(D) hay doi tuong(T) ? :"))
(if (= kt nil) (setq kt "D"))
(if (= "D" (strcase kt)) (output2 h hd) (output3 h hd))
)
)
(setvar "textstyle" oldtext)
(setvar "cmdecho" 1)
)
===============XUAT RA FILE======================
(defun output1 (h / ktra s s1 s2 s3 n f pt)
(grclear)
(command "undo" "be")
(setq oldOsmode (getvar "osmode"))
(setvar "osmode" 1)
(setvar "cmdecho" 0)
(setq LayerOld (getvar "clayer"))
(if (null (tblsearch "layer" "text_mia"))
(command "_layer" "m" "text_mia" ""))
(command "_layer" "s" "text_mia" "")
(command "_layer" "c" "50" "text_mia" "")
(setq ktra (getstring "\nCo the hien mia len ban ve khong ? :"))
(if (= ktra "") (setq ktra "C"))
;(if (= "C" (strcase ktra)) (setq h (getreal "\nNhap chieu cao text: ")))
(setq s (findfile "XY.dat"))
(setq f (open s "w"))
(setq n 0)
(princ "\nBan chon diem mia theo thu tu tang dan. Nhan ENTER de tiep tuc!")
(getstring)
(if f (write-line " &#167;i&#211;m X(m) Y(m)" f))
(if f (write-line " " f))
(if f
(progn
(while (/= (setq pt (getpoint "\nPick diem: ")) nil)
(setq n (1+ n) s1 (rtos n 2 0)
s3 (rtos (car pt) 2 3)
s2 (rtos (cadr pt) 2 3))
(setq s1 (trinhbay s1 9)
s2 (trinhbay s2 16)
s3 (trinhbay s3 16))
(write-line (strcat s1 s2 s3) f)
(if (= "C" (strcase ktra))
(progn
(command "text" pt h 0 (strcat " " (rtos n 2 0)))
(setvar "osmode" 0)
(command "line" (list (- (car pt) (/ h 4.0)) (cadr pt) 0)
(list (+ (car pt) (/ h 4.0)) (cadr pt) 0) "")
(command "line" (list (car pt) (- (cadr pt) (/ h 4.0)) 0)
(list (car pt) (+ (cadr pt) (/ h 4.0)) 0) "")
(setvar "osmode" 1)
)
)
);while
(close f)
);progn
(princ (strcat "Khong tim ra hoac khong mo duoc file " s))
);if
(setvar "osmode" oldOsmode)
(setvar "clayer" layerOld)
(princ)
)
===============XUAT RA MAN HINH=================
(defun output2 (h hd / khep yesno dem s s0 s1 s2 s3 ss i n pt pt0 p kt)
(grclear)
(setq oldosmode (getvar "osmode"))
(setvar "osmode" 1)
(command "undo" "be")
(setq LayerOld (getvar "clayer"))
;(setq h (getreal "\nNhap chieu cao text: "))
(setq i 0 n 0 dem 0 pt0 nil)
(if (null (tblsearch "layer" "Sohieu"))
(command "_layer" "m" "Sohieu" "")
(progn
(setq ss (ssget "x" '((8 . "ToadoXY"))))
(command "erase" ss "")
(setq ss (ssget "x" '((8 . "Sohieu"))))
(command "erase" ss "")
(command "regen")
)
)
(while (/= (setq pt (getpoint "\nPick diem: ")) nil)
(if (= dem 0) (setq khep pt))
(if (/= pt0 nil) (setq kt (rtos (distance pt0 pt) 2 2)))
(if (null (tblsearch "layer" "Sohieu"))
(command "_layer" "m" "Sohieu" ""))
(command "_layer" "s" "Sohieu" "")
(command "_layer" "c" "7" "Sohieu" "")
;(if (and (< n 90) (equal i 0))
; (progn
; (setq n (1+ n) s1 (chr n))
; (command "text" pt h 0 (strcat " " s1))
; (command "donut" 0 hd pt "")
; )
; (progn
; (if (>= n 90) (setq n 64 i (1+ i)))
; (setq n (1+ n) s1 (strcat (chr n) (rtos i 2 0)))
; (command "text" pt h 0 (strcat " " s1))
; (command "donut" 0 hd pt "")
; )

(setq n (1+ n) s1 (strcat " " (rtos n 2 0)))
(command "text" pt h 0 s1)
(command "donut" 0 hd pt "")
(setq pt0 pt
s3 (rtos (car pt) 2 3)
s2 (rtos (cadr pt) 2 3)
s0 " To&#185; &#167;&#233; VN-2000 "
s "&#167;i&#211;m X (m) Y (m) C&#185;nh (m)")
(setvar "osmode" 0)
(if (null (tblsearch "layer" "ToadoXY"))
(command "_layer" "m" "ToadoXY" ""))
(command "_layer" "s" "ToadoXY" "")
(command "_layer" "c" "7" "ToadoXY" "")
(command "_layer" "off" "ToadoXY" "y" "")
(command "text" "j" "br" (list 1 (* dem (/ -5 3.0)) 0) 1 0 s1)
(command "text" "j" "br" (list (/ 36 3) (* dem (/ -5 3.0)) 0) 1 0 s2)
(command "text" "j" "br" (list (/ 70 3) (* dem (/ -5 3.0)) 0) 1 0 s3)
;(command "text" "j" "bl" (list (/ 112.0 3) (* dem (/ -5 3.0)) 0) 1 0 )
(if (/= pt0 nil)
(command "text" "j" "br" (list (/ 96 3) (* (- dem 0.5) (/ -5 3.0)) 0) 1 0 kt)
)
(setvar "osmode" 1)
(setq dem (1+ dem))
);while
(setq yesno (strcase (getstring "\nCo khep diem khong (C/K)? :")))
(if (= yesno "") (setq yesno "C"))
(setvar "osmode" 0)
(if (= yesno "C")
(progn
(setq kt (rtos (distance khep pt0) 2 2))
(command "text" "j" "br" (list 1 (* dem (/ -5 3.0)) 0) 1 0 " 1")
(command "text" "j" "br" (list (/ 96 3) (* (- dem 0.5) (/ -5 3.0)) 0) 1 0 kt)
(setq dem (1+ dem))
)
)
(setq dem (1+ dem))
(command "rectang" (list -2 5.5 0) (list 35.5 (+ 3 (* dem (/ -5 3.0))) 0))
(command "line" (list 2.65 5.5 0) (list 2.65 (+ 3 (* dem (/ -5 3.0))) 0) "")
(command "line" (list 13.5 5.5 0) (list 13.5 (+ 3 (* dem (/ -5 3.0))) 0) "")
(command "line" (list 24.5 5.5 0) (list 24.5 (+ 3 (* dem (/ -5 3.0))) 0) "")
;(command "line" (list 35.5 5.5 0) (list 35.5 (+ 3 (* dem (/ -5 3.0))) 0) "")
(command "line" (list -2 2.5 0) (list 35.5 2.5 0) "")
(command "text" "j" "bl" (list -1.5 6.5 0) 2 0 s0)
(command "text" "j" "bl" (list -1.5 3 0) 1 0 s)
(setvar "clayer" layerOld)
(setvar "osmode" 1)
(setq p (getpoint "\nChon diem chen bang liet ke toa do:"))
(setvar "osmode" 0)
(setq ss (ssget "x" '((8 . "ToadoXY"))))
(command "move" ss "" (list -2.0 (+ 3 (* dem (/ -5 3.0))) 0) p)
(command "scale" ss "" p h)
(command "_layer" "on" "ToadoXY" "")
(setvar "osmode" oldosmode)
(command "undo" "e")
(princ)
)
;;;=============CLICK VAO LAYER==================
(defun output3 (h hd / kyhieu stt dem ss s s0 s1 s2 s3 i j n pt pt0 p kt yesno)
(grclear)
(setq oldcmdecho (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq oldosmode (getvar "osmode"))
(setvar "osmode" 0)
(command "undo" "be")
(setq LayerOld (getvar "clayer"))
(setq i 0 n 0 dem 0)
;(setq h (getreal "\nNhap chieu cao text: "))
(if (tblsearch "layer" "ToadoXY")
(progn
(setq ss (ssget "x" '((8 . "ToadoXY"))))
(command "erase" ss "")
(setq ss (ssget "x" '((8 . "Sohieu"))))
(command "erase" ss "")
(command "regen")
)
(progn
(command "_layer" "m" "Sohieu" "m" "ToadoXY" "")
(command "_layer" "c" "7" "Sohieu" "c" "7" "ToadoXY" "")
)
)

(setq j 0 pt0 nil kyhieu "" stt 0 khep nil kt nil)
(princ "\nChon doi tuong")
;------------------------------------------------------------------------
(setq oldob (entget (car (entsel))))

(setq oldob1 oldob oldob nil)
(foreach n oldob1
(if (or (= (car n) 10) (= (car n) 11))
(setq oldob (cons n oldob))))
(setq oldob (reverse oldob))
(setq oldob (cons (car oldob) (reverse (cdr oldob))))

(while (< j (length oldob))
(if (or (= (car (nth j oldob)) 10)
(= (car (nth j oldob)) 11))
(progn
(setq pt (cdr (nth j oldob)) stt (1+ stt))
(if (/= pt0 nil) (setq kt (rtos (distance pt0 pt) 2 2)))
(command "_layer" "s" "Sohieu" "")
(if (or (/= (equal khep pt) T) (= stt 1))
;(if (and (< n 90) (equal i 0))
; (progn
; (setq n (1+ n) s1 (chr n))
; (command "text" pt h 0 (strcat " " s1))
; (command "donut" 0 hd pt "")
; (princ khep) (princ pt)
; )
; (progn
; (if (>= n 90) (setq n 64 i (1+ i)))
; (setq n (1+ n) s1 (strcat (chr n) (rtos i 2 0)))
; (command "text" pt h 0 (strcat " " s1))
; (command "donut" 0 hd pt "")
; )

(progn
(setq n (1+ n) s1 (strcat " " (rtos n 2 0)))
(command "text" pt h 0 s1)
(command "donut" 0 hd pt "")
)
)
(if (= pt0 nil) (setq kyhieu s1 khep pt))
(setq pt0 pt
s3 (rtos (car pt) 2 3)
s2 (rtos (cadr pt) 2 3)
s0 " To&#185; &#167;&#233; VN-2000 "
s "&#167;i&#211;m X (m) Y (m) C&#185;nh (m)")
(command "_layer" "s" "ToadoXY" "off" "ToadoXY" "Y" "")
(command "text" "j" "br" (list (/ 96 3) (* (- dem 0.5) (/ -5 3.0)) 0) 1 0 kt)
(if (and (= (equal khep pt) T) (> stt 1))
(command "text" "j" "br" (list 1 (* dem (/ -5 3.0)) 0) 1 0 kyhieu)
(command "text" "j" "br" (list 1 (* dem (/ -5 3.0)) 0) 1 0 s1)
)
(command "text" "j" "br" (list (/ 36 3) (* dem (/ -5 3.0)) 0) 1 0 s2)
(command "text" "j" "br" (list (/ 70 3) (* dem (/ -5 3.0)) 0) 1 0 s3)
;(command "text" "j" "bl" (list (/ 112.0 3) (* dem (/ -5 3.0)) 0) 1 0 )
(if (/= pt0 nil)
(command "text" "j" "br" (list (/ 96 3) (* (- dem 0.5) (/ -5 3.0)) 0) 1 0 kt)
)
(setq dem (1+ dem))
);progn
);if
(setq j (1+ j))
);while
(setq yesno (strcase (getstring "\nCo khep diem khong (C/K)? :")))
(if (= yesno "") (setq yesno "C"))

(setvar "osmode" 0)
(if (= yesno "C")
(progn
(setq kt (rtos (distance khep pt0) 2 2))
(command "text" "j" "br" (list 1 (* dem (/ -5 3.0)) 0) 1 0 " 1")
(command "text" "j" "br" (list (/ 96 3) (* (- dem 0.5) (/ -5 3.0)) 0) 1 0 kt)
(setq dem (1+ dem))
)
)
(setq dem (1+ dem))
(command "rectang" (list -2 5.5 0) (list 35.5 (+ 3 (* dem (/ -5 3.0))) 0))
(command "line" (list 2.65 5.5 0) (list 2.65 (+ 3 (* dem (/ -5 3.0))) 0) "")
(command "line" (list 13.5 5.5 0) (list 13.5 (+ 3 (* dem (/ -5 3.0))) 0) "")
(command "line" (list 24.5 5.5 0) (list 24.5 (+ 3 (* dem (/ -5 3.0))) 0) "")
;(command "line" (list 35.5 5.5 0) (list 35.5 (+ 3 (* dem (/ -5 3.0))) 0) "")
(command "line" (list -2 2.5 0) (list 35.5 2.5 0) "")
(command "text" "j" "bl" (list -1.5 6.5 0) 2 0 s0)
(command "text" "j" "bl" (list -1.5 3 0) 1 0 s)
(setvar "clayer" layerOld)
(setvar "osmode" 1)

(setq p (getpoint "\nChon diem chen bang liet ke toa do:"))
(setvar "osmode" 0)
(setq ss (ssget "x" '((8 . "ToadoXY"))))
(command "move" ss "" (list -2.0 (+ 3 (* dem (/ -5 3.0))) 0) p)
(command "scale" ss "" p h)
(command "_layer" "on" "ToadoXY" "")
(setvar "osmode" oldosmode)
(command "undo" "e")
(princ)
)

  • 1

* Chỉ nên yêu cầu Lisp khi bạn làm việc đó mất cả ngày nhưng họ chỉ viết 1 giờ. Đừng nêu yêu cầu Lisp khi bạn chỉ làm 1 giờ nhưng bắt họ phải mất cả ngày.

* Nhờ viết lisp cũng như đi khám bệnh. Chỉ gởi căn cước và than sắp chết thì không bác sỹ nào cứu sống được.


#6 boycdon160483

boycdon160483

    biết zoom

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

Đã gửi 12 May 2012 - 05:11 PM

Cảm ơn tất cả các bạn, các anh!
Cảm ơn bạn Truong_AAn, anh ketxu, anh Doan Van Ha.
Chúc mọi người nhiều sức khỏe và thành công trong cuộc sống!
  • 0

#7 ro88

ro88

    biết vẽ arc

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

Đã gửi 27 September 2012 - 04:57 PM

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)


;; 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&#219;NG TO&#207;A &#209;O&#196; GO&#217;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;
)
;;;--------------------------



Mong sớm được các bạn quan tâm giúp đỡ.Thanks

http://www.cadviet.c...ke_toa_do_1.dwg
  • 0

#8 hoangkimoanh

hoangkimoanh

    biết vẽ spline

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

Đã gửi 27 September 2012 - 07:31 PM

code nguyên bản ở đây do anh ketxu tập hợp.
nhờ các anh em giúp em sửa phần ghi kích thước cạnh là dim có điểm mút 2 đầu, để người kiểm tra file vẽ có thể kiểm tra người vẽ có sửa dim không vì dim này là text không phải là dim kích thước nên không có điểm mút 2 đầu. để kiểm tra phải thử đo kích thước lại để so sanh rất bất tiện!

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=13203&st=3100
;; free lisp from cadviet.com

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chuong trinh danh so va lap bang toa do ho so thua dat dia chinh
;;;Bang toa do tao thanh block, duoc dat ten theo so thu tu 1, 2, 3...
;;;Chap nhan cac doi tuong la Region, Polyline, Line va Arc khep kin
;;;Written by - January 2009 - www.cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;PUBLIC FUNCTIONS
;;;-------------------------------------------------------------------------------
(Defun DTR (x) (/ (* x pi) 180))
;;;change degree to radian, return REAL
;;;-------------------------------------------------------------------------------
(defun lineP (p0 a r / p1)
;;;Line polar: point, degree angle, radius
(setq p1 (polar p0 (dtr a) r))
(command "line" p0 p1 "")
)
;;;-------------------------------------------------------------------------------
(defun linePX (p0 x) (lineP p0 0 x))
;;;Horizontal line: length x, from p0
;;;-------------------------------------------------------------------------------
(defun linePY (p0 y) (lineP p0 90 y))
;;;Vertical line: length y, from p0
;;;-------------------------------------------------------------------------------
(defun getVert (e / i L)
;;;Return list of all vertex from pline e
(setq i 0
L nil
)
(vl-load-com)
(repeat (fix (+ (vlax-curve-getEndParam e) 1))
(setq L (append L (list (vlax-curve-getPointAtParam e i))))
(setq i (1+ i))
)
L
)

;;; First point of List rearrangement
(defun relist(pt0 Lst / i rt)
(setq i 0)
(foreach pt Lst
(if (equal pt0 pt 0.001)
(setq rt i))
(setq i (1+ i)))
(append (append (member (nth rt Lst) Lst)
(cdr (reverse (cdr (member (nth rt Lst) (reverse Lst))))))
(list (nth rt Lst)))
)

;;;New Layer
(defun newlayer(a b c d)
(if (not (tblsearch "layer" a))
(command "-layer" "n" a "c" b a "l" c a "lw" d a ""))
)
;;;-------------------------------------------------------------------------------
(defun wtxtMC (txt p h k)
;;;Write text Middle Center, specify text, point, height
(entmake (list (cons 0 "TEXT")
(cons 7 (getvar "textstyle"))
(cons 1 txt)
(cons 10 p)
(cons 11 p)
(cons 40 h)
(cons 72 1)
(cons 73 2)
(if k (cons 51 (DTR 18)) (cons 51 0))
)
)
)
;;;-------------------------------------------------------------------------------
(defun Collect (e / e2 SS)
;;;Selection set from e to entlast
(setq SS (ssadd))
(ssadd e SS)
(while (setq e2 (entnext e)) (ssadd e2 SS) (setq e e2))
SS
)
;;;-------------------------------------------------------------------------------
(defun Collect1 (e / ss)
;;;Selection set after e to entlast. If e nil, select all from fist entity of drawing.
(if (= e nil)
(setq ss (collect (entnext)))
(progn (setq ss (collect e)) (ssdel e ss))
)
)
;;;-------------------------------------------------------------------------------

;;;PRIVATE FUNCTIONS
;;;-------------------------------------------------------------------------------
(defun txt1 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
(setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 7 h))
p3 (polar p2 0 (* 10 h))
p4 (polar p3 0 (* 9 h))
pL (list p1 p2 p3 p4)
i 0
)
(repeat 4
(wtxtMC (nth i txtL) (nth i pL) h t)
(setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
(defun txt2 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
(setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 7 h))
p3 (polar p2 0 (* 10 h))
p4 (polar p3 0 (* 9 h))
p4 (polar p4 (* 0.5 pi) h)
pL (list p1 p2 p3 p4)
i 0
)
(repeat 4
(wtxtMC (nth i txtL) (nth i pL) h t)
(setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:HSKT (/ 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&#219;NG TO&#207;A &#209;O&#196; GO&#217;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 "erase" vtron "")
(setq j (1+ j))
)

;;;GHI CANH THUA
(setvar "CLAYER" "kichthuoc")
(ghicanh)

;;;FINISH
(savef)
(setvar "osmode" oldos)
;(setq pdau (getpoint "\nPick diem dau tien (so thu tu = 1) :"))
;;; )
(setvar "cmdecho" 1)
(princ)
)

;;;-------------------------------------------------------------------------------
(defun savef()
(if save
(progn
(setq file (open (setq tenfile (strcat (getvar "dwgprefix")
(vl-filename-base (vl-string-right-trim "\\" (getvar "dwgname"))) ".txt")) "a"))
(foreach line Lkqua
(setq line1 "")
(foreach it line
(setq line1 (strcat line1 " " it)))
(write-line line1 file)
)
(close file)
(princ (strcat "\nDa luu thanh file " tenfile))
)
)
)

;;;PHAN BO SUNG
;;;------------------------------------------------------------------------------------
(defun Text_canh_TCA (S p a )
;;;Entmake text S at p with angle A - Top Center
(if (/= p nil)
(entmake (list
(cons 0 "TEXT")
(cons 62 2)
(cons 10 p)
(cons 40 h)
(cons 1 S)
(cons 50 a )
(cons 41 0.7)
(cons 7 (getvar "textstyle"))
(cons 72 1)
(cons 11 p)
(cons 73 3)
)
)
)
)
;;;------------------------------------------------------------------------------------
(defun Text_canh_BCA (S p a )
;;;Entmake text S at p with angle A - Bottom Center
(if (/= p nil)
(entmake (list
(cons 0 "TEXT")
(cons 62 2)
(cons 10 p)
(cons 40 h)
(cons 1 S)
(cons 50 a )
(cons 41 0.7)
(cons 7 (getvar "textstyle"))
(cons 72 1)
(cons 11 p)
(cons 73 1)
)
)
)
)
;;;-------------------------------------------------------------------------------
(defun Ghicanh (/ i k p1 p2 dist rad x_mp y_mp mp)
(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

#9 ro88

ro88

    biết vẽ arc

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

Đã gửi 27 September 2012 - 09:09 PM

sao không thấy ai giúp dùm hết vậy? Nhờ mấy bạn giúp dùm với cảm ơn rất nhiều
  • 0

#10 ro88

ro88

    biết vẽ arc

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

Đã gửi 28 September 2012 - 06:06 PM

mãi mà chẳng thấy ai giúp hết vậy,có ai vui lòng giúp dùm mình với.
  • 0

#11 VoHoan

VoHoan

    biết lệnh move

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

Đã gửi 28 September 2012 - 08:25 PM

mãi mà chẳng thấy ai giúp hết vậy,có ai vui lòng giúp dùm mình với.

Mình chỉ sửa theo các ý của "ro88" và "hoangkimioanh" thôi, lisp chạy ra chắc chưa được đẹp lắm. Đế hoàn thiện hơn 2 ban nên nhờ trực tiếp bác "ketxu" nhé. Đây là lisp đã sửa:

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=63922&pid=199638&st=0&#entry199638
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=13203&st=3100
;; free lisp from cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chuong trinh danh so va lap bang toa do ho so thua dat dia chinh
;;;Bang toa do tao thanh block, duoc dat ten theo so thu tu 1, 2, 3...
;;;Chap nhan cac doi tuong la Region, Polyline, Line va Arc khep kin
;;;Written by - January 2009 - www.cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;PUBLIC FUNCTIONS
;;;-------------------------------------------------------------------------------
(Defun DTR (x) (/ (* x pi) 180))
;;;change degree to radian, return REAL
;;;-------------------------------------------------------------------------------
(defun lineP (p0 a r / p1)
;;;Line polar: point, degree angle, radius
(setq p1 (polar p0 (dtr a) r))
(command "line" p0 p1 "")
)
;;;-------------------------------------------------------------------------------
(defun linePX (p0 x) (lineP p0 0 x))
;;;Horizontal line: length x, from p0
;;;-------------------------------------------------------------------------------
(defun linePY (p0 y) (lineP p0 90 y))
;;;Vertical line: length y, from p0
;;;-------------------------------------------------------------------------------
(defun getVert (e / i L)
;;;Return list of all vertex from pline e
(setq i 0
L nil
)
(vl-load-com)
(repeat (fix (+ (vlax-curve-getEndParam e) 1))
(setq L (append L (list (vlax-curve-getPointAtParam e i))))
(setq i (1+ i))
)
L
)
;;; First point of List rearrangement
(defun relist(pt0 Lst / i rt)
(setq i 0)
(foreach pt Lst
(if (equal pt0 pt 0.001)
(setq rt i))
(setq i (1+ i)))
(append (append (member (nth rt Lst) Lst)
(cdr (reverse (cdr (member (nth rt Lst) (reverse Lst))))))
(list (nth rt Lst)))
)
;;;New Layer
(defun newlayer(a b c d)
(if (not (tblsearch "layer" a))
(command "-layer" "n" a "c" b a "l" c a "lw" d a ""))
)
;;;-------------------------------------------------------------------------------
(defun wtxtMC (txt p h k)
;;;Write text Middle Center, specify text, point, height
(entmake (list (cons 0 "TEXT")
(cons 7 (getvar "textstyle"))
(cons 1 txt)
(cons 10 p)
(cons 11 p)
(cons 40 h)
(cons 72 1)
(cons 73 2)
(if k (cons 51 (DTR 18)) (cons 51 0))
)
)
)
;;;-------------------------------------------------------------------------------
(defun Collect (e / e2 SS)
;;;Selection set from e to entlast
(setq SS (ssadd))
(ssadd e SS)
(while (setq e2 (entnext e)) (ssadd e2 SS) (setq e e2))
SS
)
;;;-------------------------------------------------------------------------------
(defun Collect1 (e / ss)
;;;Selection set after e to entlast. If e nil, select all from fist entity of drawing.
(if (= e nil)
(setq ss (collect (entnext)))
(progn (setq ss (collect e)) (ssdel e ss))
)
)
;;;-------------------------------------------------------------------------------
;;;PRIVATE FUNCTIONS
;;;-------------------------------------------------------------------------------
(defun txt1 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
(setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 7 h))
p3 (polar p2 0 (* 10 h))
p4 (polar p3 0 (* 9 h))
pL (list p1 p2 p3 p4)
i 0
)
(repeat 4
(wtxtMC (nth i txtL) (nth i pL) h t)
(setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
(defun txt2 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
(setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 7 h))
p3 (polar p2 0 (* 10 h))
p4 (polar p3 0 (* 9 h))
p4 (polar p4 (* 0.5 pi) h)
pL (list p1 p2 p3 p4)
i 0
)
(repeat 4
(wtxtMC (nth i txtL) (nth i pL) h t)
(setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:HSKT (/ 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:"))
(initget "T t N n")
(setq chieu (getkword "\nLua chon chieu ghi toa do < T/N >"))
(command "erase" et "")
(setq p0 p00
p01 (polar p00 (* 1.5 pi) (* h 3))
pvL (relist pdau pvL1)
n (length pvL)
p02 (polar p01 (* 1.5 pi) (+ (* h 3) (* (1- n) h 2)))
)
(setvar "osmode" 0)
;;;HEADER
(setvar "CLAYER" "bangtd")
(linepx p0 (* 32 h))
(command "copy" "L" "" "m" p00 p01 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 "Bang toa do cac dinh thua dat"
(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
(if (or (= chieu "N") (= chieu "n")) (setq pvL (reverse pvL)) )
(setq j 0
pt nil)
(repeat n
(setq
pv (nth j pvL)
num (itoa (1+ j))
num (strcat "M" num)
)
(if pt
(setq S (rtos (distance pt pv) 2 ntp))
(setq S "")
)
(setq
txtL (list num (rtos (car pv) 2 ntp) (rtos (cadr pv) 2 ntp) S)
Lkqua (append Lkqua (list txtL))
)
(txt2 txtL)
(setq 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))
num (strcat "M" num)
)
(wtxtMC num (polar pv 0 h) h t)
(command "circle" pv cr0)
(command "erase" vtron "")
(setq j (1+ j))
)
;;;GHI CANH THUA
(setvar "CLAYER" "kichthuoc")
(ghicanh)
;;;FINISH
(savef)
(setvar "osmode" oldos)
;(setq pdau (getpoint "\nPick diem dau tien (so thu tu = 1) :"))
;;; )
(setvar "cmdecho" 1)
(princ)
)
;;;-------------------------------------------------------------------------------
(defun savef()
(if save
(progn
(setq file (open (setq tenfile (strcat (getvar "dwgprefix")
(vl-filename-base (vl-string-right-trim "\\" (getvar "dwgname"))) ".txt")) "a"))
(foreach line Lkqua
(setq line1 "")
(foreach it line
(setq line1 (strcat line1 " " it)))
(write-line line1 file)
)
(close file)
(princ (strcat "\nDa luu thanh file " tenfile))
)
)
)
;;;PHAN BO SUNG
;;;------------------------------------------------------------------------------------
(defun Text_canh_TCA (S p a )
;;;Entmake text S at p with angle A - Top Center
(if (/= p nil)
(entmake (list
(cons 0 "TEXT")
(cons 62 2)
(cons 10 p)
(cons 40 h)
(cons 1 S)
(cons 50 a )
(cons 41 0.7)
(cons 7 (getvar "textstyle"))
(cons 72 1)
(cons 11 p)
(cons 73 3)
)
)
)
)
;;;------------------------------------------------------------------------------------
(defun Text_canh_BCA (S p a )
;;;Entmake text S at p with angle A - Bottom Center
(if (/= p nil)
(entmake (list
(cons 0 "TEXT")
(cons 62 2)
(cons 10 p)
(cons 40 h)
(cons 1 S)
(cons 50 a )
(cons 41 0.7)
(cons 7 (getvar "textstyle"))
(cons 72 1)
(cons 11 p)
(cons 73 1)
)
)
)
)
;;;-------------------------------------------------------------------------------
(defun Ghicanh (/ i k p1 p2 dist rad x_mp y_mp mp)
(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)
)
(command "DIMALIGNED" p1 p2 mp)
(setq i (1+ i))
)
;; repeat k;
)
;;;--------------------------

  • 1

#12 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5682 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 28 September 2012 - 08:58 PM

Lisp này bác SSG viết mà ^^
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#13 ro88

ro88

    biết vẽ arc

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

Đã gửi 28 September 2012 - 09:39 PM

Mình chỉ sửa theo các ý của "ro88" và "hoangkimioanh" thôi, lisp chạy ra chắc chưa được đẹp lắm. Đế hoàn thiện hơn 2 ban nên nhờ trực tiếp bác "ketxu" nhé. Đây là lisp đã sửa:


;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=63922&pid=199638&st=0&#entry199638
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=13203&st=3100
;; free lisp from cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chuong trinh danh so va lap bang toa do ho so thua dat dia chinh
;;;Bang toa do tao thanh block, duoc dat ten theo so thu tu 1, 2, 3...
;;;Chap nhan cac doi tuong la Region, Polyline, Line va Arc khep kin
;;;Written by - January 2009 - www.cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;PUBLIC FUNCTIONS
;;;-------------------------------------------------------------------------------
(Defun DTR (x) (/ (* x pi) 180))
;;;change degree to radian, return REAL
;;;-------------------------------------------------------------------------------
(defun lineP (p0 a r / p1)
;;;Line polar: point, degree angle, radius
(setq p1 (polar p0 (dtr a) r))
(command "line" p0 p1 "")
)
;;;-------------------------------------------------------------------------------
(defun linePX (p0 x) (lineP p0 0 x))
;;;Horizontal line: length x, from p0
;;;-------------------------------------------------------------------------------
(defun linePY (p0 y) (lineP p0 90 y))
;;;Vertical line: length y, from p0
;;;-------------------------------------------------------------------------------
(defun getVert (e / i L)
;;;Return list of all vertex from pline e
(setq i 0
L nil
)
(vl-load-com)
(repeat (fix (+ (vlax-curve-getEndParam e) 1))
(setq L (append L (list (vlax-curve-getPointAtParam e i))))
(setq i (1+ i))
)
L
)
;;; First point of List rearrangement
(defun relist(pt0 Lst / i rt)
(setq i 0)
(foreach pt Lst
(if (equal pt0 pt 0.001)
(setq rt i))
(setq i (1+ i)))
(append (append (member (nth rt Lst) Lst)
(cdr (reverse (cdr (member (nth rt Lst) (reverse Lst))))))
(list (nth rt Lst)))
)
;;;New Layer
(defun newlayer(a b c d)
(if (not (tblsearch "layer" a))
(command "-layer" "n" a "c" b a "l" c a "lw" d a ""))
)
;;;-------------------------------------------------------------------------------
(defun wtxtMC (txt p h k)
;;;Write text Middle Center, specify text, point, height
(entmake (list (cons 0 "TEXT")
(cons 7 (getvar "textstyle"))
(cons 1 txt)
(cons 10 p)
(cons 11 p)
(cons 40 h)
(cons 72 1)
(cons 73 2)
(if k (cons 51 (DTR 18)) (cons 51 0))
)
)
)
;;;-------------------------------------------------------------------------------
(defun Collect (e / e2 SS)
;;;Selection set from e to entlast
(setq SS (ssadd))
(ssadd e SS)
(while (setq e2 (entnext e)) (ssadd e2 SS) (setq e e2))
SS
)
;;;-------------------------------------------------------------------------------
(defun Collect1 (e / ss)
;;;Selection set after e to entlast. If e nil, select all from fist entity of drawing.
(if (= e nil)
(setq ss (collect (entnext)))
(progn (setq ss (collect e)) (ssdel e ss))
)
)
;;;-------------------------------------------------------------------------------
;;;PRIVATE FUNCTIONS
;;;-------------------------------------------------------------------------------
(defun txt1 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
(setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 7 h))
p3 (polar p2 0 (* 10 h))
p4 (polar p3 0 (* 9 h))
pL (list p1 p2 p3 p4)
i 0
)
(repeat 4
(wtxtMC (nth i txtL) (nth i pL) h t)
(setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
(defun txt2 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
(setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 7 h))
p3 (polar p2 0 (* 10 h))
p4 (polar p3 0 (* 9 h))
p4 (polar p4 (* 0.5 pi) h)
pL (list p1 p2 p3 p4)
i 0
)
(repeat 4
(wtxtMC (nth i txtL) (nth i pL) h t)
(setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:HSKT (/ 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:"))
(initget "T t N n")
(setq chieu (getkword "\nLua chon chieu ghi toa do < T/N >"))
(command "erase" et "")
(setq p0 p00
p01 (polar p00 (* 1.5 pi) (* h 3))
pvL (relist pdau pvL1)
n (length pvL)
p02 (polar p01 (* 1.5 pi) (+ (* h 3) (* (1- n) h 2)))
)
(setvar "osmode" 0)
;;;HEADER
(setvar "CLAYER" "bangtd")
(linepx p0 (* 32 h))
(command "copy" "L" "" "m" p00 p01 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 "Bang toa do cac dinh thua dat"
(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
(if (or (= chieu "N") (= chieu "n")) (setq pvL (reverse pvL)) )
(setq j 0
pt nil)
(repeat n
(setq
pv (nth j pvL)
num (itoa (1+ j))
num (strcat "M" num)
)
(if pt
(setq S (rtos (distance pt pv) 2 ntp))
(setq S "")
)
(setq
txtL (list num (rtos (car pv) 2 ntp) (rtos (cadr pv) 2 ntp) S)
Lkqua (append Lkqua (list txtL))
)
(txt2 txtL)
(setq 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))
num (strcat "M" num)
)
(wtxtMC num (polar pv 0 h) h t)
(command "circle" pv cr0)
(command "erase" vtron "")
(setq j (1+ j))
)
;;;GHI CANH THUA
(setvar "CLAYER" "kichthuoc")
(ghicanh)
;;;FINISH
(savef)
(setvar "osmode" oldos)
;(setq pdau (getpoint "\nPick diem dau tien (so thu tu = 1) :"))
;;; )
(setvar "cmdecho" 1)
(princ)
)
;;;-------------------------------------------------------------------------------
(defun savef()
(if save
(progn
(setq file (open (setq tenfile (strcat (getvar "dwgprefix")
(vl-filename-base (vl-string-right-trim "\\" (getvar "dwgname"))) ".txt")) "a"))
(foreach line Lkqua
(setq line1 "")
(foreach it line
(setq line1 (strcat line1 " " it)))
(write-line line1 file)
)
(close file)
(princ (strcat "\nDa luu thanh file " tenfile))
)
)
)
;;;PHAN BO SUNG
;;;------------------------------------------------------------------------------------
(defun Text_canh_TCA (S p a )
;;;Entmake text S at p with angle A - Top Center
(if (/= p nil)
(entmake (list
(cons 0 "TEXT")
(cons 62 2)
(cons 10 p)
(cons 40 h)
(cons 1 S)
(cons 50 a )
(cons 41 0.7)
(cons 7 (getvar "textstyle"))
(cons 72 1)
(cons 11 p)
(cons 73 3)
)
)
)
)
;;;------------------------------------------------------------------------------------
(defun Text_canh_BCA (S p a )
;;;Entmake text S at p with angle A - Bottom Center
(if (/= p nil)
(entmake (list
(cons 0 "TEXT")
(cons 62 2)
(cons 10 p)
(cons 40 h)
(cons 1 S)
(cons 50 a )
(cons 41 0.7)
(cons 7 (getvar "textstyle"))
(cons 72 1)
(cons 11 p)
(cons 73 1)
)
)
)
)
;;;-------------------------------------------------------------------------------
(defun Ghicanh (/ i k p1 p2 dist rad x_mp y_mp mp)
(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)
)
(command "DIMALIGNED" p1 p2 mp)
(setq i (1+ i))
)
;; repeat k;
)
;;;--------------------------



Cảm ơn VoHoan nhiều nhé.
cái chạy Thuận Nghịch thì ok roài.nhưng bạn có thể hoán đổi tọa độ cột X sang Y và thêm những đường line chia mỗi hàng ra như bản vẽ mình đã up ở trên nhé
và hatch những nút tròn ở mỗi đỉnh thửa lun nhé
Nếu được thì bạn có thể đổi tên bảng tọa độ giống như trong bản vẽ lun thì ok.
Thanks rất nhiều.
mình up lại bản vẽ nhé



http://www.cadviet.c...ke_toa_do_2.dwg
  • 0

#14 VoHoan

VoHoan

    biết lệnh move

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

Đã gửi 28 September 2012 - 11:15 PM

Bạn xem như ri đã được chưa nhé

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=63922&pid=199638&st=0&#entry199638
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=13203&st=3100
;; free lisp from cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chuong trinh danh so va lap bang toa do ho so thua dat dia chinh
;;;Bang toa do tao thanh block, duoc dat ten theo so thu tu 1, 2, 3...
;;;Chap nhan cac doi tuong la Region, Polyline, Line va Arc khep kin
;;;Written by - January 2009 - www.cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;PUBLIC FUNCTIONS
;;;-------------------------------------------------------------------------------
(Defun DTR (x) (/ (* x pi) 180))
;;;change degree to radian, return REAL
;;;-------------------------------------------------------------------------------
(defun lineP (p0 a r / p1)
;;;Line polar: point, degree angle, radius
(setq p1 (polar p0 (dtr a) r))
(command "line" p0 p1 "")
)
;;;-------------------------------------------------------------------------------
(defun linePX (p0 x) (lineP p0 0 x))
;;;Horizontal line: length x, from p0
;;;-------------------------------------------------------------------------------
(defun linePY (p0 y) (lineP p0 90 y))
;;;Vertical line: length y, from p0
;;;-------------------------------------------------------------------------------
(defun getVert (e / i L)
;;;Return list of all vertex from pline e
(setq i 0
L nil
)
(vl-load-com)
(repeat (fix (+ (vlax-curve-getEndParam e) 1))
(setq L (append L (list (vlax-curve-getPointAtParam e i))))
(setq i (1+ i))
)
L
)
;;; First point of List rearrangement
(defun relist(pt0 Lst / i rt)
(setq i 0)
(foreach pt Lst
(if (equal pt0 pt 0.001)
(setq rt i))
(setq i (1+ i)))
(append (append (member (nth rt Lst) Lst)
(cdr (reverse (cdr (member (nth rt Lst) (reverse Lst))))))
(list (nth rt Lst)))
)
;;;New Layer
(defun newlayer(a b c d)
(if (not (tblsearch "layer" a))
(command "-layer" "n" a "c" b a "l" c a "lw" d a ""))
)
;;;-------------------------------------------------------------------------------
(defun wtxtMC (txt p h k)
;;;Write text Middle Center, specify text, point, height
(entmake (list (cons 0 "TEXT")
(cons 7 (getvar "textstyle"))
(cons 1 txt)
(cons 10 p)
(cons 11 p)
(cons 40 h)
(cons 72 1)
(cons 73 2)
(if k (cons 51 (DTR 18)) (cons 51 0))
)
)
)
;;;-------------------------------------------------------------------------------
(defun Collect (e / e2 SS)
;;;Selection set from e to entlast
(setq SS (ssadd))
(ssadd e SS)
(while (setq e2 (entnext e)) (ssadd e2 SS) (setq e e2))
SS
)
;;;-------------------------------------------------------------------------------
(defun Collect1 (e / ss)
;;;Selection set after e to entlast. If e nil, select all from fist entity of drawing.
(if (= e nil)
(setq ss (collect (entnext)))
(progn (setq ss (collect e)) (ssdel e ss))
)
)
;;;-------------------------------------------------------------------------------
;;;PRIVATE FUNCTIONS
;;;-------------------------------------------------------------------------------
(defun txt1 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
(setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 7 h))
p3 (polar p2 0 (* 10 h))
p4 (polar p3 0 (* 9 h))
pL (list p1 p2 p3 p4)
i 0
)
(repeat 4
(wtxtMC (nth i txtL) (nth i pL) h t)
(setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
(defun txt2 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
(setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 7 h))
p3 (polar p2 0 (* 10 h))
p4 (polar p3 0 (* 9 h))
p4 (polar p4 (* 0.5 pi) h)
pL (list p1 p2 p3 p4)
i 0
)
(repeat 4
(wtxtMC (nth i txtL) (nth i pL) h t)
(setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:HSKT (/ 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:"))
(initget "T t N n")
(setq chieu (getkword "\nLua chon chieu ghi toa do < T/N >"))
(command "erase" et "")
(setq p0 p00
p01 (polar p00 (* 1.5 pi) (* h 3))
pvL (relist pdau pvL1)
n (length pvL)
p02 (polar p01 (* 1.5 pi) (+ (* h 3) (* (1- n) h 2)))
)
(setvar "osmode" 0)
;;;HEADER
(setvar "CLAYER" "bangtd")
(linepx p0 (* 32 h))
(command "copy" "L" "" "m" p00 p01 "")
(setq Lkqua nil)
(wtxtMC "B?NG K&#202; T?A &#208;? V&#192; KHO?NG C&#193;CH"
(polar (polar p0 0 (* 16 h)) (* 0.5 pi) (* 4 h))
(* 1.2 h) nil)
(wtxtMC "H? T?A &#208;? VN - 2000"
(polar (polar p0 0 (* 16 h)) (* 0.5 pi) (* 2 h))
(* 1.2 h) nil)
(txt1 (setq Lkq (list "TT" "Y (m)" "X (m)" "S (m)")))
(setq Lkqua (append Lkqua (list Lkq)))
(setq p0 (polar p0 (* 1.5 pi) (* 3 h)))
;;;MAKE RECORDS
(if (or (= chieu "N") (= chieu "n")) (setq pvL (reverse pvL)) )
(setq j 0
pt nil)
(repeat n
(setq
pv (nth j pvL)
num (itoa (1+ j))
num (strcat "M" num)
)
(if pt
(setq S (rtos (distance pt pv) 2 ntp))
(setq S "")
)
(setq
txtL (list num (rtos (car pv) 2 ntp) (rtos (cadr pv) 2 ntp) S)
Lkqua (append Lkqua (list txtL))
)
(txt2 txtL)
(setq p11 (polar p0 (* 1.5 pi) (* 2.5 h)))
(setq P12 (polar p11 0 (* 25 h)))
(setq P13 (polar p11 0 (* 31 h)))
(setq P14 (polar p11 0 (* 32 h)))
(command "LINE" p11 p12 "")
(command "LINE" p13 p14 "")
(setq p0 (polar p0 (* 1.5 pi) (* 2 h)))
(setq pt pv)
(setq j (1+ j))
(if (= j (- n 1)) (setq j 0))
)
(command "LINE" p11 p14 "")
(linepy p00 (- (distance p00 (polar p0 (* 1.5 pi) (* 0.5 h)) )))
(command "copy" "L" "" "m" p0
(list (+ (car p0) (* 4 h)) (cadr p0))
(list (+ (car p0) (* 14 h)) (cadr p0))
(list (+ (car p0) (* 24 h)) (cadr p0))
(list (+ (car p0) (* 32 h)) (cadr p0))
"")
;;;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))
num (strcat "M" num)
)
(wtxtMC num (polar pv 0 h) h t)
(command "circle" pv cr0)
(command "-HATCH" "S" "L" "" "")
(command "erase" vtron "")
(setq j (1+ j))
)
;;;GHI CANH THUA
(setvar "CLAYER" "kichthuoc")
(ghicanh)
;;;FINISH
(savef)
(setvar "osmode" oldos)
;(setq pdau (getpoint "\nPick diem dau tien (so thu tu = 1) :"))
;;; )
(setvar "cmdecho" 1)
(princ)
)
;;;-------------------------------------------------------------------------------
(defun savef()
(if save
(progn
(setq file (open (setq tenfile (strcat (getvar "dwgprefix")
(vl-filename-base (vl-string-right-trim "\\" (getvar "dwgname"))) ".txt")) "a"))
(foreach line Lkqua
(setq line1 "")
(foreach it line
(setq line1 (strcat line1 " " it)))
(write-line line1 file)
)
(close file)
(princ (strcat "\nDa luu thanh file " tenfile))
)
)
)
;;;PHAN BO SUNG
;;;------------------------------------------------------------------------------------
(defun Text_canh_TCA (S p a )
;;;Entmake text S at p with angle A - Top Center
(if (/= p nil)
(entmake (list
(cons 0 "TEXT")
(cons 62 2)
(cons 10 p)
(cons 40 h)
(cons 1 S)
(cons 50 a )
(cons 41 0.7)
(cons 7 (getvar "textstyle"))
(cons 72 1)
(cons 11 p)
(cons 73 3)
)
)
)
)
;;;------------------------------------------------------------------------------------
(defun Text_canh_BCA (S p a )
;;;Entmake text S at p with angle A - Bottom Center
(if (/= p nil)
(entmake (list
(cons 0 "TEXT")
(cons 62 2)
(cons 10 p)
(cons 40 h)
(cons 1 S)
(cons 50 a )
(cons 41 0.7)
(cons 7 (getvar "textstyle"))
(cons 72 1)
(cons 11 p)
(cons 73 1)
)
)
)
)
;;;-------------------------------------------------------------------------------
(defun Ghicanh (/ i k p1 p2 dist rad x_mp y_mp mp)
(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)
)
(command "DIMALIGNED" p1 p2 mp)
(setq i (1+ i))
)
;; repeat k;
)
;;;--------------------------

  • 0

#15 ro88

ro88

    biết vẽ arc

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

Đã gửi 28 September 2012 - 11:42 PM

Cảm ơn VoHoan nhiều lắm.Thật là tuyệt
Bạn có thể giúp mình vấn đề này lun nhé;
1)Font chữ Bảng ke tọa độ bị lỗi
2)Những điểm nút ở đỉnh thửa ko có hatch
3)Text cạnh bị trùng lặp
Xong 3 cái nay nữa là ok
Thanks bạn rất nhiều
Chúc sức khỏe
  • 0

#16 hoangkimoanh

hoangkimoanh

    biết vẽ spline

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

Đã gửi 28 September 2012 - 11:45 PM

anh VoHoan ơi cái kích thước mà anh sửa cho em nó lại chạy cả 2 dạng kích thước anh ạ (cả Text cả Dim). em muốn chạy chỉ 1 loại kích thước là Dim thôi mà nó cùng vẫn nằm ngoài thửa đất được không ạ!
  • 0

#17 VoHoan

VoHoan

    biết lệnh move

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

Đã gửi 29 September 2012 - 09:51 AM

S­ửa lại cho bạn đây:

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=63922&pid=199638&st=0&#entry199638
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=13203&st=3100
;; free lisp from cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Chuong trinh danh so va lap bang toa do ho so thua dat dia chinh
;;;Bang toa do tao thanh block, duoc dat ten theo so thu tu 1, 2, 3...
;;;Chap nhan cac doi tuong la Region, Polyline, Line va Arc khep kin
;;;Written by - January 2009 - www.cadviet.com
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;PUBLIC FUNCTIONS
;;;-------------------------------------------------------------------------------
(Defun DTR (x) (/ (* x pi) 180))
;;;change degree to radian, return REAL
;;;-------------------------------------------------------------------------------
(defun lineP (p0 a r / p1)
;;;Line polar: point, degree angle, radius
(setq p1 (polar p0 (dtr a) r))
(command "line" p0 p1 "")
)
;;;-------------------------------------------------------------------------------
(defun linePX (p0 x) (lineP p0 0 x))
;;;Horizontal line: length x, from p0
;;;-------------------------------------------------------------------------------
(defun linePY (p0 y) (lineP p0 90 y))
;;;Vertical line: length y, from p0
;;;-------------------------------------------------------------------------------
(defun getVert (e / i L)
;;;Return list of all vertex from pline e
(setq i 0
L nil
)
(vl-load-com)
(repeat (fix (+ (vlax-curve-getEndParam e) 1))
(setq L (append L (list (vlax-curve-getPointAtParam e i))))
(setq i (1+ i))
)
L
)
;;; First point of List rearrangement
(defun relist(pt0 Lst / i rt)
(setq i 0)
(foreach pt Lst
(if (equal pt0 pt 0.001)
(setq rt i))
(setq i (1+ i)))
(append (append (member (nth rt Lst) Lst)
(cdr (reverse (cdr (member (nth rt Lst) (reverse Lst))))))
(list (nth rt Lst)))
)
;;;New Layer
(defun newlayer(a b c d)
(if (not (tblsearch "layer" a))
(command "-layer" "n" a "c" b a "l" c a "lw" d a ""))
)
;;;-------------------------------------------------------------------------------
(defun wtxtMC (txt p h k)
;;;Write text Middle Center, specify text, point, height
(entmake (list (cons 0 "TEXT")
(cons 7 (getvar "textstyle"))
(cons 1 txt)
(cons 10 p)
(cons 11 p)
(cons 40 h)
(cons 72 1)
(cons 73 2)
(if k (cons 51 (DTR 18)) (cons 51 0))
)
)
)
;;;-------------------------------------------------------------------------------
(defun Collect (e / e2 SS)
;;;Selection set from e to entlast
(setq SS (ssadd))
(ssadd e SS)
(while (setq e2 (entnext e)) (ssadd e2 SS) (setq e e2))
SS
)
;;;-------------------------------------------------------------------------------
(defun Collect1 (e / ss)
;;;Selection set after e to entlast. If e nil, select all from fist entity of drawing.
(if (= e nil)
(setq ss (collect (entnext)))
(progn (setq ss (collect e)) (ssdel e ss))
)
)
;;;-------------------------------------------------------------------------------
;;;PRIVATE FUNCTIONS
;;;-------------------------------------------------------------------------------
(defun txt1 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
(setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 7 h))
p3 (polar p2 0 (* 10 h))
p4 (polar p3 0 (* 9 h))
pL (list p1 p2 p3 p4)
i 0
)
(repeat 4
(wtxtMC (nth i txtL) (nth i pL) h t)
(setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
(defun txt2 (txtL / p1 p2 p3 p4 pL i)
;;;Write texts in 1 row
(setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 7 h))
p3 (polar p2 0 (* 10 h))
p4 (polar p3 0 (* 9 h))
p4 (polar p4 (* 0.5 pi) h)
pL (list p1 p2 p3 p4)
i 0
)
(repeat 4
(wtxtMC (nth i txtL) (nth i pL) h t)
(setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:HSKT (/ h p et p0 p00 p01 p02 pt pvL pvL1 n j pv num txtL ss bn ntp p11 p12 p13 p14)
(setvar "cmdecho" 0)
;;;New layer check
(newlayer "kichthuoc" 7 "continuous" "default")
(newlayer "stt" 1 "continuous" "default")
(newlayer "bangtd" 7 "continuous" "default")
;;;GET TEXT HEIGHT
(if (not h0) (setq h0 1))
(setq h (getreal (strcat "\nChon chieu cao text <" (rtos h0) ">:")))
(if (not h) (setq h h0) (setq h0 h))
;;;GET DECIMAL PRECISION
(if (not ntp0) (setq ntp0 2))
(setq ntp (getint (strcat "\nSo chu so thap phan <" (itoa ntp0) ">:")))
(if (not ntp) (setq ntp ntp0) (setq ntp0 ntp))
;;;GET CIRCLE RADIUS
(if (not cr0) (setq cr0 0.3))
(setq cr (getreal (strcat "\nNhap ban kinh vong tron <" (rtos cr0) ">:")))
(if cr (setq cr0 cr))

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

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

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

  • 2

#18 ro88

ro88

    biết vẽ arc

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

Đã gửi 29 September 2012 - 11:28 AM

Thanks VoHoan nhiều nhé
Chúc vui và thành công trong cuộc sống và trong công việc
  • 0

#19 hoangkimoanh

hoangkimoanh

    biết vẽ spline

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

Đã gửi 30 September 2012 - 03:04 PM

cảm ơn anh nhiều nhé, chúc các anh và gia đình có 1 đêm trung thu vui vẻ hạnh phúc!
  • 0

#20 tuanchung

tuanchung

    biết vẽ line

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

Đã gửi 06 November 2012 - 04:00 PM

em có một chút vấn đề thế này mong bác VoHoan sửa giúp em thì em cảm ơn bác lắm ý.
Thay cho đánh số là M1,M2......thì bác có thể chuyển cho em thành 1,2,3,......n. Mong bác giúp em.!
Em xin chân thành cảm ơn bác .!!!!
  • 0