Đến nội dung


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

Viết Lisp theo yêu cầu


  • Chủ đề bị khóa Chủ đề bị khóa
2780 replies to this topic

#2001 phuchauctc

phuchauctc

    Chưa sử dụng CAD

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

Đã gửi 17 May 2009 - 01:09 PM

Chào các cao thủ.
Mình mới tham gia diễn đàn và thấy rất nhiều điều hay. Hôm trước mình có dùng một số lisp tạo bảng toạ độ để lấy toạ độ của các điểm trên Pline hoặc Region rồi xuất ngay trong CAD hoặc sang Excel hoặc text. Mình thấy cũng tốt nhiều cho mình rồi nhưng còn một số việc chưa được nên nhờ các cao thủ lập giúp mình một lisp thực hiện công việc sau:
Có 1 bản vẽ mặt bằng công trình theo dạng tuyến được vẽ với tỷ lệ 1/2000. Trên mặt bằng có các mốc giải phóng mặt bằng có tọa độ X và Y. Giả sử mốc GPMB1 có tọa độ chuẩn theo hệ tọa độ Quốc gia VN2000 là X1, Y1. Trong quá trình lập bản vẽ thiết kế lại chuyển cả bản vẽ mặt bằng đi một vị trí khác (move tự do không định trước khoảng cách) nên điểm GPMB1 bây giờ có tọa độ là X2, Y2. Để có bảng tọa độ đúng của các mốc GPMB, mình đã làm như sau:
- Chuyển tỷ lệ bản vẽ về đúng tỷ lệ thật.
- Chuyển (move) một điểm nào đó (ví dụ điểm đường chuyền) trên bản vẽ đã bị dịch đi về đúng tọa độ của nó theo tài liệu khảo sát địa hình.
- Dùng Lisp sau (xin lỗi ko nhớ của tác giả nào nữa):
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;Chuong trinh danh so va lap bang toa do ho so thua dat dia chinh
;;;Bang toa do tao thanh block, duoc dat ten theo so thu tu 1, 2, 3...
;;;Chap nhan cac doi tuong la Region, Polyline, Line va Arc khep kin
;;;Free utility - www.cadviet.com - September 2008
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;




;;;PUBLIC FUNCTIONS
;;;-------------------------------------------------------------------------------
(Defun DTR(x) (/ (* x pi) 180) ) ;;;change degree to radian, return REAL
;;;-------------------------------------------------------------------------------
(defun lineP (p0 a r / p1) ;;;Line polar: point, degree angle, radius
(setq p1 (polar p0 (dtr a) r))
(command "line" p0 p1 "")
)
;;;-------------------------------------------------------------------------------
(defun linePX (p0 x) (lineP p0 0 x)) ;;;Horizontal line: length x, from p0
;;;-------------------------------------------------------------------------------
(defun linePY (p0 y) (lineP p0 90 y)) ;;;Vertical line: length y, from p0
;;;-------------------------------------------------------------------------------
(defun getVert (e / i L) ;;;Return list of all vertex from pline e
(setq i 0 L nil)
(vl-load-com)
(repeat (fix (+ (vlax-curve-getEndParam e) 1))
(setq L (append L (list (vlax-curve-getPointAtParam e i))))
(setq i (1+ i))
)
L
)
;;;-------------------------------------------------------------------------------
(defun wtxtMC (txt p h) ;;;Write text Middle Center, specify text, point, height
(entmake (list (cons 0 "TEXT") (cons 7 (getvar "textstyle"))
(cons 1 txt) (cons 10 p) (cons 11 p) (cons 40 h) (cons 72 1) (cons 73 2)))
)
;;;-------------------------------------------------------------------------------
(defun Collect(e / e2 SS) ;;;Selection set from e to entlast
(setq SS (ssadd))
(ssadd e SS)
(while (setq e2 (entnext e)) (ssadd e2 SS) (setq e e2))
SS
)
;;;-------------------------------------------------------------------------------
(defun Collect1(e / ss)
;;;Selection set after e to entlast. If e nil, select all from fist entity of drawing.
(if (= e nil) (setq ss (collect (entnext)))
(progn (setq ss (collect e)) (ssdel e ss))
)
)
;;;-------------------------------------------------------------------------------

;;;PRIVATE FUNCTIONS
;;;-------------------------------------------------------------------------------
(defun txt1(txtL / p1 p2 p3 p4 pL i) ;;;Write texts in 1 row
(setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 8 h))
p3 (polar p2 0 (* 12 h))
p4 (polar p3 0 (* 10 h))
pL (list p1 p2 p3 p4)
i 0
)
(repeat 4
(wtxtMC (nth i txtL) (nth i pL) h)
(setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------
(defun txt2(txtL / p1 p2 p3 p4 pL i) ;;;Write texts in 1 row
(setq
p1 (list (+ (car p0) (* 2 h)) (- (cadr p0) (* 1.5 h)))
p2 (polar p1 0 (* 8 h))
p3 (polar p2 0 (* 12 h))
p4 (polar p3 0 (* 10 h))
p4 (polar p4 (* 0.5 pi) (* 1.5 h))
pL (list p1 p2 p3 p4)
i 0
)
(repeat 4
(wtxtMC (nth i txtL) (nth i pL) h)
(setq i (1+ i))
)
)
;;;-------------------------------------------------------------------------------


;;;MAIN PROGRAM
;;;-------------------------------------------------------------------------------
(defun C:VC( / h p et p0 p00 p01 p02 pt pvL n j pv num txtL ss bn)
;;;Vertex Co-ordinate

;;;GET TEXT HEIGHT
(if (not h0) (setq h0 1))
(setq h (getreal (strcat "\nChon chieu cao text <" (rtos h0) ">:")))
(if (not h) (setq h h0) (setq h0 h))

;;;PICK & BASE POINT
(setq p (getpoint "\nPick 1 diem giua mien kin:"))
(command "boundary" p "")
(setq et (entlast))
(redraw et 3)
(setq
p00 (getpoint "\nDiem chuan bang toa do (phia tren ben trai):")
p0 p00
p01 (polar p00 (* 1.5 pi) (* h 3))
pvL (reverse (getvert et))
n (length pvL)
p02 (polar p01 (* 1.5 pi) (* n h 3))
oldos (getvar "osmode")
)
(setvar "osmode" 0)

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

(txt1 (list "TT" "X (m)" "Y (m)" "S (m)"))
(setq p0 (polar p0 (* 1.5 pi) (* 3 h)))

;;;MAKE RECORDS
(setq j 0 pt nil)
(repeat n
(setq
pv (nth j pvL)
num (itoa (1+ j))
)
(if pt (setq S (rtos (distance pt pv))) (setq S ""))
(setq txtL (list num (rtos (cadr pv)) (rtos (car pv)) S))
(txt2 txtL)
(setq p0 (polar p0 (* 1.5 pi) (* 3 h)))
(setq pt pv)
(setq j (1+ j))
(if (= j (- n 1)) (setq j 0))
)

;;;MAKE BLOCK
(setq ss (collect1 et))
(command "erase" et "")
(setq bn "1")
(while (tblsearch "block" bn) (setq bn (itoa (1+ (atoi bn)))))
(command "block" bn p00 ss "")
(command "insert" bn p00 "" "" "")

;;;WRITE POINT NAME
(setq j 0)
(repeat (1- n)
(setq
pv (nth j pvL)
num (itoa (1+ j))
)
(wtxtMC num (polar pv 0 h) h)
(setq j (1+ j))
)
;;;FINISH
(setvar "osmode" oldos)
(princ)
)
;;;-------------------------------------------------------------------------------

Mình đã tạo được bảng tọa độ theo ý muốn. Tuy nhiên mình muốn các cao thủ sửa giúp (do mình hoàn toàn mù tịt về AutoLisp) Lisp trên nhằm thực hiện các việc:
- Nhập tỷ lệ bản vẽ hiện hành.
- Nhập tỷ lệ thực cần chuyển về.
- Chọn điểm chuẩn cần chuyển tọa độ.
- Nhập tọa độ hiện hành (đã bị dịch chuyển) của điểm đó.
- Nhập tọa độ chuẩn của điểm chuẩn đó.
Sau đó mới đến các việc của đoạn Lisp trên và việc đánh số thứ tự không là 1,2,3... mà có thể là GPMB1, GPMB2, GPMB3,... hoặc gì đó theo bước nhảy do người dùng đặt (mặc định là 1) và xuất trực tiếp ra bản vẽ hoặc sang Excel hoặc text.
Đây là lần đầu tiên viết bài trên diễn đàn nên có gì chưa được xin được chỉ giáo.
Mr Hoành hoặc Mr ssg ơi, nếu ai sửa giúp được xin nhờ gửi cho mình theo Email: phuchauctc@gmail.com với nhé.
Xin đa tạ và chúc sức khỏe!
  • 0

#2002 Tue_NV

Tue_NV

    KS Võ Quang Tuệ

  • Moderator
  • PipPipPipPipPipPipPip
  • 4296 Bài viết
Điểm đánh giá: 3804 (đỉnh cao)

Đã gửi 17 May 2009 - 01:53 PM

Chào các cao thủ.
Mình mới tham gia diễn đàn và thấy rất nhiều điều hay. Hôm trước mình có dùng một số lisp tạo bảng toạ độ để lấy toạ độ của các điểm trên Pline hoặc Region rồi xuất ngay trong CAD hoặc sang Excel hoặc text. Mình thấy cũng tốt nhiều cho mình rồi nhưng còn một số việc chưa được nên nhờ các cao thủ lập giúp mình một lisp thực hiện công việc sau:



Theo em anh ko nên "viết chào các cao thủ"! Viết như thế kỳ kỳ thế nào ứ! Vì có người biết nhưng cũng ngại ko dám trả lời câu hỏi của anh chỉ vì một lý do tế nhị là họ ko thích làm cao thủ! Anh hiểu chửa???


  • 0

#2003 thuyvan0210

thuyvan0210

    biết zoom

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

Đã gửi 17 May 2009 - 03:46 PM

Chào bạn thuyvan0210. Đây là Code mà Tue_NV viết theo ý của bạn. Hy vọng bạn hài lòng :


(defun c:SCD()
(vl-load-com)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 15359)

(setq olddim (getvar "dimzin"))

(setvar "dimzin" 0)
(setq mss (car(entsel "\n Chon mat so sanh :")))
(HLI mss)
(setq gtmss (getreal "\n Nhap gia tri mat so sanh :"))

(setq PL (car (entsel "\n Chon Pline :")))
(HLI PL)
(setq po (getpoint "\n Chon cac nut tren Polyline can ghi cao do :"))
(setq cao (getreal "\n Chon chieu cao chu :"))
(setq tp (getint "\n So chu so thap phan :"))

(while po

(setq po2 (vlax-curve-getClosestPointTo mss po))
(setq pot (list (car po2) (- (cadr po2) (/ cao 2)) 0))
(setq kc (+ (distance po po2) gtmss))
(Command "line" po po2 "")
(Command "style" "CADVIET" "TIMES.TTF" "0" "1" "0" "N" "N")
(Command "Text" "j" "BR" pot cao "90" (rtos kc 2 tp))
(HLI PL)
(setq po (getpoint "\n Chon cac nut tren Polyline can ghi cao do :"))

)
(setvar "dimzin" olddim)
(setvar "osmode" oldos)
(command "undo" "end")
(Princ)
)

;
(defun HLI(enT)
(sssetfirst (ssadd enT (ssadd)) (ssadd enT (ssadd)))
)

Trước tiên mình cảm ơn bạn! Nhưng mà đoạn lisp bạn viết nó cũng gần giống đoạn lisp của mình. Mình muốn chỉ chọn pline một lần duy nhất thôi, lisp sẽ tự định nghĩa các nút của pline đó, chứ ko phải chọn lại từng nút như vậy nữa. bạn xem lại hộ mình nhé!
  • 0

#2004 Tue_NV

Tue_NV

    KS Võ Quang Tuệ

  • Moderator
  • PipPipPipPipPipPipPip
  • 4296 Bài viết
Điểm đánh giá: 3804 (đỉnh cao)

Đã gửi 17 May 2009 - 04:08 PM

Trước tiên mình cảm ơn bạn! Nhưng mà đoạn lisp bạn viết nó cũng gần giống đoạn lisp của mình. Mình muốn chỉ chọn pline một lần duy nhất thôi, lisp sẽ tự định nghĩa các nút của pline đó, chứ ko phải chọn lại từng nút như vậy nữa. bạn xem lại hộ mình nhé!

Hy vọng lần này thì bạn hài lòng :

(defun c:SCD()
(vl-load-com)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)

(setq olddim (getvar "dimzin"))

(setvar "dimzin" 0)
(setq mss (car(entsel "\n Chon mat so sanh :")))
(HLI mss)
(setq gtmss (getreal "\n Nhap gia tri mat so sanh :"))

(setq PL (car (entsel "\n Chon Pline :")))
(HLI PL)

(setq pr (vlax-curve-getEndParam PL) i 0)

(setq cao (getreal "\n Chon chieu cao chu :"))
(setq tp (getint "\n So chu so thap phan :"))

(while (<= i pr)

(setq po (vlax-curve-getPointAtParam PL i))

(setq po2 (vlax-curve-getClosestPointTo mss po))
(setq pot (list (car po2) (- (cadr po2) (/ cao 2)) 0))
(setq kc (+ (distance po po2) gtmss))
(Command "line" po po2 "")
(Command "style" "CADVIET" "TIMES.TTF" "0" "1" "0" "N" "N")
(Command "Text" "j" "BR" pot cao "90" (rtos kc 2 tp))
(HLI PL)
(setq i (1+ i))

)
(setvar "dimzin" olddim)
(setvar "osmode" oldos)
(command "undo" "end")
(Princ)
)

;
(defun HLI(enT)
(sssetfirst (ssadd enT (ssadd)) (ssadd enT (ssadd)))
)

:mellow:
  • 0

#2005 thuyvan0210

thuyvan0210

    biết zoom

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

Đã gửi 17 May 2009 - 08:24 PM

[quote name='Tue_NV' date='May 17 2009, 16:08' post='60255']
Hy vọng lần này thì bạn hài lòng :

cảm ơn bạn nhiều, lisp rất đúngý mình. bây giờ rất cần những người nhiệt tình như bạn
  • 0

#2006 conghoan1003

conghoan1003

    biết vẽ point

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

Đã gửi 18 May 2009 - 09:24 AM

Chào cả nhà!
Mình đang cần cái lisp chèn một ký tự phía trước hoặc phía sau tấc cả các text mình chọn. Ai có cho mình xin với. Cảm ơn nhiều!
Chúc mọi người tuần làm việc hiệu quả!
  • 0
Học học nữa học mãi.
Đúp học lại!

#2007 duy782006

duy782006

    PHẠM QUỐC DUY

  • CADViet Team
  • PipPipPipPipPipPipPip
  • 2155 Bài viết
Điểm đánh giá: 1360 (rất tốt)

Đã gửi 18 May 2009 - 10:43 AM

Chào cả nhà!
Mình đang cần cái lisp chèn một ký tự phía trước hoặc phía sau tấc cả các text mình chọn. Ai có cho mình xin với. Cảm ơn nhiều!
Chúc mọi người tuần làm việc hiệu quả!

Xem đây:
http://www.cadviet.c...?showtopic=6991
  • 1

Cứ ngỡ trần gian là cõi thật.Cho nên tất bật đến bây giờ.
Tạo hộp thoại bằng lisp My blog QUY ĐỊNH ĐẶT TÊN TOPIC TRONG CHUYÊN MỤC LISPD http://ktsduy.wordpress.com/
Để cám ơn chỉ cần nhấn rep_up.png
(Là nhấn vào nút đó phía bài viết của người ta í chứ đừng có nhè cái hình này mà nhấn miết đi nha :-D


#2008 q288

q288

    biết lệnh fillet

  • Members
  • PipPipPipPip
  • 209 Bài viết
Điểm đánh giá: 164 (tàm tạm)

Đã gửi 18 May 2009 - 11:10 AM

Chào cả nhà!
Mình đang cần cái lisp chèn một ký tự phía trước hoặc phía sau tấc cả các text mình chọn. Ai có cho mình xin với. Cảm ơn nhiều!
Chúc mọi người tuần làm việc hiệu quả!


Nói chung lisp kiểu này chắc có nhiều trên diễn đàn này rồi, tuy nhiên mình cũng làm thêm 1 cái nữa. Lisp này chọn text, mtext và thêm vào đầu hay cuối ký tự chèn.
(defun c:ckt()
(vl-load-com)
(setq kt (getstring "Chen ky tu: ")
dc (strcase (getstring "Chen vao dau hay cuoi? :") t)
sst (ssget '((0 . "TEXT,MTEXT"))))
(while (and sst (> (sslength sst) 0))
(setq ven (ssname sst 0)
vob (vlax-ename->vla-object ven)
txt (vla-get-TextString vob))

(if (= dc "d")
(vla-put-TextString vob (strcat kt txt))
(vla-put-TextString vob (strcat txt kt)))
(ssdel ven sst)
)
)

  • 1

#2009 oanhvang

oanhvang

    biết zoom

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

Đã gửi 18 May 2009 - 12:57 PM

thanks các bạn
  • 0

#2010 q288

q288

    biết lệnh fillet

  • Members
  • PipPipPipPip
  • 209 Bài viết
Điểm đánh giá: 164 (tàm tạm)

Đã gửi 18 May 2009 - 12:59 PM

Nhân tiện mình cũng bổ sung chèn ký tự cho cả DIM nữa.
Lệnh này khi hỏi chèn đầu hay cuối, nếu đầu thì gõ "d" , còn nếu cuối thì enter cũng chạy đc.
(defun c:ckt()
(vl-load-com)
(setq kt (getstring "Chen ky tu: ")
dc (strcase (getstring "Chen vao dau hay cuoi? :") t)
sst (ssget '((0 . "TEXT,MTEXT,DIMENSION"))))
(while (and sst (> (sslength sst) 0))
(setq ven (ssname sst 0)
vob (vlax-ename->vla-object ven))

(if (member (vla-get-ObjectName vob) '("AcDbText" "AcDbMText"))
(if (= dc "d")
(vla-put-TextString vob (strcat kt (vla-get-TextString vob)))
(vla-put-TextString vob (strcat (vla-get-TextString vob) kt)))
(progn
(if (= "" (setq to (vla-get-TextOverride vob)))
(setq to "<>"))
(if (= dc "d")
(vla-put-TextOverride vob (strcat kt to))
(vla-put-TextOverride vob (strcat to kt))))
)
(ssdel ven sst)
)
)

  • 1

#2011 nguyenkhoadung98

nguyenkhoadung98

    biết vẽ pline

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

Đã gửi 18 May 2009 - 12:59 PM

chào cả nhà CADVIET, hồi trước mình có nhờ các bạn NDTVN, TUE_NV, THANHBINH viết cho mình cái lisp bắn cột đèn và bắn số cột đèn nôi dung của nó như sau :
nó sẽ tu dong rải cho mình 1 block trên 1 đoạn thẳng Pline hoặc SPline... sau đó nó sẽ đánh tên blog này theo thứ tự là T1/L1-1A rồi đến T1/L1-2B, T1/L1-3C, T1/L1-4A.....

bây giờ mình chỉ cần nó tu dong đánh số cho mình thôi mà kô cần rải blog kia nữa ( vì mình rải block sẵn rồi giờ chỉ đánh số thôi ) xin nhờ các bạn : lisp ấy đây

(defun GetDxf(n e) (cdr (assoc n e)))
(defun ModDxf(n v e)
(if (GetDxf n e)
(entmod (subst (cons n v) (assoc n e) e))
(entmod (append e (list (cons n v))))
)
)

(defun c:dsc ( / i k e ss plObj p0 p1 a0 a1 kc d d0 len om pre id inc pos asc las)
(defun TachTen(s)
(setq pre "T1/l1-" id 1 pos "" asc 97 las 0)
)
(defun TenCotKe()
(setq id (+ id inc))
(if asc (setq las (rem (1+ las) 3)))
(strcat pre (itoa id) pos (if asc (chr (+ asc las)) ""))
)
; Main program
(princ "\nChon doi tuong va text :")
(setq ss (ssget ) i -1)
(repeat (sslength ss)
(setq i (1+ i)e (entget (ssname ss i)) )
(if (= "INSERT" (GetDxf 0 e))
(setq p1 (GetDxf 10 e))
)
(if (= "TEXT" (GetDxf 0 e))
(progn (TachTen (GetDxf 1 e)) (setq k i) )
)
)
(setq plObj (car (entsel "\nHay chon duong polyline ")))
(if (not (and k plObj)) (quit))
(setq p0 (getpoint "\nChon diem goc de copy : "))
(if (not p0) (setq p0 p1))
(if (not (setq p0 (vlax-curve-getClosestPointTo plObj p0))) (quit))
(setq inc (getint "\nHay nhap he so tang giam <1> : "))
(if (not inc ) (setq inc 1) )
(setq d (getreal "\nChon khoang cach giua cac doi tuong: "))
(setq om (getvar "OSMODE")) (setvar "OSMODE" 0)
(setq a0 (angle '(0 0) (vlax-curve-getFirstDeriv plObj (vlax-curve-getParamAtPoint plObj p0))))
(setq d0 (vlax-curve-getDistAtPoint plObj p0))
(setq len (vlax-curve-getDistAtPoint plObj (vlax-curve-getEndPoint plObj)))
(if (< d0 (/ len 2))
(setq len (- len d0))
(setq len d0 d (- d))
)
(setq d0 (+ d0 d) i (fix (abs (/ len d))))
(while (and (> i 0) (setq p1 (vlax-curve-getpointatdist plObj d0)))
(setq a1 (angle '(0 0) (vlax-curve-getFirstDeriv plObj (vlax-curve-getParamAtPoint plObj p1))))
(command "COPY" ss "" p0 p0)
(command "MOVE" "P" "" p0 p1)
(command "ROTATE" "P" "" p1 (/ (* 180 (- a1 a0)) pi))
(setq e (entget (ssname ss k)))
(ModDxf 1 (TenCotKe) e)
(setq d0 (+ d0 d) p0 p1 a0 a1 i (1- i))
)
(setvar "OSMODE" om)


cam on cac ban
)
  • 0

#2012 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

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

Đã gửi 18 May 2009 - 05:34 PM

chào cả nhà CADVIET, hồi trước mình có nhờ các bạn NDTVN, TUE_NV, THANHBINH viết cho mình cái lisp bắn cột đèn và bắn số cột đèn nôi dung của nó như sau :
nó sẽ tu dong rải cho mình 1 block trên 1 đoạn thẳng Pline hoặc SPline... sau đó nó sẽ đánh tên blog này theo thứ tự là T1/L1-1A rồi đến T1/L1-2B, T1/L1-3C, T1/L1-4A.....

bây giờ mình chỉ cần nó tu dong đánh số cho mình thôi mà kô cần rải blog kia nữa ( vì mình rải block sẵn rồi giờ chỉ đánh số thôi ) xin nhờ các bạn : lisp ấy đây

(defun GetDxf(n e) (cdr (assoc n e)))
(defun ModDxf(n v e)
(if (GetDxf n e)
(entmod (subst (cons n v) (assoc n e) e))
(entmod (append e (list (cons n v))))
)
)

(defun c:dsc ( / i k e ss plObj p0 p1 a0 a1 kc d d0 len om pre id inc pos asc las)
(defun TachTen(s)
(setq pre "T1/l1-" id 1 pos "" asc 97 las 0)
)
(defun TenCotKe()
(setq id (+ id inc))
(if asc (setq las (rem (1+ las) 3)))
(strcat pre (itoa id) pos (if asc (chr (+ asc las)) ""))
)
; Main program
(princ "\nChon doi tuong va text :")
(setq ss (ssget ) i -1)
(repeat (sslength ss)
(setq i (1+ i)e (entget (ssname ss i)) )
(if (= "INSERT" (GetDxf 0 e))
(setq p1 (GetDxf 10 e))
)
(if (= "TEXT" (GetDxf 0 e))
(progn (TachTen (GetDxf 1 e)) (setq k i) )
)
)
(setq plObj (car (entsel "\nHay chon duong polyline ")))
(if (not (and k plObj)) (quit))
(setq p0 (getpoint "\nChon diem goc de copy : "))
(if (not p0) (setq p0 p1))
(if (not (setq p0 (vlax-curve-getClosestPointTo plObj p0))) (quit))
(setq inc (getint "\nHay nhap he so tang giam <1> : "))
(if (not inc ) (setq inc 1) )
(setq d (getreal "\nChon khoang cach giua cac doi tuong: "))
(setq om (getvar "OSMODE")) (setvar "OSMODE" 0)
(setq a0 (angle '(0 0) (vlax-curve-getFirstDeriv plObj (vlax-curve-getParamAtPoint plObj p0))))
(setq d0 (vlax-curve-getDistAtPoint plObj p0))
(setq len (vlax-curve-getDistAtPoint plObj (vlax-curve-getEndPoint plObj)))
(if (< d0 (/ len 2))
(setq len (- len d0))
(setq len d0 d (- d))
)
(setq d0 (+ d0 d) i (fix (abs (/ len d))))
(while (and (> i 0) (setq p1 (vlax-curve-getpointatdist plObj d0)))
(setq a1 (angle '(0 0) (vlax-curve-getFirstDeriv plObj (vlax-curve-getParamAtPoint plObj p1))))
(command "COPY" ss "" p0 p0)
(command "MOVE" "P" "" p0 p1)
(command "ROTATE" "P" "" p1 (/ (* 180 (- a1 a0)) pi))
(setq e (entget (ssname ss k)))
(ModDxf 1 (TenCotKe) e)
(setq d0 (+ d0 d) p0 p1 a0 a1 i (1- i))
)
(setvar "OSMODE" om)
cam on cac ban
)

Chào bạn nguyenkhoadung98,
Đọc kỹ lisp của bác ndtvn, bạn sẽ thấy bác ấy copy cả đối tượng block và text sang vị trí mới. Như vậy để có thể làm như ý của bạn bạn phải tách được đối tượng block ra khỏi tập chọn ss trước khi copy. Nhưng vì bạn vẫn muốn còn đối tượng block này tại vị trí đầu tiên khi chọn nên theo mình bạn có thể làm như sau:
1/- Sau khi bạn đã lấy được điểm chèn của block p1, hãy copy block này một lần tại ngay vị trí p1 đó.
2/- Xóa đối tượng block này khỏi tập chọn SS.
Nhờ vậy khi copy tập chọn ss về vị trí mới, bạn sẽ không có các block kèm theo nữa mà chỉ còn text thôi bạn ạ.

Bạn hãy thêm các dòng code dưới đây vào bên dưới dòng code (setq p1 (GetDxf 10 e)) trong hàm điều kiện If bạn nhé rồi chạy thử xem có OK không.
(command "copy" e "" p1 p1)
(command "erase" e "")
)
À quên, bạn phải thêm dòng code (progn vào trước dòng (setq p1 (GetDxf 10 e)) nữa nhé.
Vì chưa có thời gian nên mình chưa kiểm lại được mong bạn thông cảm nếu có sai sót nhé.
Chúc bạn thành công.
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#2013 BigBill

BigBill

    biết vẽ circle

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

Đã gửi 18 May 2009 - 10:01 PM

Nói chung lisp kiểu này chắc có nhiều trên diễn đàn này rồi, tuy nhiên mình cũng làm thêm 1 cái nữa. Lisp này chọn text, mtext và thêm vào đầu hay cuối ký tự chèn.

(defun c:ckt()
(vl-load-com)
(setq kt (getstring "Chen ky tu: ")
dc (strcase (getstring "Chen vao dau hay cuoi? :") t)
sst (ssget '((0 . "TEXT,MTEXT"))))
(while (and sst (> (sslength sst) 0))
(setq ven (ssname sst 0)
vob (vlax-ename->vla-object ven)
txt (vla-get-TextString vob))

(if (= dc "d")
(vla-put-TextString vob (strcat kt txt))
(vla-put-TextString vob (strcat txt kt)))
(ssdel ven sst)
)
)

không biết có ai biết lisp copy text ATT tăng dần không nhỉ,ví dụ e có 1 cái nút, đó là 1 block ATT, ngoài là 1 vòng tròn, trong là text ATT, bây giờ mình muốn copy nút này và text ATT nhảy theo?Mong mọi người giúp đỡ
  • 0

#2014 Tue_NV

Tue_NV

    KS Võ Quang Tuệ

  • Moderator
  • PipPipPipPipPipPipPip
  • 4296 Bài viết
Điểm đánh giá: 3804 (đỉnh cao)

Đã gửi 18 May 2009 - 10:37 PM

không biết có ai biết lisp copy text ATT tăng dần không nhỉ,ví dụ e có 1 cái nút, đó là 1 block ATT, ngoài là 1 vòng tròn, trong là text ATT, bây giờ mình muốn copy nút này và text ATT nhảy theo?Mong mọi người giúp đỡ

Bạn hãy đọc bài viết này nhé : Lisp copy tang dan vowi Block ATT
:mellow:
  • 0

#2015 baodenhp

baodenhp

    biết vẽ arc

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

Đã gửi 19 May 2009 - 02:34 PM

Mình muốn ghi nhãn đường đồng mức như file http://www.cadviet.c...les/nhan_DM.dwg ai có thể giúp mình với.
  • 0

#2016 nguyenkhoadung98

nguyenkhoadung98

    biết vẽ pline

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

Đã gửi 20 May 2009 - 02:17 PM

Chào bạn nguyenkhoadung98,
Đọc kỹ lisp của bác ndtvn, bạn sẽ thấy bác ấy copy cả đối tượng block và text sang vị trí mới. Như vậy để có thể làm như ý của bạn bạn phải tách được đối tượng block ra khỏi tập chọn ss trước khi copy. Nhưng vì bạn vẫn muốn còn đối tượng block này tại vị trí đầu tiên khi chọn nên theo mình bạn có thể làm như sau:
1/- Sau khi bạn đã lấy được điểm chèn của block p1, hãy copy block này một lần tại ngay vị trí p1 đó.
2/- Xóa đối tượng block này khỏi tập chọn SS.
Nhờ vậy khi copy tập chọn ss về vị trí mới, bạn sẽ không có các block kèm theo nữa mà chỉ còn text thôi bạn ạ.

Bạn hãy thêm các dòng code dưới đây vào bên dưới dòng code (setq p1 (GetDxf 10 e)) trong hàm điều kiện If bạn nhé rồi chạy thử xem có OK không.
(command "copy" e "" p1 p1)
(command "erase" e )
)
À quên, bạn phải thêm dòng code (progn vào trước dòng (setq p1 (GetDxf 10 e)) nữa nhé.
Vì chưa có thời gian nên mình chưa kiểm lại được mong bạn thông cảm nếu có sai sót nhé.
Chúc bạn thành công.



thanks bạn BINH, mình đã thử nhưng mà kô đuợc bạn ah, thực ra trong lisp ấy mình chỉ chọn têxt kô thôi thì nó cũng chỉ bắn text cho mình thôi, nhưng mà ý mình muốn text nó phải đứng cạnh block như cái ban đầu cơ, ở trong bản vẽ mình đã thể hiện :mellow: cảm ơn các bạn


http://www.mediafire...z/Drawing11.dwg
  • 0

#2017 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

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

Đã gửi 20 May 2009 - 07:23 PM

thanks bạn BINH, mình đã thử nhưng mà kô đuợc bạn ah, thực ra trong lisp ấy mình chỉ chọn têxt kô thôi thì nó cũng chỉ bắn text cho mình thôi, nhưng mà ý mình muốn text nó phải đứng cạnh block như cái ban đầu cơ, ở trong bản vẽ mình đã thể hiện :mellow: cảm ơn các bạn
http://www.mediafire...z/Drawing11.dwg

Xin lỗi bạn nguyen khoadung98.
Do vội nên đoạn code trước mình viết thiếu hai dâu "" trong hàm (command "erase" e) bạn ạ nên chắc khi bạn load lisp nó báo lỗi. Bạn thử sửa nó thành (command "erase" e "") xem sao.
Việc bạn muốn vị trí tương đối của text với block giữ nguyên thực ra là điều khá khó khăn vì để làm được điều đó cần xác định vị trí tương đối giữa điểm chèn của block và điểm chèn của text. Không những thế bạn còn phải xác định góc quay tương đối của chúng tại từng vị trí chèn so với vị trí ban đầu, rồi tính toán tọa độ điểm chèn mới của text sao cho phù hợp với góc quay đó và vẫn đảm bảo text không bị lộn ngược.
Việc này mình đã nói trước đây rồi. Bác ndtvn đã xử lý bằng cách copy chung cả text và block và như vậy là bác ấy đã chấp nhận ở một số trường hợp đặc biệt text và block sẽ cùng chổng tu đúng không bạn. Nay bạn lại tách rời chúng ra, nên gay thiệt. Việc giải bài toán lượng giác này (sin (a-:mellow:, cos(a-:cheers:.... rồi lúc thì cộng lúc thì trừ làm mình rối mù chưa gỡ ra được bạn ạ.
Hy vọng bạn hay các bác khác sẽ có cách giải quyết vấn đề triệt để hơn.
Chúc bạn vui.
  • 1
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#2018 nguyenkhoadung98

nguyenkhoadung98

    biết vẽ pline

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

Đã gửi 21 May 2009 - 10:24 AM

Xin lỗi bạn nguyen khoadung98.
Do vội nên đoạn code trước mình viết thiếu hai dâu "" trong hàm (command "erase" e) bạn ạ nên chắc khi bạn load lisp nó báo lỗi. Bạn thử sửa nó thành (command "erase" e "") xem sao.
Việc bạn muốn vị trí tương đối của text với block giữ nguyên thực ra là điều khá khó khăn vì để làm được điều đó cần xác định vị trí tương đối giữa điểm chèn của block và điểm chèn của text. Không những thế bạn còn phải xác định góc quay tương đối của chúng tại từng vị trí chèn so với vị trí ban đầu, rồi tính toán tọa độ điểm chèn mới của text sao cho phù hợp với góc quay đó và vẫn đảm bảo text không bị lộn ngược.
Việc này mình đã nói trước đây rồi. Bác ndtvn đã xử lý bằng cách copy chung cả text và block và như vậy là bác ấy đã chấp nhận ở một số trường hợp đặc biệt text và block sẽ cùng chổng tu đúng không bạn. Nay bạn lại tách rời chúng ra, nên gay thiệt. Việc giải bài toán lượng giác này (sin (a-:mellow:, cos(a-:cheers:.... rồi lúc thì cộng lúc thì trừ làm mình rối mù chưa gỡ ra được bạn ạ.
Hy vọng bạn hay các bác khác sẽ có cách giải quyết vấn đề triệt để hơn.
Chúc bạn vui.



đúng thế bạn ah, quả này chắc khó khăn đây, đành hài lòng với cái mình đã có vạy thôi :mellow: cảm ơn bạn rất nhiều :cheers:
  • 0

#2019 oanhvang

oanhvang

    biết zoom

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

Đã gửi 21 May 2009 - 02:37 PM

chào các bạn CADVIET, hôm nay mình nhờ các bạn viết giúp mình 1 lisp như thế này: mình có 1 lisp dùng để nối các đoạn PLINE với nhau lisp ấy đây :

(defun c:nn (/ tdt ssdt sodt index)
(defun ObjName (ssdt /)
(cdr (assoc '0 (entget ssdt)))
)
(defun MoPL (ssdt /)
(= (cdr (assoc '70 (entget ssdt))) 0)
)
(defun NoiPL (ssdt /)
(if (MoPL ssdt)
(command ".PEDIT" ssdt "J" "All" "" "X")
)
)
(defun NoiLC (ssdt /)
(command ".PEDIT" ssdt "Y" "J" "All" "" "X")
)
(setq
tdt (ssget)
sodt (sslength tdt)
index 0
)
(repeat sodt
(setq
ssdt (ssname tdt index)
index (1+ index)
)
(if (or (= (Objname ssdt) "LWPOLYLINE")
(= (Objname ssdt) "POLYLINE")
)
(NoiPL ssdt)
)
(if (or (= (Objname ssdt) "LINE") (= (Objname ssdt) "ARC"))
(NoiLC ssdt)
)
)
(princ)
)


bây h bản vẽ của mình bao gồm các PLINE nhưng mà nó lại bị cắt đi 1 đoạn nhỏ hoặc là bị chéo nhau 1 đoạn nhỏ. với kiểu như vậy thì lisp này nó kô nối được ( lại phải dùng lệnh PE hoặc filet ), mình mong các bạn cải tiến cái lisp này cho mình để sao cho nó có thể nối được luôn những đoạn như vậy mà kô cần phải dùng lệnh PE hoặc filet, mình gửi cùng bản vẽ. cảm ơn các bạn nhiều


http://www.2shared.c...8/Drawing1.html
  • 0

#2020 thiep

thiep

    biết dimbaseline

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

Đã gửi 21 May 2009 - 05:48 PM

Mình muốn ghi nhãn đường đồng mức như file http://www.cadviet.c...les/nhan_DM.dwg ai có thể giúp mình với.

Lisp này giúp cho bạn gần được như ý muốn:
http://www.cadviet.c.../TEXT_CAODO.lsp
Đây là bản vẽ của bạn, tôi đã test, trong đó, tôi có tạo block là "wip"
http://www.cadviet.c...s/nhan_DM_1.dwg
Tuy nhiên, vì text contuor của bạn là 1 group gồm 1 đối tượng wipeout và 1 đối tượng text, tôi chưa biết tạo mã cho group này. Có ai biết thì ra tay giúp với, cho dòng sông này chảy trôi êm đềm.
  • 1