Chuyển đến nội dung
Diễn đàn CADViet
Đăng nhập để thực hiện theo  
thachtrinh

NHỜ SỬA LISP

Các bài được khuyến nghị

Em có tìm được file lisp trên diễn đàn (của bác kangkung) nhưng chưa đúng ý, nhờ anh chị trên diễn đàn sửa giúp ạ :) Cảm ơn mọi người.File lisp này dùng để gán cao độ đường đồng mức và ghi cao độ lên đường đồng mức. Bây giờ em cần bỏ 2 số 0 sau dấu phẩy khi ghi text, và điểm chèn text là vào giữa đường đồng mức (mặc định là có 2 số 0 sau dấu phẩy và ghi text cách đường đồng mức 1/2 chiều cao text.

Cho em hỏi thêm là có lệnh nào ẩn đường line dưới text đi không? (ngoài lệnh wipeout) Hay anh chị nào viết thêm cho em cái này vào lisp thì quá tuyệt. 
Em cảm ơn ạ :D

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Sưu tầm và chắp vá giúp bạn.

;; free lisp from cadviet.com

;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/70261-nho-viet-lisp-gan-cao-do-cho-duong-dong-muc-va-ghi-ra-text/

;GAN CAO DO CHO DUONG DONG MUC VA GHI RA TEXT

;=======KANGKUNG 14/04/2013 - REV1===========

(defun C:kk( / i index pt pt1 pt2 taphop lst huong)

(setvar "CMDECHO" 0)

(setvar "DIMZIN" 0)

(command "UNDO" "BE")

(setq os(getvar "OSMODE"))

(setvar "OSMODE" 0)

(setq taphop (ssget '((0 . "POLYLINE,LWPOLYLINE")))) ;POLYLINE,LWPOLYLINE

(if (and (/= docao nil) (= (length list_caodo) 2))

(setq docao (read (lisped (rtos (+ (- (nth 1 list_caodo) (nth 0 list_caodo)) docao) 2 2))))

(if (/= docao nil)

(setq docao (read (lisped (rtos docao 2 2))))

(setq docao (read (lisped "Nhap do cao duong dong muc vao day")))

)

)

(if (< (length list_caodo) 2)

(setq list_caodo(append list_caodo (list docao)))

(setq list_caodo(append (list (nth 1 list_caodo)) (list docao)))

)

(if (= Height nil)

(setq Height(read(lisped "Nhap cao chu vao day")))

)

(setq index 0)

(while (< index (sslength taphop))

(vla-put-elevation (vlax-ename->vla-object (ssname taphop index)) docao)

(vla-put-color (vlax-ename->vla-object (ssname taphop index)) 2)

(setq index (1+ index))

)

(while (setq pt (getpoint "\n Pick diem chen TEXT: " ))

(huongtext)

(entmake (list '(0 . "TEXT") (cons 10 pt2) (cons 40 Height) (cons 1 (rtos docao 2 0)) (cons 50 huong)))(txt2mtxt)

)

(setvar "OSMODE" os)

(command "UNDO" "END")

(setvar "cmdecho" 1)

(princ)

)

(defun huongtext()

(setq i 0)

(setq lst(list))

(while (< i (sslength taphop))

(setq dt(ssname taphop i))

(setq pt1(vlax-curve-getClosestPointTo dt pt))

(if (and (<= pi (angle pt1 pt)) (<= (angle pt1 pt) (* 2 pi)))

(setq pt2(polar pt1 (angle pt pt1) (/ Height -2)))

(setq pt2(polar pt1 (angle pt1 pt) (/ Height -2)))

)

(if (= (vlax-curve-getDistAtPoint dt (vlax-curve-getClosestPointTo dt pt)) (vla-get-length (vlax-ename->vla-object dt)))

(setq huong(angle ( vlax-curve-getPointAtDist dt (+ (vlax-curve-getDistAtPoint dt (vlax-curve-getClosestPointTo dt pt)) -0.001)) (vlax-curve-getClosestPointTo dt pt) ))

(setq huong(angle (vlax-curve-getClosestPointTo dt pt) ( vlax-curve-getPointAtDist dt (+ (vlax-curve-getDistAtPoint dt (vlax-curve-getClosestPointTo dt pt)) 0.001))))

)

(if (and (> huong (/ pi 2)) (< huong (/ (* 3 pi) 2))) (setq huong(- huong pi)))

(setq lst(append lst (list (list (distance pt pt1) huong pt2))))

(setq i(1+ i))

)

(setq lst(vl-sort lst '(lambda (e1 e2) (< (car e1) (car e2)))))

(setq huong(cadr(nth 0 lst)))

(setq pt2(caddr(nth 0 lst)))

)

(princ "\n KangKung - 14/04/2013\n")

(princ "\n Nhap KK de chay chuong trinh\n")

 

(defun txt2mtxt (/ sset count num en el

mcontent bbox point1 point2 point3 point4

mwidth mheight mstyle njust mrotate nmtext ss)

(if (setq sset (ssget "L"))

(progn

(setq count 0

ss (ssadd)

) ;_ end of setq

(while (ssname sset COUNT)

(setq EN (ssname sset COUNT))

(setq EL (entget EN))

(if (= (cdr (assoc 0 EL)) "TEXT")

(progn

(setq mcontent (cons '1 (strcase (cdr (assoc 1 el)))))

(setq EL (subst mcontent(assoc 1 EL) EL))

(setq bbox (acet-geom-textbox EL 0.1))

(setq point1 (car bbox))

(setq point2 (cadr bbox))

(setq point3 (cadr (cdr bbox)))

(setq point4 (cadr (cdr (cdr bbox))))

(setq mwidth (cons '41 (distance point1 point2)))

(setq mheight (cons '40 (cdr (assoc 40 el))))

(setq mstyle (cons '7 (cdr (assoc 7 el))))

(setq nspace (cons '410 (cdr (assoc 410 EL))))

(setq minsert (cons '10 (cdr (assoc 10 EL))))

(cond

((and (= (cdr (assoc 72 el)) 0) (= (cdr (assoc 73 el)) 3))

(setq NJUST (cons '71 1))

) ;JY

((and (= (cdr (assoc 72 el)) 1) (= (cdr (assoc 73 el)) 3))

(setq NJUST (cons '71 2))

) ;JU

((and (= (cdr (assoc 72 el)) 2) (= (cdr (assoc 73 el)) 3))

(setq NJUST (cons '71 3))

) ;JI

((and (= (cdr (assoc 72 el)) 0) (= (cdr (assoc 73 el)) 2))

(setq NJUST (cons '71 7))

) ;JN

((and (= (cdr (assoc 72 el)) 1) (= (cdr (assoc 73 el)) 2))

(setq NJUST (cons '71 7))

) ;JN

((and (= (cdr (assoc 72 el)) 2) (= (cdr (assoc 73 el)) 2))

(setq NJUST (cons '71 6))

) ;JK

((and (= (cdr (assoc 72 el)) 0) (= (cdr (assoc 73 el)) 0))

(setq NJUST (cons '71 7))

) ;JN

((and (= (cdr (assoc 72 el)) 4) (= (cdr (assoc 73 el)) 0))

(setq NJUST (cons '71 7))

) ;JN

((and (= (cdr (assoc 72 el)) 0) (= (cdr (assoc 73 el)) 1))

(setq NJUST (cons '71 7))

) ;JN

((and (= (cdr (assoc 72 el)) 1) (= (cdr (assoc 73 el)) 0))

(setq NJUST (cons '71 7))

) ;JN

((and (= (cdr (assoc 72 el)) 1) (= (cdr (assoc 73 el)) 1))

(setq NJUST (cons '71 8))

) ;JM

((and (= (cdr (assoc 72 el)) 2) (= (cdr (assoc 73 el)) 1))

(setq NJUST (cons '71 9))

) ;J,

((and (= (cdr (assoc 72 el)) 2) (= (cdr (assoc 73 el)) 0))

(setq NJUST (cons '71 7))

) ;JN

) ;_ end of cond

(setq mrotate (cons '50 (cdr (assoc 50 el))))

(setq nmtext (list '(0 . "MTEXT") '(100 . "AcDbEntity")

'(67 . 0) nspace

'(8 . "TEXT") '(100 . "AcDbMText")

minsert njust

mheight mwidth

mstyle mcontent

mrotate

) ;_ end of list

) ;_ end of setq

(vla-put-backgroundfill

(vlax-ename->vla-object (entmakex nmtext))

:vlax-true

) ;_ end of vla-put-BackgroundFill

(ssadd (entlast) ss)

(entdel en)

(setq count (+ count 1))

) ;_ end of progn

(setq count (+ count 1))

) ;_ end of if

) ;_ end of while

(if (> (sslength ss) 0)

(command "_draworder" ss "" "_F")

) ;_ end of if

)

)

(princ)

) ;_ end of defun

(vl-load-com)

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Sưu tầm và chắp vá giúp bạn.

;; free lisp from cadviet.com

;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/70261-nho-viet-lisp-gan-cao-do-cho-duong-dong-muc-va-ghi-ra-text/

;GAN CAO DO CHO DUONG DONG MUC VA GHI RA TEXT

;=======KANGKUNG 14/04/2013 - REV1===========

(defun C:kk( / i index pt pt1 pt2 taphop lst huong)

(setvar "CMDECHO" 0)

(setvar "DIMZIN" 0)

(command "UNDO" "BE")

(setq os(getvar "OSMODE"))

(setvar "OSMODE" 0)

(setq taphop (ssget '((0 . "POLYLINE,LWPOLYLINE")))) ;POLYLINE,LWPOLYLINE

(if (and (/= docao nil) (= (length list_caodo) 2))

(setq docao (read (lisped (rtos (+ (- (nth 1 list_caodo) (nth 0 list_caodo)) docao) 2 2))))

(if (/= docao nil)

(setq docao (read (lisped (rtos docao 2 2))))

(setq docao (read (lisped "Nhap do cao duong dong muc vao day")))

)

)

(if (< (length list_caodo) 2)

(setq list_caodo(append list_caodo (list docao)))

(setq list_caodo(append (list (nth 1 list_caodo)) (list docao)))

)

(if (= Height nil)

(setq Height(read(lisped "Nhap cao chu vao day")))

)

(setq index 0)

(while (< index (sslength taphop))

(vla-put-elevation (vlax-ename->vla-object (ssname taphop index)) docao)

(vla-put-color (vlax-ename->vla-object (ssname taphop index)) 2)

(setq index (1+ index))

)

(while (setq pt (getpoint "\n Pick diem chen TEXT: " ))

(huongtext)

(entmake (list '(0 . "TEXT") (cons 10 pt2) (cons 40 Height) (cons 1 (rtos docao 2 0)) (cons 50 huong)))(txt2mtxt)

)

(setvar "OSMODE" os)

(command "UNDO" "END")

(setvar "cmdecho" 1)

(princ)

)

(defun huongtext()

(setq i 0)

(setq lst(list))

(while (< i (sslength taphop))

(setq dt(ssname taphop i))

(setq pt1(vlax-curve-getClosestPointTo dt pt))

(if (and (<= pi (angle pt1 pt)) (<= (angle pt1 pt) (* 2 pi)))

(setq pt2(polar pt1 (angle pt pt1) (/ Height -2)))

(setq pt2(polar pt1 (angle pt1 pt) (/ Height -2)))

)

(if (= (vlax-curve-getDistAtPoint dt (vlax-curve-getClosestPointTo dt pt)) (vla-get-length (vlax-ename->vla-object dt)))

(setq huong(angle ( vlax-curve-getPointAtDist dt (+ (vlax-curve-getDistAtPoint dt (vlax-curve-getClosestPointTo dt pt)) -0.001)) (vlax-curve-getClosestPointTo dt pt) ))

(setq huong(angle (vlax-curve-getClosestPointTo dt pt) ( vlax-curve-getPointAtDist dt (+ (vlax-curve-getDistAtPoint dt (vlax-curve-getClosestPointTo dt pt)) 0.001))))

)

(if (and (> huong (/ pi 2)) (< huong (/ (* 3 pi) 2))) (setq huong(- huong pi)))

(setq lst(append lst (list (list (distance pt pt1) huong pt2))))

(setq i(1+ i))

)

(setq lst(vl-sort lst '(lambda (e1 e2) (< (car e1) (car e2)))))

(setq huong(cadr(nth 0 lst)))

(setq pt2(caddr(nth 0 lst)))

)

(princ "\n KangKung - 14/04/2013\n")

(princ "\n Nhap KK de chay chuong trinh\n")

 

(defun txt2mtxt (/ sset count num en el

mcontent bbox point1 point2 point3 point4

mwidth mheight mstyle njust mrotate nmtext ss)

(if (setq sset (ssget "L"))

(progn

(setq count 0

ss (ssadd)

) ;_ end of setq

(while (ssname sset COUNT)

(setq EN (ssname sset COUNT))

(setq EL (entget EN))

(if (= (cdr (assoc 0 EL)) "TEXT")

(progn

(setq mcontent (cons '1 (strcase (cdr (assoc 1 el)))))

(setq EL (subst mcontent(assoc 1 EL) EL))

(setq bbox (acet-geom-textbox EL 0.1))

(setq point1 (car bbox))

(setq point2 (cadr bbox))

(setq point3 (cadr (cdr bbox)))

(setq point4 (cadr (cdr (cdr bbox))))

(setq mwidth (cons '41 (distance point1 point2)))

(setq mheight (cons '40 (cdr (assoc 40 el))))

(setq mstyle (cons '7 (cdr (assoc 7 el))))

(setq nspace (cons '410 (cdr (assoc 410 EL))))

(setq minsert (cons '10 (cdr (assoc 10 EL))))

(cond

((and (= (cdr (assoc 72 el)) 0) (= (cdr (assoc 73 el)) 3))

(setq NJUST (cons '71 1))

) ;JY

((and (= (cdr (assoc 72 el)) 1) (= (cdr (assoc 73 el)) 3))

(setq NJUST (cons '71 2))

) ;JU

((and (= (cdr (assoc 72 el)) 2) (= (cdr (assoc 73 el)) 3))

(setq NJUST (cons '71 3))

) ;JI

((and (= (cdr (assoc 72 el)) 0) (= (cdr (assoc 73 el)) 2))

(setq NJUST (cons '71 7))

) ;JN

((and (= (cdr (assoc 72 el)) 1) (= (cdr (assoc 73 el)) 2))

(setq NJUST (cons '71 7))

) ;JN

((and (= (cdr (assoc 72 el)) 2) (= (cdr (assoc 73 el)) 2))

(setq NJUST (cons '71 6))

) ;JK

((and (= (cdr (assoc 72 el)) 0) (= (cdr (assoc 73 el)) 0))

(setq NJUST (cons '71 7))

) ;JN

((and (= (cdr (assoc 72 el)) 4) (= (cdr (assoc 73 el)) 0))

(setq NJUST (cons '71 7))

) ;JN

((and (= (cdr (assoc 72 el)) 0) (= (cdr (assoc 73 el)) 1))

(setq NJUST (cons '71 7))

) ;JN

((and (= (cdr (assoc 72 el)) 1) (= (cdr (assoc 73 el)) 0))

(setq NJUST (cons '71 7))

) ;JN

((and (= (cdr (assoc 72 el)) 1) (= (cdr (assoc 73 el)) 1))

(setq NJUST (cons '71 8))

) ;JM

((and (= (cdr (assoc 72 el)) 2) (= (cdr (assoc 73 el)) 1))

(setq NJUST (cons '71 9))

) ;J,

((and (= (cdr (assoc 72 el)) 2) (= (cdr (assoc 73 el)) 0))

(setq NJUST (cons '71 7))

) ;JN

) ;_ end of cond

(setq mrotate (cons '50 (cdr (assoc 50 el))))

(setq nmtext (list '(0 . "MTEXT") '(100 . "AcDbEntity")

'(67 . 0) nspace

'(8 . "TEXT") '(100 . "AcDbMText")

minsert njust

mheight mwidth

mstyle mcontent

mrotate

) ;_ end of list

) ;_ end of setq

(vla-put-backgroundfill

(vlax-ename->vla-object (entmakex nmtext))

:vlax-true

) ;_ end of vla-put-BackgroundFill

(ssadd (entlast) ss)

(entdel en)

(setq count (+ count 1))

) ;_ end of progn

(setq count (+ count 1))

) ;_ end of if

) ;_ end of while

(if (> (sslength ss) 0)

(command "_draworder" ss "" "_F")

) ;_ end of if

)

)

(princ)

) ;_ end of defun

(vl-load-com)

 

Hề hề hề,

1/- Lisp này không sử dụng được với Cad2004 do sử dụng hàm (vla-put-backgroundfill ........) Hình như từ CAD2007 trở lên mới có hàm này.

2/- Trong lisp sử dụng khá nhiều hàm dạng (cons a (cdr (assoc a elst))), Vì sao không xài luôn thằng (assoc a elst) ???

3/- Vì sao không tạo mtext ngay từ đầu mà lại tạo text rồi mất công đổi sang mtext???

4/- Biến pt2 có còn cần thiết không nhỉ??

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Hề hề... Mỳ ăn liền (Như comment là chắp vá). 1 khúc của KangKung, 1 khúc là lisp có sẵn chuyển từ text sang mtext và textmask ghép lại ấy mà!

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay

Đăng nhập để thực hiện theo  

×