Đến nội dung


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

Viết lisp theo yêu cầu [phần 2]


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

#2961 ngocnam.cad

ngocnam.cad

    biết vẽ ellipse

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

Đã gửi 27 December 2010 - 08:07 AM

bác Thái thân! em đã thử lisp edtn cua bác nhưng không được bác à.em làm thử trên file bác gửi thì được nhưng làm trên file em chạy ra thì không được .có lẽ vì trên file của bác khai báo đầu trắc ngang khác của em bác à. nên khi em thực hiện lệnh edtn thì cad không xóa bớt text đi mà lại thêm vào nhiều hơn bác à.. em gửi bác file của em nhờ bác xem giúp nguyên nhân bác nhé. :http://www.cadviet.com/upfiles/3/sua.dwg .em cám ơn bác nhiều lắm lắm.
  • 0

#2962 ngocnam.cad

ngocnam.cad

    biết vẽ ellipse

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

Đã gửi 27 December 2010 - 08:11 AM

các bác làm ơn cho em hỏi là trong nova có lệnh edtn cũng để làm thưa điểm mia . em chưa dùng lệnh đó bao giờ mà cũng chưa thấy mọi người sử dụng, mong các bác giải thích về lệnh đó cho em đc không a? nếu dùng lệnh đó mà không bị ảnh hưởng gì thì tốt quá ,
  • 0

#2963 Thaistreetz

Thaistreetz

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 903 Bài viết
Điểm đánh giá: 505 (tốt)

Đã gửi 27 December 2010 - 08:51 AM

Thôi để mình viết lại nó vậy.
EDTN là lệnh của nova2005. tuy nhiên thuật toán làm thưa mà nova sử dụng không hiệu quả cho lắm nên kết quả chưa triệt để, không muốn nói là tệ hơn. tuy nhiên với các trắc ngang chạy từ mặt bằng san nền của hạ tầng thì nó dùng được. sử dụng thế nào thì cứ thử đi. hộp thoại của nó rất rõ ràng mà.
  • 1

Hình đã gửi
IN HIM, I TRUST. THE TRUST IN MY GOD


#2964 trieubb

trieubb

    biết vẽ ellipse

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

Đã gửi 27 December 2010 - 10:14 AM

Em chào bác các bác!
em muốn các bác giúp em viết cái lisp chuyển các nét vẽ trong CAD sang Plaxis
File xuất ra là dạng .GEO để sang Plaxis em import nó vào
em đã xem trên web thấy có bác đã có "p2plaxis.lsp" đó là video bác ấy làm
em nhìn thấy nhưng không sao tìm thấy lisp tương tự
nhờ các bác giúp vì phải vẽ lại kết cấu trong Plaxis thì chết mất và không chuẩn nữa
mong các bác giúp đỡ.
  • 0

#2965 ngocnam.cad

ngocnam.cad

    biết vẽ ellipse

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

Đã gửi 27 December 2010 - 11:14 AM

Thôi để mình viết lại nó vậy.
EDTN là lệnh của nova2005. tuy nhiên thuật toán làm thưa mà nova sử dụng không hiệu quả cho lắm nên kết quả chưa triệt để, không muốn nói là tệ hơn. tuy nhiên với các trắc ngang chạy từ mặt bằng san nền của hạ tầng thì nó dùng được. sử dụng thế nào thì cứ thử đi. hộp thoại của nó rất rõ ràng mà.

vâng. em biết sử dụng cái lệnh edtn trong nv2005 rồi ạ. bác giúp em sửa lisp theo đầu trắc ngang của em bác nhé. em cám ơn bác đã hồi âm. mong tin bác !
  • 0

#2966 tiendaica

tiendaica

    biết zoom

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

Đã gửi 27 December 2010 - 02:39 PM

THƯA CÁC BẠN! MÌNH NHỜ CÁC BẠN VIẾT GIÙM MÌNH LISP KICK TOA CỌC ! ĐẦU TIÊN LÀ CHẠY LISP SAU ĐÓ ĐÁNH TÊN CỌC ENTER NHÂP TIẾP CAO ĐỘ KICK CHUỘT VÀO VỊ TRÍ CẦN TÌM XY TƯƠNG TU ĐẾN ĐIỂM TIẾP THEO CŨNG NHẬP TƯƠNG TỰ VÀ CUỐI CÙNG CHON VỊ TRÍ CHO RA KẾT QUẢ DẠNG BẢNG (TEN COC X Y H HOẶC TÊN CỌC H X Y)NHƯ FILE CAD MINH GỬI ! MONG CÁC BẠN GIÚP ĐỠ!MÌNH CÁM ƠN TRƯỚC
http://www.cadviet.c.../bd_tong_in.dwg
  • 0

#2967 duyhung

duyhung

    biết vẽ rectang

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

Đã gửi 27 December 2010 - 02:51 PM

Nhờ ae sửa hộ mình một chút cái lisp này:
- Cái lisp này là bố trí block theo yêu cầu của mình với điều kiện khoảng cách 2 block = 2 lần khoảng cách từ block tới cạnh của HCN.
- Mình muốn sửa một chút là vẫn nhập các điểm của HCN, số block theo trục x, số block theo trục y nhưng với điều kiện hơi khác một chút đó là khoảng cách 2 block theo trục x= 1200x số block theo trục x, còn khoảng cách 2 block theo trục y= 600x số block theo trục y.
;; free lisp from cadviet.com


(defun c:dd ()
(batdau)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(command "osnap" "End,Mid,Cen,Node,Quad,Int,Ins,Perp,Tan,Near,App,Int,Ext,Par")
(setq bd (car (entsel "\nChon block can chen: ")))
(while (= bd nil)
(setq bd (car (entsel "\nChon block can chen: ")))
)
(setq boun (acet-ent-geomextents bd)
tam (polar (car boun) (angle (car boun) (cadr boun))
(/ (distance (car boun) (cadr boun)) 2))
)
(setq p1 (getpoint "\nChon diem thu nhat: ")
p2 (getcorner p1 "\nChon diem thu hai: ")
vx (abs (- (car p1) (car p2)))
vy (abs (- (cadr p1) (cadr p2)))
ix (getint "\nSo block theo truc x: ")
iy (getint "\nSo block theo truc y: ")
dix (/ vx (* ix 2))
diy (/ vy (* iy 2))
)
(if (< (angle p1 p2) (/ pi 2))
(setq pc (list (+ (car p1) dix) (+ (cadr p1) diy) 0))
)
(if (and (< (angle p1 p2) pi) (> (angle p1 p2) (/ pi 2)))
(progn
(setq p1 (list (car p2) (cadr p1) 0))
(setq pc (list (+ (car p1) dix) (+ (cadr p1) diy) 0))
)
)
(if (and (< (angle p1 p2) (/ (* pi 3) 2)) (> (angle p1 p2) pi))
(setq pc (list (+ (car p2) dix) (+ (cadr p2) diy) 0))
)
(if (and (< (angle p1 p2) (* pi 2)) (> (angle p1 p2) (/ (* pi 3) 2)))
(progn
(setq p1 (list (car p1) (cadr p2) 0))
(setq pc (list (+ (car p1) dix) (+ (cadr p1) diy) 0))
)
)
(setq sspoi (ssadd))
(command "copy" bd "" tam pc)
(repeat (1- ix)
(setq poi (entlast))
(setq sspoi (ssadd poi sspoi))
(command "copy" poi "" pc
(strcat "@" (rtos (* dix 2) 2 3) ",0")
)
)
(setq sspoi (ssadd (entlast) sspoi))
(setq y 0)
(repeat (1- iy)
(setq y (+ y (* diy 2)))
(command "copy" sspoi "" pc
(strcat "@0," (rtos y 2 3))
)
)
(setvar "osmode" oldos)
(ketthuc)
)

(defun batdau ()
(command "undo" "be")
(setvar "cmdecho" 0)
(setq
old_er *error*
*error* myerror
)
)

(defun myerror (errmsg)
(ketthuc)
(command "undo" "")
)

(defun ketthuc ()
(setq *error* old_er)
(setvar "cmdecho" 1)
(command "undo" "e")
)

Và đây là file cad mình muốn
Hình đã gửi
  • 0
Song va chien dau!

#2968 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 27 December 2010 - 04:22 PM

Bạn thử xem đã vừa ý chưa :undecided:

;; free lisp from cadviet.com


(defun c:dd ()
(batdau)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(command "osnap" "End,Mid,Cen,Node,Quad,Int,Ins,Perp,Tan,Near,App,Int,Ext,Par")
(setq bd (car (entsel "\nChon block can chen: ")))
(while (= bd nil)
(setq bd (car (entsel "\nChon block can chen: ")))
)
(setq boun (acet-ent-geomextents bd)
tam (polar (car boun) (angle (car boun) (cadr boun))
(/ (distance (car boun) (cadr boun)) 2))
)
(setq p1 (getpoint "\nChon diem thu nhat: ")
p2 (getcorner p1 "\nChon diem thu hai: ")
vx (abs (- (car p1) (car p2)))
vy (abs (- (cadr p1) (cadr p2)))
ix (getint "\nSo block theo truc x: ")
iy (getint "\nSo block theo truc y: ")
)
(setq dx (getreal "\nKhoang cach x : ")) (if (null dx)(setq dx 1200))
(setq dy (getreal "\nKhoang cach y : ")) (if (null dy)(setq dy 600))

(setq
dix ( / (- vx (* dx (- ix 1))) 2)
diy ( / (- vy (* dy (- iy 1))) 2)
)

(if (< (angle p1 p2) (/ pi 2))
(setq pc (list (+ (car p1) dix ) (+ (cadr p1) diy ) 0))
)
(if (and (< (angle p1 p2) pi) (> (angle p1 p2) (/ pi 2)))
(progn
(setq p1 (list (car p2) (cadr p1) 0))
(setq pc (list (+ (car p1) dix ) (+ (cadr p1) diy ) 0))
)
)
(if (and (< (angle p1 p2) (/ (* pi 3) 2)) (> (angle p1 p2) pi))
(setq pc (list (+ (car p2) dix ) (+ (cadr p2) diy ) 0))
)
(if (and (< (angle p1 p2) (* pi 2)) (> (angle p1 p2) (/ (* pi 3) 2)))
(progn
(setq p1 (list (car p1) (cadr p2) 0))
(setq pc (list (+ (car p1) dix ) (+ (cadr p1) diy ) 0))
)
)
(setq sspoi (ssadd))
(command "copy" bd "" tam pc)
(repeat (1- ix)
(setq poi (entlast))
(setq sspoi (ssadd poi sspoi))
(command "copy" poi "" pc
(strcat "@" (rtos dx 2 3) ",0")
;(strcat "@" (rtos (* dix 2) 2 3) ",0")
)
)
(setq sspoi (ssadd (entlast) sspoi))
(setq y 0)
(repeat (1- iy)
(setq y (+ y dy))
(command "copy" sspoi "" pc
(strcat "@0," (rtos y 2 3))
)
)
(setvar "osmode" oldos)
(ketthuc)
)

(defun batdau ()
(command "undo" "be")
(setvar "cmdecho" 0)
(setq
old_er *error*
*error* myerror
)
)

(defun myerror (errmsg)
(ketthuc)
(command "undo" "")
)

(defun ketthuc ()
(setq *error* old_er)
(setvar "cmdecho" 1)
(command "undo" "e")
)

  • 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


#2969 Thaistreetz

Thaistreetz

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 903 Bài viết
Điểm đánh giá: 505 (tốt)

Đã gửi 27 December 2010 - 06:07 PM

@NgocNam.Cad
Lisp này cách làm việc vẫn tương tự lisp cũ. Vì mình không tin tưởng việc làm thưa tự động (lại giống Nova thì bằng nhau) nên lisp vẫn yêu cầu xóa thủ công các đường dóng sao cho hợp lý nhất.
(chú ý: không được xóa đường dóng ngoài cùng bên trái mỗi trắc ngang vì lisp lấy đường này làm mốc tính toán)
Sau khi đã làm thưa đường dóng trên trắc ngang thì chạy lisp này. Tại dòng nhắc "Chọn trắc ngang cần sửa" chỉ cần chọn 1 đối tượng bất kỳ trên trắc ngang là được. Lisp này có thể chạy cả trong môi trường cad và nova mà không ảnh hưởng đến kết quả chạy nova. nếu gặp lỗi gì thì thông báo lại cho mình.
Lisp post bằng code của diễn đàn bị lỗi nên bạn download tại đây Njoy n' Have fun :undecided:
  • 1

Hình đã gửi
IN HIM, I TRUST. THE TRUST IN MY GOD


#2970 thanhvienmoi1981

thanhvienmoi1981

    biết pan

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

Đã gửi 27 December 2010 - 08:35 PM

Của bác đây.em đã save xuống cad 2004 cho bác rùii.
http://www.cadviet.c...s/3/gui_bac.rar

Cám ơn bác đã giúp, nhưng bác Phamvanthiet108 ơi sau địa chỉ nảy không tải về được (không tìm thấy file trên server) bác gửi lại dùm.
  • 0

#2971 hoanthanh2010

hoanthanh2010

    biết pan

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

Đã gửi 27 December 2010 - 10:27 PM

THƯA CÁC BẠN! MÌNH NHỜ CÁC BẠN VIẾT GIÙM MÌNH LISP KICK TOA CỌC ! ĐẦU TIÊN LÀ CHẠY LISP SAU ĐÓ ĐÁNH TÊN CỌC ENTER NHÂP TIẾP CAO ĐỘ KICK CHUỘT VÀO VỊ TRÍ CẦN TÌM XY TƯƠNG TU ĐẾN ĐIỂM TIẾP THEO CŨNG NHẬP TƯƠNG TỰ VÀ CUỐI CÙNG CHON VỊ TRÍ CHO RA KẾT QUẢ DẠNG BẢNG (TEN COC X Y H HOẶC TÊN CỌC H X Y)NHƯ FILE CAD MINH GỬI ! MONG CÁC BẠN GIÚP ĐỠ!MÌNH CÁM ƠN TRƯỚC
http://www.cadviet.c.../bd_tong_in.dwg

không phải là mình viết, nhưnng mình có lips đó bàn dùng thử nha!
http://www.cadviet.c...s/3/vmc_tbd.lsp
  • 0

#2972 phamvanthiet108

phamvanthiet108

    biết vẽ polygon

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

Đã gửi 27 December 2010 - 11:05 PM

Cám ơn bác đã giúp, nhưng bác Phamvanthiet108 ơi sau địa chỉ nảy không tải về được (không tìm thấy file trên server) bác gửi lại dùm.

của bác đây.
http://www.cadviet.c...s/3/gui_bac.rar
  • 0

#2973 hugo75

hugo75

    biết vẽ polygon

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

Đã gửi 28 December 2010 - 11:19 AM

Trên diễn đàn có 1 lisp vẽ mặt cắt dầm:

;; free lisp from cadviet.com
(defun c:MCD (/ A B C BV D E D1 E1 F P1 P2 S)
(setq oldosmode (getvar "osmode"))
(setvar "osmode" 0)
(setq
A (getreal "\nBe rong mc DAM:")
B (getreal "\nBe dai mc DAM:")
S (getreal "\nBe day san:")
BV (getreal "\nLop bv mc DAM:")
D (getint "\nS.luong thep ngang mc DAM:")
E (getint "\nS.luong thep doc mc DAM:")
P1 (getpoint "\nDiem chen:")
F (* bv 0.7)
D1 (/ (- A (* 2 BV) (* F 2)) (- D 1))
E1 (/ (- B (* 2 BV) (* F 2)) (- E 1))
); end of setq
(command ".rectangle" "f" (* bv 0.5) (list (+ (car P1) BV) (+ (cadr P1) BV))
(list (+ (car P1) (- A BV)) (+ (cadr P1) (- B BV))) "" "f" "0" ""
".change" "L" "" "P" "C" 1 ""
".pline" (Polar P1 0 (/ A 2)) "W" 0 0
P1
(setq P11 (list (car P1) (+ (cadr P1) (- B S))))
(setq P11 (list (- (car P11) (* 2 S)) (cadr P11)))
(list (car P11) (- (cadr P11) (* 0.4 S)))
(setq P11 (list (car P11) (+ (cadr P11) (* 0.4 S))))
(setq P11 (list (- (car P11) (* 0.4 S)) (cadr P11)))
(setq P11 (list (+ (car P11) (* 0.8 S)) (+ (cadr P11) (* 0.2 S))))
(setq P11 (list (- (car P11) (* 0.4 S)) (cadr P11)))
(list (car P11) (+ (cadr P11) (* 0.8 S)))
(setq P11 (list (car P11) (+ (cadr P11) (* 0.4 S))))
(setq P11 (list (+ (car P11) (* 2 S) (/ A 2)) (cadr P11)))
""
".mirror" "L" "" (Polar P1 0 (/ A 2)) P11 ""
".pedit" "l" "j" "p" "l" "" ""

); end of command
(setq P2 (list (+ (car P1) BV F) (+ (cadr P1) BV F)))
(repeat D
(command ".donut" 0 F P2 ^C)
(setq P2 (polar P2 0 D1))
); end of repeat1
(setq P2 (list (+ (car P1) BV F) (+ (cadr P1) (- B BV F) )))
(repeat D
(command ".donut" 0 F P2 ^C)
(setq P2 (polar P2 0 D1))
); end of repeat2
(setq P2 (list (+ (car P1) BV F) (+ (cadr P1) BV F)))
(repeat (- E 2)
(setq P2 (polar P2 (/ pi 2) E1))
(command ".donut" 0 F P2 ^C)
); end of repeat3
(setq P2 (list (+ (car P1) (- A BV F)) (+ (cadr P1) BV F)))
(repeat (- E 2)
(setq P2 (polar P2 (/ pi 2) E1))
(command ".donut" 0 F P2 ^C)
); end of repeat3
(setvar "osmode" oldosmode)
)
Giả sử mình có sẵn 4 layer tên là:1,2,3,4 vậy mình muốn gán cho đường bao là layer 1 ,dấu cắt là số 2,chấm tròn thép là số
3,thép đai là số 4 thì phải sửa làm sao trong lisp này.Các bác thông cảm e đã viết bài này trong mục khác nhưng hình như mục đó ít cao thủ vào đọc nên mạn phép cho e viết vào mục này.Mong được sự giúp đỡ của các bác.Thanks

Không bác nào giúp được e sao?Mong các bác ra tay giúp đỡ.Thanks
  • 0

#2974 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 28 December 2010 - 01:10 PM

Bấn quá thì bạn dùng tạm nhé.Chỗ nét cắt thì bác ấy viết liền thành 1 nét rùi,giờ nghỉ trưa mình hơi ngại edit ^^


;; free lisp from cadviet.com
(defun c:MCD (/ A B C BV D E D1 E1 F P1 P2 S)
(setq oldosmode (getvar "osmode"))
(setvar "osmode" 0)
(setq
A (getreal "\nBe rong mc DAM:")
B (getreal "\nBe dai mc DAM:")
S (getreal "\nBe day san:")
BV (getreal "\nLop bv mc DAM:")
D (getint "\nS.luong thep ngang mc DAM:")
E (getint "\nS.luong thep doc mc DAM:")
P1 (getpoint "\nDiem chen:")
F (* bv 0.7)
D1 (/ (- A (* 2 BV) (* F 2)) (- D 1))
E1 (/ (- B (* 2 BV) (* F 2)) (- E 1))
); end of setq
(setvar "clayer" "4")
(command ".rectangle" "f" (* bv 0.5) (list (+ (car P1) BV) (+ (cadr P1) BV))
(list (+ (car P1) (- A BV)) (+ (cadr P1) (- B BV))) "" "f" "0" "")
;".change" "L" "" "P" "C" 1 ""
(setvar "clayer" "1")
(command ".pline" (Polar P1 0 (/ A 2)) "W" 0 0
P1
(setq P11 (list (car P1) (+ (cadr P1) (- B S))))
(setq P11 (list (- (car P11) (* 2 S)) (cadr P11)))
(list (car P11) (- (cadr P11) (* 0.4 S)))
(setq P11 (list (car P11) (+ (cadr P11) (* 0.4 S))))
(setq P11 (list (- (car P11) (* 0.4 S)) (cadr P11)))
(setq P11 (list (+ (car P11) (* 0.8 S)) (+ (cadr P11) (* 0.2 S))))
(setq P11 (list (- (car P11) (* 0.4 S)) (cadr P11)))
(list (car P11) (+ (cadr P11) (* 0.8 S)))
(setq P11 (list (car P11) (+ (cadr P11) (* 0.4 S))))
(setq P11 (list (+ (car P11) (* 2 S) (/ A 2)) (cadr P11)))
""
".mirror" "L" "" (Polar P1 0 (/ A 2)) P11 ""
".pedit" "l" "j" "p" "l" "" ""
); end of command
(setvar "clayer" "3")
(setq P2 (list (+ (car P1) BV F) (+ (cadr P1) BV F)))
(repeat D
(command ".donut" 0 F P2 ^C)
(setq P2 (polar P2 0 D1))
); end of repeat1
(setq P2 (list (+ (car P1) BV F) (+ (cadr P1) (- B BV F) )))
(repeat D
(command ".donut" 0 F P2 ^C)
(setq P2 (polar P2 0 D1))
); end of repeat2
(setq P2 (list (+ (car P1) BV F) (+ (cadr P1) BV F)))
(repeat (- E 2)
(setq P2 (polar P2 (/ pi 2) E1))
(command ".donut" 0 F P2 ^C)
); end of repeat3
(setq P2 (list (+ (car P1) (- A BV F)) (+ (cadr P1) BV F)))
(repeat (- E 2)
(setq P2 (polar P2 (/ pi 2) E1))
(command ".donut" 0 F P2 ^C)
); end of repeat3
(setvar "osmode" oldosmode)
)


  • 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


#2975 gaconcuaem

gaconcuaem

    Chưa sử dụng CAD

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

Đã gửi 28 December 2010 - 01:39 PM

Chào các bạn, mình có tìm trên diễn đàn Lisp Cộng, trừ, nhân, chia 1 dãy số cho 1 số. Nhưng không tìm thấy 1 dãy số trên trừ cho dãy số dưới, bạn nào có thể viết Lisp như vậy được ko, Thanks nhiều :undecided:.
Vd :
dãy 1 : 1 3 4 2 6 7 8
dãy 2 : 3 5 5 7 8 8 8
-----------------------------------
(dãy 1- dãy 2) : -2-2-1-5-2-10
PS Nếu Có rồi thì post dùm mình vì mình tìm chỉ thấy lisp tính toán mà ko thấy cái mình cần, cám ơn!
  • 0

#2976 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 28 December 2010 - 02:41 PM

Cái này @bác Sì trít, vừa mới có rì quét mấy hôm thì phải

;; free lisp from cadviet.com

;===========================================================================
(prompt"\nCmd:SRT- [Cong-Tru-Nhan-Chia 2 hang TEXT] by Thaistreetz - huuthais@yahoo.com\n")
;===========================================================================
(defun c:srt (/ cmd ss lst data i lst1 lst2)
(setq ctnc (cond (ctnc) ("Cong")))
(initget "Cong Tru Nhan CHia")
(setq ctnc (cond ((getkword (strcat "\nChon phep tinh: [Cong/Tru/Nhan/CHia/] <" ctnc ">"))) (ctnc)))
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(command "ucs" "world")
(prompt"\nChon hang-cot text thu nhat\n")
(if (setq ss1 (ssget (list (cons 0 "TEXT"))))
(progn
(setq lst1 (vl-sort (mapcar 'entget (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss1))))
'(lambda (x y) (if (equal (car(setq x1 (cdr (assoc 10 x)))) (car(setq y1 (cdr (assoc 10 y)))))
(> (cadr x1) (cadr y1)) (< (car x1) (car y1))))))))
(prompt"\nChon hang-cot text thu 2\n")
(if (setq ss2 (ssget (list (cons 0 "TEXT"))))
(if (< (- (cadr (cdr(assoc 10 (nth 0 lst1)))) (cadr (cdr(assoc 10 (nth 1 lst1)))))
(- (car (cdr(assoc 10 (nth 1 lst1)))) (car (cdr(assoc 10 (nth 0 lst1))))))
(setq lst2 (vl-sort (mapcar 'entget (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss2))))
'(lambda (x y) (if (equal (car(setq x2 (cdr (assoc 10 x)))) (car(setq y2 (cdr (assoc 10 y)))))
(> (cadr x2) (cadr y2)) (< (car x2) (car y2))))))
(setq lst2 (vl-sort (mapcar 'entget (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss2))))
'(lambda (x y) (if (equal (car(setq x2 (cdr (assoc 10 x)))) (car(setq y2 (cdr (assoc 10 y)))))
(< (cadr x2) (cadr y2)) (> (car x2) (car y2))))))
))
(if (/= (sslength ss2) (sslength ss1)) (alert "\n Hai tap hop text co so \ndoi tuong khong bang nhau!")
(progn
(setq ptkq (getpoint "\nChon diem ghi ket qua hoac enter de ghi ket qua vao hang-cot text khac\n"))
(if (= ptkq nil)
(progn
(prompt"\nChon hang-cot text ghi ket qua\n")
(if (setq ss3 (ssget (list (cons 0 "TEXT"))))
(progn
(setq lst3 (vl-sort (mapcar 'entget (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss3))))
'(lambda (x y) (if (equal (car(setq x3 (cdr (assoc 10 x)))) (car(setq y3 (cdr (assoc 10 y)))))
(> (cadr x3) (cadr y3)) (< (car x3) (car y3))))))))
(if (/= (sslength ss2) (sslength ss3)) (alert "\nTap hop text ghi ket qua \nthua hoac thieu doi tuong!"))
);progn
);if
);progn
);if
;----------------------------------
(command "undo" "be")
(setq angbs (getvar "angbase"))
(setq oldos (getvar "osmode"))
(setq Ladim (getvar "Dimzin"))
(setq olstyle (getvar "textstyle"))
(setq olcol (getvar "CEColor"))
(setvar "Dimzin" 0)
(setq txti 0)

(while (< txti (sslength ss1))
(if (eq ctnc "Cong") (setq kqi (+ (atof (cdr(assoc 1 (nth txti lst1)))) (atof (cdr(assoc 1 (nth txti lst2)))))))
(if (eq ctnc "Tru") (setq kqi (- (atof (cdr(assoc 1 (nth txti lst1)))) (atof (cdr(assoc 1 (nth txti lst2)))))))
(if (eq ctnc "Nhan") (setq kqi (* (atof (cdr(assoc 1 (nth txti lst1)))) (atof (cdr(assoc 1 (nth txti lst2)))))))
(if (eq ctnc "CHia") (setq kqi (/ (atof (cdr(assoc 1 (nth txti lst1)))) (atof (cdr(assoc 1 (nth txti lst2)))))))
(if ptkq
(progn
(if (< (- (cadr (cdr(assoc 10 (nth 0 lst1)))) (cadr (cdr(assoc 10 (nth 1 lst1)))))
(- (car (cdr(assoc 10 (nth 1 lst1)))) (car (cdr(assoc 10 (nth 0 lst1))))))
(setq ptkqi (list (car (cdr(assoc 10 (nth txti lst1)))) (cadr ptkq)))
(setq ptkqi (list (car ptkq) (cadr (cdr(assoc 10 (nth txti lst1)))))))
(command "textstyle" (cdr(assoc 7 (nth txti lst1))) "osmode" 0 "angbase" 0 "color" 1)
(command "text" ptkqi (cdr(assoc 40 (nth txti lst1))) (/ (* 180 (cdr(assoc 50 (nth txti lst1)))) pi) (rtos kqi 2 2))
);progn
(entmod (subst (cons 1 (rtos kqi 2 2)) (assoc 1 (nth txti lst3)) (nth txti lst3)))
);if
(setq txti (1+ txti))
);while
;----------------------------------
(command "ucs" "p")
(setvar "textstyle" olstyle)
(setvar "Dimzin" Ladim)
(setvar "CECOLOR" olcol)
(setvar "angbase" angbs)
(setvar "osmode" oldos)
(command "undo" "e")
(setvar "cmdecho" cmd)
(princ)
)

  • 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


#2977 thanhvienmoi1981

thanhvienmoi1981

    biết pan

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

Đã gửi 28 December 2010 - 10:55 PM

Cám ơn bác PhamvanThiet108 nhiều, chúc bác và các bác trên diễn đàn năm mới vui vẻ hạnh phúc thành đạt nhé
:undecided:
  • 0

#2978 ngocnam.cad

ngocnam.cad

    biết vẽ ellipse

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

Đã gửi 29 December 2010 - 08:05 AM

@NgocNam.Cad
Lisp này cách làm việc vẫn tương tự lisp cũ. Vì mình không tin tưởng việc làm thưa tự động (lại giống Nova thì bằng nhau) nên lisp vẫn yêu cầu xóa thủ công các đường dóng sao cho hợp lý nhất.
(chú ý: không được xóa đường dóng ngoài cùng bên trái mỗi trắc ngang vì lisp lấy đường này làm mốc tính toán)
Sau khi đã làm thưa đường dóng trên trắc ngang thì chạy lisp này. Tại dòng nhắc "Chọn trắc ngang cần sửa" chỉ cần chọn 1 đối tượng bất kỳ trên trắc ngang là được. Lisp này có thể chạy cả trong môi trường cad và nova mà không ảnh hưởng đến kết quả chạy nova. nếu gặp lỗi gì thì thông báo lại cho mình.
Lisp post bằng code của diễn đàn bị lỗi nên bạn download tại đây Njoy n' Have fun :undecided:

cám ơn bác rất nhiều. em dùng rồi .lisp dùng rất tốt bác à. thaks bác nhiều.chúc bác và gd mạnh khỏe
  • 1

#2979 ngocnam.cad

ngocnam.cad

    biết vẽ ellipse

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

Đã gửi 29 December 2010 - 08:53 AM

bác vuvuzela đâu rùi nhỉ?
  • 0

#2980 ngocnam.cad

ngocnam.cad

    biết vẽ ellipse

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

Đã gửi 29 December 2010 - 08:57 AM

chờ tin bác vuvu lâu quá bác à.
  • 0