PDA

View Full Version : Tổng hợp các Lisp phục vụ cho Giao Thông



lenhan
31/10/09, 09:40 AM
Bài này hay nên mình giới thiệu, hy vọng có ích cho các bạn

Tại đây sẽ tổng hợp các lisp phục vụ cho chuyên ngành Giao Thông. Các bạn có thể nêu yêu cầu (nêu rõ đầy đủ dữ liệu đầu vào, mong muốn kết quả, có thể minh họa bằng hình ảnh và file Cad là tốt nhất).
Đầu tiên là lisp: Số hóa đường đồng mức. Lệnh CDM -> sẽ cho ra 2 lựa chọn
+ Lựa chọn thứ nhất : Số hóa theo bước ( B ) sẽ giúp bạn số hóa 1 cách liên tục và nhanh
+Lựa chọn thứ hai : Số hóa theo Text cao độ có sẵn ( T ) sẽ giúp bạn đưa cao độ của đường Polyline cần số hóa theo Text có sẵn.


(defun C:CDM (/ cdo next dem)
(setq phuongan (I_KEY "\nChon kieu nhap (theo Buoc lien tuc/theo Text co san)" "B T" phuongan))
(cond ( (= phuongan "B")
(setq cdo (I_REAL "\n Nhap cao do ban dau" cdo)
ccao (I_REAL "\n Nhap chenh cao giua cac duong dong muc" ccao)
insT (I_KEY "\nCo insert Text vao duong dong muc khong? <Yes,No>" "Y N" insT)
next (strcat "dau tien (cao do la: " (rtos cdo 2 2) ")")
dem 0
)
(if (and (= insT "Y") (null Tmaucd))
(setq Tmaucd (entget (ssname (ES_TM "\nChon text mau...") 0)))
)
(while (setq pline (entsel (strcat "\n Chon duong dong muc " next)))
(if (and (or (= (cdr (assoc 0 (entget (car pline)))) "POLYLINE")
(= (cdr (assoc 0 (entget (car pline)))) "LWPOLYLINE")
)
(/= (cdr (assoc 8 (entget (car pline)))) "DM so hoa")
)
(progn
(cond ( (= (length (assoc 10 (entget (car pline)))) 4)
(setq tdN (R_POS (assoc 10 (entget (car pline))) (list 0.0 0.0 0.0 cdo) "z"))
(entmod (subst tdN (assoc 10 (entget (car pline))) (entget (car pline))))
)
( (= (length (assoc 10 (entget (car pline)))) 3)
(entmod (subst (cons 38 cdo) (assoc 38 (entget (car pline))) (entget (car pline))))
)
)
(entmod (subst (cons 8 "DM so hoa") (assoc 8 (entget (car pline))) (entget (car pline))))
(setq dem (1+ dem)
cdo (+ cdo ccao)
next (strcat "thu " (itoa dem) " (cao do la: " (rtos cdo 2 2) ") /An enter de ket thuc chon")
)
(command "osmode" 2)
(while (setq pos (getpoint "\nVi tri dat text/Enter de ket thuc..."))
(command "osmode" 1)
(setq p1 (getpoint "\nchon diem lay huong thu 1...")
p2 (getpoint "\nchon diem lay huong thu 2...")
ang (angle p1 p2)
pos (polar pos (+ ang (/ pi 2)) (/ (cdr (assoc 40 Tmaucd)) 3))
text (subst (cons 11 pos) (assoc 11 Tmaucd) Tmaucd)
text (subst (cons 50 ang) (assoc 50 text) text)
text (subst (cons 72 1) (assoc 72 text) text)
)
(entmake text)
(command "osmode" 2)

)

)
(alert "Chon lai!!! . Doi tuong ban vua chon khong phai la Polyline hoac da duoc so hoa")
)
)
)
( (= phuongan "T")

(while (and (not (prompt "\n Chon duong dong muc /Enter de ket thuc... " ))
(setq pline (if (setq ss (ssget '((-4 . "<OR") (0 . "POLYLINE") (0 . "LWPOLYLINE") (-4 . "OR>"))))
(ssname ss 0)
nil)
)
)
(setq cdo (V_T (ssname (ES_TM "\nChon Text chua cao do") 0)))
(if (and (or (= (cdr (assoc 0 (entget pline))) "POLYLINE")
(= (cdr (assoc 0 (entget pline))) "LWPOLYLINE")
)
(/= (cdr (assoc 8 (entget pline))) "DM so hoa")
)
(progn
(cond ( (= (length (assoc 10 (entget pline))) 4)
(setq tdN (R_POS (assoc 10 (entget (car pline))) (list 0.0 0.0 0.0 cdo) "z"))
(entmod (subst tdN (assoc 10 (entget (car pline))) (entget (car pline))))
)
( (= (length (assoc 10 (entget pline))) 3)
(entmod (subst (cons 38 cdo) (assoc 38 (entget pline)) (entget pline)))
)
)
(entmod (subst (cons 8 "DM so hoa") (assoc 8 (entget pline)) (entget pline)))
)
(alert "Chon lai!!! . Doi tuong ban vua chon khong phai la Polyline hoac da duoc so hoa")
)
)
)
)
(princ"\n Copyright by Nataca ....www.tailieukythuat.com")
)

;------------------------------------------
;;;NHAP KEY VAO
(defun I_KEY (dongnhac key Text)

(if (null Text)
(progn
(initget 1 key)
(getkword (strcat dongnhac " :"))
)
(progn
(cond
((progn
(initget key)
(getkword (strcat dongnhac " < " Text " >:"))
)
)
(T Text)

)
)

)
)
;;;NHAP GIA TRI LA SO THUC
(defun I_REAL (dongnhac Tso)
(if (null Tso)
(progn
(initget (+ 1 2))
(getdist (strcat dongnhac " <?>:"))
)
(progn
(cond
( (progn
(initget (+ 2))
(getdist (strcat dongnhac " < "(rtos Tso 2 5) " >:"))
)
)
(T Tso)

)
)

)
)

;------------------------------------------
;;; DOI TOA DO X HOAC Y HOAC Z
(defun R_POS (TdOld TdNew vtri / Tj x y z)
(cond ( (= vtri "x")
(setq Tj (car TdOld)
x (cadr TdNew)
y (caddr TdOld)
z (cadddr TdOld)
)
(list Tj x y z)
)
( (= vtri "y")
(setq Tj (car TdOld)
x (cadr TdOld)
y (caddr TdNew)
z (cadddr TdOld)
)
(list Tj x y z)
)
( (= vtri "z")
(setq Tj (car TdOld)
x (cadr TdOld)
y (caddr TdOld)
z (cadddr TdNew)
)
(list Tj x y z)
)
( (= vtri "Tj")
(setq Tj (car TdNew)
x (cadr TdOld)
y (caddr TdOld)
z (cadddr TdOld)
)
(list Tj x y z)
)
)
)

;------------------------------------------
;;;GIA TRI CUA DOI TUONG TEXT STRING
(defun V_T (ent)
(cond ( (= (type (read (cdr (assoc 1 (entget ent))))) 'INT)
(read (cdr (assoc 1 (entget ent))))
)
( (= (type (read (cdr (assoc 1 (entget ent))))) 'REAL)
(read (cdr (assoc 1 (entget ent))))
)
(T (alert (strcat " Ban da chon text " (cdr (assoc 1 (entget ent))) " khong phai la mot so!!!")))
)
)

;------------------------------------------
;;; CHON TEXT, MTEXT KEM DONG NHAC (BAT BUOC CHON)
(defun ES_TM (dongnhac / ss)
(while (and (not (prompt dongnhac))
(not (setq ss (ssget
'((-4 . "<OR") (0 . "TEXT") (0 . "MTEXT") (-4 . "OR>"))
)
)
)
)
)
ss
)
các bạn có thể yêu cầu lisp tại bạn nacata
link bài viết http://tailieukythuat.com/forum/index.php?showtopic=1050

duongepu
26/01/10, 06:52 PM
Xin chào các bạn.Các bạn có thể sửa giúp mình cái lisp này được không??
http://www.cadviet.com/upfiles/2/ban_ve_3.rar
Đây là lisp vẽ bánh răng nó được lập trình để vẽ bánh răng 3D của cad.
Nhưng mình muốn sửa :
+ Cái đỉnh của bánh răng là nó một góc lượn
+ Chân của cái bánh răng cũng vậy.
Các bạn xem bản cad thì cụ thể hơn đó.
Mình chỉ cần sửa cái đỉnh chân răng với lại cái chân răng thui.
Cảm ơn các bạn nhiều.
mail của mình là : selochome@gmail.com