| Info | File |
Tác giả: tanpopo
Bài viết gốc: 186601
Tên lệnh: lo |
Hỏi về Block thuộc tính
Mình cũng ko chắc nhưng có lẽ là do dynamic block nen nó ko làm việc dc???
bạn có thể xài cái lisp mình viết, lisp này chỉ yêu cầu bạn chọn block mẫu, sau đó tự nó làm việc. Xong rồi bạn có thể test lại bằng lệnh attsync xem nó có bị nữa ko nhá!
(defun c:lo(/ ent dtc dt1 sdt id sl nd1 lst1 lt)
(setq dtc(car (entsel "\nchon block:")))
(get-block dtc)
(setq
sdt (sslength dt1)
id 0
lt (list))
(repeat sdt
(setq ent (ssname dt1 id)
id (1+ id)
nd1 (assoc 1 (entget (entnext ent)))
lt (cons nd1 lt)
)
)
(command "attsync" "s" dtc "y")
(setq sl -1
id (- id 1)
)
(repeat sdt
(setq ent (ssname dt1 id)
id (1- id)
lst1 (entget (entnext ent))
lst1 (subst (nth (+ sl 1) lt) (assoc 1 lst1) lst1)
)
(setq sl (+ sl 1))
(entmod lst1)
)
)
;;;;;;;;;;;;;;;;;;;;;;;
(defun get-block(entm / sdtb idb ent2 entb dtm namem name BBB entb)
(setq dtm (vlax-ename->vla-object entm))
(setq namem (if(vlax-property-available-p dtm 'effectivename)
(vla-get-effectivename dtm)
(vla-get-name dtm)
));;;
(setq BBB(SSGET "all" (list(cons 0 "INSERT") (assoc 8 (entget entm))))
sdtb (sslength BBB)
idb 0
dt1 (ssadd)
)
(repeat sdtb;;repeat
(setq entb (ssname BBB idb)
idb (1+ idb)
)
(setq ent2(vlax-ename->vla-object entb))
(setq name (if(vlax-property-available-p ent2 'effectivename)
(vla-get-effectivename ent2)
(vla-get-name ent2)
))
(if (= name namem)
(setq dt1 (ssadd entb dt1))
)
);;repeat
)
sadiwediwỉiewr
Các bác cho em hỏi chút về block ATT
Trong bản vẽ em đã chèn rất nhiều block thuộc tính, bây giờ em muốn thay đổi vị trí hiển thị text thuộc tính. Nhưng các block đã chèn nó không thay đổi theo.
Em muốn hỏi làm cách nào để khi dùng lệnh Bedit chỉnh sửa block thì vị trí ghi thuộc tính của block cũng được cập nhật theo.
Cảm ơn các bác.
m hỏi chút về block ATT
Trong bản vẽ em đã chèn rất nhiều block thuộc tính, bây giờ em muốn thay đổi vị trí hiển thị text thuộc tính. Nhưng các block đã chèn nó không thay đổi theo.
Em muốn hỏi làm cách nào để khi dùng lệnh Bedit chỉnh sửa block thì vị trí ghi thuộc tính của block cũng được cập nhật theo.
Cảm ơn các bác.
cai này hay nha. chắc chắn mình sẽ làm thử rồi.!!!!!!!!!!!!!!! thanks các pác nha
re
<<
|
Tác giả: draftsman38751
Bài viết gốc: 182417
Tên lệnh: oval |
Lisp vẽ hình oval
Bạn dùng thử cái này xem được không nhé!
;Doan Van Ha - CADViet.com
(defun C:OVAL()
(BAT_DAU)
(acet-sysvar-set...
>>
Bạn dùng thử cái này xem được không nhé!
;Doan Van Ha - CADViet.com
(defun C:OVAL()
(BAT_DAU)
(acet-sysvar-set (list "osmode" 0 "cmdecho" 0))
(initget 7) (setq bk (getreal "\nBan kinh Oval: "))
(initget 1) (setq p1 (getpoint "\nPick tam Oval thu 1: "))
(command "arc" (polar p1 (/ pi 2) bk) (polar p1 (- pi) bk) (polar p1 (/ pi -2) bk))
(setq ent1 (entlast))
(command "circle" p1 bk)
(setq ent2 (entlast))
(initget 1) (setq p2 (getpoint p1 "\nPick tam Oval thu 2: "))
(command "rotate" ent1 "" p1 (/ (* 180 (angle p1 p2)) pi))
(command "line" (vlax-curve-getEndPoint ent1) (polar (vlax-curve-getEndPoint ent1) (angle p1 p2) (distance p1 p2)) "")
(command "line" (vlax-curve-getStartPoint ent1) (polar (vlax-curve-getStartPoint ent1) (angle p1 p2) (distance p1 p2)) "")
(command "mirror" ent1 "" (acet-geom-midpoint (vlax-curve-getEndPoint ent1) (polar (vlax-curve-getEndPoint ent1) (angle p1 p2) (distance p1 p2)))
(acet-geom-midpoint (vlax-curve-getStartPoint ent1) (polar (vlax-curve-getStartPoint ent1) (angle p1 p2) (distance p1 p2))) "N")
(command "erase" ent2 "")
(acet-sysvar-restore)
(KET_THUC)
(princ))
(defun BAT_DAU()
(setq AcDoc (vla-get-activeDocument (vlax-get-acad-object)))
(vla-StartUndoMark AcDoc)
(setq err *error* *error* KHI_LOI))
(defun KET_THUC()
(acet-sysvar-restore)
(vla-EndUndoMark AcDoc)
(setq *error* err))
(defun KHI_LOI(msg)
(acet-sysvar-restore)
(vla-EndUndoMark AcDoc)
(redraw)
(command "u")
(princ (strcat "\n" msg ", Reset System Variables\n"))
(setq *error* err))
Bạn dùng thử cái này xem được không nhé!
;Doan Van Ha - CADViet.com
(defun C:OVAL()
(BAT_DAU)
(acet-sysvar-set (list "osmode" 0 "cmdecho" 0))
(initget 7) (setq bk (getreal "\nBan kinh Oval: "))
(initget 1) (setq p1 (getpoint "\nPick tam Oval thu 1: "))
(command "arc" (polar p1 (/ pi 2) bk) (polar p1 (- pi) bk) (polar p1 (/ pi -2) bk))
(setq ent1 (entlast))
(command "circle" p1 bk)
(setq ent2 (entlast))
(initget 1) (setq p2 (getpoint p1 "\nPick tam Oval thu 2: "))
(command "rotate" ent1 "" p1 (/ (* 180 (angle p1 p2)) pi))
(command "line" (vlax-curve-getEndPoint ent1) (polar (vlax-curve-getEndPoint ent1) (angle p1 p2) (distance p1 p2)) "")
(command "line" (vlax-curve-getStartPoint ent1) (polar (vlax-curve-getStartPoint ent1) (angle p1 p2) (distance p1 p2)) "")
(command "mirror" ent1 "" (acet-geom-midpoint (vlax-curve-getEndPoint ent1) (polar (vlax-curve-getEndPoint ent1) (angle p1 p2) (distance p1 p2)))
(acet-geom-midpoint (vlax-curve-getStartPoint ent1) (polar (vlax-curve-getStartPoint ent1) (angle p1 p2) (distance p1 p2))) "N")
(command "erase" ent2 "")
(acet-sysvar-restore)
(KET_THUC)
(princ))
(defun BAT_DAU()
(setq AcDoc (vla-get-activeDocument (vlax-get-acad-object)))
(vla-StartUndoMark AcDoc)
(setq err *error* *error* KHI_LOI))
(defun KET_THUC()
(acet-sysvar-restore)
(vla-EndUndoMark AcDoc)
(setq *error* err))
(defun KHI_LOI(msg)
(acet-sysvar-restore)
(vla-EndUndoMark AcDoc)
(redraw)
(command "u")
(princ (strcat "\n" msg ", Reset System Variables\n"))
(setq *error* err))
Cảm ơn Bác Doan van Ha nhé!Nhưng bác có thể chỉnh lại giúp e chút xíu được không!Trước khi mình nhập vào bán kính,mình sẽ pick vào 1 điểm bất kì để xác định tâm cho hình oval 1 luôn và khi vẽ xong thì tất cả sẽ nối lại thành 1 polyline!
<<
|
|
Filename: 182417_oval.lsp
|
|
Tác giả: nhunha_pro279
Bài viết gốc: 411129
Tên lệnh: ip |
Lisp xuất-nhập toạ độ
+Lệnh IP dùng để insert các Points tại các giao điểm của các Line/Pline/Spline (trên mặt phằng XY) sau khi dùng mouse quét qua...
>>
+Lệnh IP dùng để insert các Points tại các giao điểm của các Line/Pline/Spline (trên mặt phằng XY) sau khi dùng mouse quét qua các objects.
Lisp do Trưởng lão Ssg viết:
;;;-----------------------------------------------------
(defun ss2ent (ss / i Le e) ;;;Convert ss to list of ename
(setq i 0)
(repeat (sslength ss)
(setq
e (ssname ss i)
Le (append Le (list e))
i (1+ i)
)
)
Le
)
;;;-----------------------------------------------------
(defun Inters (e1 e2 / ob1 ob2 g L i kq)
(vl-load-com)
(setq
ob1 (vlax-ename->vla-object e1)
ob2 (vlax-ename->vla-object e2)
g (vlax-variant-value (vla-IntersectWith ob1 ob2 acExtendNone))
)
(if (/= (vlax-safearray-get-u-bound g 1) -1) (setq L (vlax-safearray->list g)))
(setq i 0)
(repeat (/ (length L) 3)
(setq kq (append (list (list (nth i L) (nth (+ i 1) L) (nth (+ i 2) L))) kq))
(setq i (+ i 3))
)
kq
)
;;;-----------------------------------------------------
(defun C:IP ( / Le e0 e Lp p) ;;;Intersection Points
(setq Le (ss2ent (ssget '((0 . "LINE,POLYLINE,LWPOLYLINE,SPLINE")))))
(repeat (1- (length Le))
(setq Le (vl-remove (setq e0 (car Le)) Le))
(foreach e Le (setq Lp (append Lp (inters e0 e))))
)
(foreach p Lp (entmake (list (cons 0 "POINT") (cons 10 (list (car p) (cadr p) 0.0)))))
(princ)
)
;;;-----------------------------------------------------
Bác ơi có thể phát triển lisp này để đếm số lượng điểm point được không nhỉ?
<<
|
Tác giả: phamthe
Bài viết gốc: 372379
Tên lệnh: lc |
vấn đề về lệnh tắt trong cad
Bác Hà chưa release nó sau khi dùng lisp ^^
@toiyeuvietnam :
- Nếu không nhớ lệnh (hay như trong ví dụ của bạn là các hàm...
>>
Bác Hà chưa release nó sau khi dùng lisp ^^
@toiyeuvietnam :
- Nếu không nhớ lệnh (hay như trong ví dụ của bạn là các hàm viết bằng lisp), tại sao bạn không tạo menu, hoặc tạo Toolbar bằng lệnh CUI của CAD ?
- Nếu không rành tạo menu thì tạo Tool Palette
- Nếu đã dùng lisp gọi bảng lệnh thì nên làm theo gợi ý của bác Duy, không nên tốn chỗ cho 1 file lisp + 1 file txt list lệnh, ngoài ra khi gọi sang chương trình khác sẽ làm gián đoạn quá trình làm việc của bạn, bất kể là word hay txt thì sau đó cũng phải back ngược lại về CAD và đánh lệnh
Mình viết cho bạn 1 cái hiển thị bảng lệnh - hoặc lisp. Sau khi chọn lệnh bạn có thể ấn nút OK để CAD thực hiện lệnh đó luôn.
Cách thêm lệnh bạn xem trong code mình ghi chú rồi đó. Sau khi thêm các lệnh sẽ được sắp xếp theo thứ tự abc.
Bạn có thể đánh dòng ghi chú bằng tiếng việt không dấu, hoặc tiếng việt có dấu dạng TCVN3, hoặc Unicode Hexa (tìm tool convert trong các bài tiếng việt trong Lisp), tuyệt đối không đánh trực tiếp font Unicode
(defun c:lc(/ LM:ListBox str lstData ST:SendKeys)
(setq lstData
(acad_strlsort (list
;Viet tiep cac lenh vao duoi dong nay theo mau "Ten lenh Noi dung"
"Erase Xoa doi tuong"
"Copy Sao chep doi tuong"
"Mirror Lay doi xung"
"CO Copy th\U+00F4ng minh"
))
)
(defun ST:SendKeys (keys / ws)
(vlax-invoke-method (setq ws (vlax-create-object "WScript.Shell")) 'sendkeys keys)
(vlax-release-object ws)
(princ)
)
(defun LM:ListBox ( title data multiple / file tmp dch return )
(cond
(
(not
(and (setq file (open (setq tmp (vl-filename-mktemp nil nil ".dcl")) "w"))
(write-line
(strcat "listbox : dialog { label = \"" title
"\"; spacer; : list_box { key = \"list\"; multiple_select = "
(if multiple "true" "false") "; } spacer; ok_cancel;}"
)
file
)
(not (close file)) (< 0 (setq dch (load_dialog tmp))) (new_dialog "listbox" dch)
)
)
)
(
t
(start_list "list")
(mapcar 'add_list data) (end_list)
(setq return (set_tile "list" "0"))
(action_tile "list" "(setq return $value)")
(setq return
(if (= 1 (start_dialog))
(mapcar '(lambda ( x ) (nth x data)) (read (strcat "(" return ")")))
)
)
)
)
(if (< 0 dch) (unload_dialog dch))
(if (setq tmp (findfile tmp)) (vl-file-delete tmp))
return
)
(cond (
(setq str (LM:ListBox "Ghi ch\U+00FA l\U+1EC7nh - lisp CAD - @ketxu - 2/6/2012 :" lstData nil))
(setq str (car str))
(ST:SendKeys (strcat (substr str 1 (vl-string-position 32 str)) "\n"))
)
)
(princ)
)
anh ơi cho em hỏi em muốn mấy chữ dưới đây hiển thị trên màn hình không theo thứ tự A, B, C, D mà em muốn nó hiện theo thứ tự từng dòng từ trên xuống dưới như mình đã sắp xếp thì làm thế nào anh nhỉ?
(ĐÂY LÀ HIỆN KHÔNG THEO NHỮ DÒNG MÌNH SẮP XẾP MÀ THEO A,B,C,D)
"Erase Xoa doi tuong" I
"Copy Sao chep doi tuong" I ĐÂY LÀ HIỂN THỊ TỪNG DÒNG THEO THỨ TỰ MÌNH SẮP XẾP ĐÂY!
"Mirror Lay doi xung" I
"CO Copy th\U+00F4ng minh" I
<<
|
Tác giả: Tue_NV
Bài viết gốc: 98276
Tên lệnh: lb3 |
Giao diện hộp thoại trong AutoLisp
.............. Gửi Tue_NV code có thay thế nội dung biến ten bằng danh sách các Layer trong bản vẽ.
(defun c:lb3 (/ a dcl_id phepchon ten)
(defun...
>>
.............. Gửi Tue_NV code có thay thế nội dung biến ten bằng danh sách các Layer trong bản vẽ.
(defun c:lb3 (/ a dcl_id phepchon ten)
(defun GetLayerLst(/ tbl tbl_lst)
(setq tbl (tblnext "layer" 1) tbl_lst nil)
(while tbl
(setq tbl_lst (cons (cdr (assoc 2 tbl)) tbl_lst))
(setq tbl (tblnext "layer")) )
(vl-sort tbl_lst ';main
(setq dcl_id (load_dialog "listbox.dcl"))
(setq ten (GetLayerLst)
a "0")
(while (not (vl-position phepchon '(0 1)))
(if (not (new_dialog "LB" dcl_id))
(exit))
(start_list "C")
(mapcar 'add_list ten)
(end_list)
(set_tile "C" a)
(action_tile "C" "(setq a $value)")
(action_tile "cancel" "(done_dialog 0)")
(action_tile "accept" "(done_dialog 1)" )
(action_tile "th" "(done_dialog 3)")
(setq phepchon (start_dialog))
(if (= phepchon 3)
(alert (nth (atoi a) ten)))
);while
(unload_dialog DCL_ID)
(if (= phepchon 1) (alert (strcat "Ban da chon Layer : "(nth (atoi a) ten))))
(princ))
Cảm ơn anh gia_bach thật nhiều.
Tue_NV còn 1 vấn đề này nữa ạ :
Sau khi tạo 1 popup_list trong dialog : đó là danh sách tên các Layer thì phát sinh thêm 1 vấn đề nữa là Tue_NV muốn tạo thêm 1 popup_list nữa. Popup_list này chứa thuộc tính Color và Linetype từ tên Layer mà ta đã chọn ở trên.
Kết quả là trong dialog có 2 Popup_list. Một popup_list thể hiện tên Layer. Sau khi mình chọn tên Layer ở popup_list đầu thì popup_list thứ 2 tự động cập nhật thuộc tính Color và Linetype vào.
Đây là file .dcl
////////file dcl : Listbox.dcl
LB : dialog {
label = "Layer va thuoc tinh Color , Linetype ";
:boxed_row {
label = "Layer va thuoc tinh Color , Linetype ";
width = 50;
: row {
: column {
: popup_list {
label = "Layer_Name ";
key = "LA";
allow_accept = true;
}
: popup_list {
label = "Color and Linetype";
key = "T";
allow_accept = true;
}
}
}
}
ok_cancel; //OK and Cancel Buttons
}
Việc tạo list ten Layer và add vào popup_list thì như anh gia_bach đã hướng dẫn và Tue_NV đã hiểu, nhưng còn việc chọn 1 phần tử trong popup_list 1 để các thuộc tính tự động cập nhật vào popup_list 2 thì Tue_NV chưa biết cách
Minh họa theo hình vẽ cụ thể sau :
2 : chính là số màu của Layer
Continuous : chính là Linetype
Rất mong sự giúp đỡ của anh gia_bach và các bác.
Tue_NV xin chân thành cảm ơn.
<<
|
Tác giả: nataca
Bài viết gốc: 66022
Tên lệnh: ewb |
lisp xóa tất cả các đối tượng trong 1 vùng kín
Chào các bạn. Về cơ bản thì LISP ERC của bạn Thiệp đã giải quyết đuợc các yêu cầu xóa các đối tuợng trong, ngoài và giữa 2 đuờng bao.
Tuy...
>>
Chào các bạn. Về cơ bản thì LISP ERC của bạn Thiệp đã giải quyết đuợc các yêu cầu xóa các đối tuợng trong, ngoài và giữa 2 đuờng bao.
Tuy nhiên với các đối tuợng có giao với đuờng bao thì Lisp ERC chưa hoàn chỉnh.
Để giải quyết vấn đề xóa các đối tuợng có giao với đuờng bao, tui dùng giải pháp là cắt các đối tuợng này tại giao điểm với đuờng bao, sử dụng hàm break_with của CAB trên www.TheSwamp.org
Do hàm break_with chỉ cắt các đối tuợng lines, lwplines, plines, splines, ellipse, circles & arcs nên với các đối tuợng còn lại như Text, Dimension,... LISP không giải quyết triệt để. :s_big:
Các bạn chạy thử và cho ý kiến.
(defun c:EWB (/ ov vl ss1 ss2 ptLst plSet) ;EWB -> Erase With Boundary
(defun *error* (msg)
(if ov (mapcar 'setvar vl ov)) ; reset Sys vars
(princ (strcat "\n<< Error: " msg " >>")) ; Print Error Message
(princ) ; Exit Cleanly
)
(command "_.undo" "_begin")
(setq vl '("CMDECHO" "OSMODE" "ORTHOMODE") ; Sys Var list
ov (mapcar 'getvar vl)) ; Get Old values
(mapcar 'setvar vl '(0 0 0)) ; Turn off CMDECHO, OSMODE, ORTHOMODE
(initget "T N G")
(setq bit (getkword "\nBan muon xoa Trong hay Ngoai duong bao, hay Giua 2 duong bao : " ) )
(cond
((= bit "T") ;xoa Trong duong bao
(princ"\n<<< Chon duong bao >>> ")
(if (and (setq ss (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE"))))
(setq ssInside (GetssInside ss))
(> (sslength ssInside) 0))
(mapcar 'entdel (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssInside))) ) ; xoa ssInside
)
)
((= bit "G") ;xoa giua 2 duong bao
(princ"\n<<< Chon duong bao ngoai >>> ")
(setq ssN (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE"))))
(princ"\n<<< Chon duong bao trong >>> ")
(setq ssT (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE")))
curT (ssname ssT 0)
ssT (GetssInside ssT)
ssN (GetssInside ssN))
(if (and ssT (> (sslength ssT) 0) ssN (> (sslength ssN) 0) )
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssT)))
(if (ssmemb e ssN) (ssdel e ssN)))
)
(if (ssmemb curT ssN) (ssdel curT ssN))
(mapcar 'entdel (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssN))) ) ; xoa ss
)
((= bit "N") ;xoa Ngoai duong bao
(initget "T G")
(setq bit (getkword "\nXoa Tat ca doi tuong ngoai duong bao, hay chi doi tuong Giao voi duong bao : " ) )
(princ"\n<<< Chon duong bao >>> ")
(setq ss (ssget "_:S" '((0 . "LWPOLYLINE,CIRCLE,ELLIPSE")))
cur (ssname ss 0))
(if (= bit "T")
(progn ;xoa Tat ca doi tuong ngoai duong bao
(setq ssInside (GetssInside ss)
ssAll (ssget "x" (list (cons 410 (getvar "ctab")))) )
(if (and ssInside (> (sslength ssInside) 0) )
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssInside)))
(if (ssmemb e ssAll) (ssdel e ssAll)))
)
(if (ssmemb cur ssAll) (ssdel cur ssAll))
(mapcar 'entdel (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssAll))) ) ; xoa ss
)
;chi xoa doi tuong Giao voi duong bao
(if (and (setq ssOutside (GetssOutside ss))
(> (sslength ssOutside) 0))
(mapcar 'entdel (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssOutside))) ) ; xoa ssOutside
)
);if
);;xoa Ngoai duong bao
);cond
(mapcar 'setvar vl ov) ; reset Sys Vars
(command "_.undo" "_end")
(princ)
)
(defun GetssOutside (ss2 / ptLst cur ssInside lstss1 ss1 ssTouching)
(if (and (setq lstss1 (gettouching ss2))
(setq ss1 (ssadd))
(mapcar '(lambda (x) (ssadd x ss1)) lstss1)
)
(progn ; co ssTouching
(break_with ss1 ss2 nil 0)
(setq cur (ssname ss2 0)
ssTouching (ssadd)
ssOutside (ssadd))
(mapcar '(lambda (x) (ssadd x ssTouching)) (gettouching ss2))
;loc ssTouching -> ssOutside
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssTouching)))
(if
(or
(not(insidep (vlax-curve-getStartPoint e) cur))
(not(insidep (vlax-curve-getEndPoint e) cur))
(not(insidep (vlax-curve-getPointAtParam e (/(+(vlax-curve-getStartParam e)
(vlax-curve-getEndParam e))2)) cur))
);or
(ssadd e ssOutside)
);if
);foreach
);progn
);if
(if (ssmemb cur ssOutside) (ssdel cur ssOutside))
ssOutside
)
(defun GetssInside (ss2 / ptLst cur ssInside lstss1 ss1 ssTouching)
(setq ptLst (GetPtLst (setq cur (ssname ss2 0)))
ssInside (ssget "_WP" ptLst ) )
(if (and (setq lstss1 (gettouching ss2))
(setq ss1 (ssadd))
(mapcar '(lambda (x) (ssadd x ss1)) lstss1)
)
(progn ; co ssTouching
(break_with ss1 ss2 nil 0)
(setq ssTouching (ssadd))
(mapcar '(lambda (x) (ssadd x ssTouching)) (gettouching ss2))
;loc ssTouching -> ssInside
(or ssInside (setq ssInside (ssadd)) )
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ssTouching)))
(if
(and (insidep (vlax-curve-getStartPoint e) cur)
(insidep (vlax-curve-getEndPoint e) cur)
(insidep (vlax-curve-getPointAtParam e (/(+(vlax-curve-getStartParam e)
(vlax-curve-getEndParam e))2)) cur)
)
(ssadd e ssInside)
);if
);foreach
);progn
);if
(if (ssmemb cur ssInside) (ssdel cur ssInside))
ssInside
)
(defun GetPtLst (obj / startparam endparam anginc delta div inc pt ptlst)
(defun ZClosed (lst)
(if (and (vlax-curve-isClosed obj)
(not(equal (car lst)(last lst) 1e-6)))
(append lst (list (car lst)))
lst))
(or (eq (type obj) 'VLA-OBJECT)
(setq obj (vlax-ename->vla-object obj)))
(setq typ (vlax-get obj 'ObjectName))
(if (or (eq typ "AcDbCircle") (eq typ "AcDbEllipse"))
(progn
(setq param 0)
(while (< param (* pi 2))
(setq pt (vlax-curve-getPointAtParam obj param)
ptlst (cons pt ptlst)
param (+ (/ (* pi 2) 72) param))
)
(reverse ptlst)
)
(progn ;Pline (eq typ "AcDbPolyline")
(setq param (vlax-curve-getStartParam obj)
endparam (vlax-curve-getEndParam obj)
anginc (* pi (/ 7.5 180.0)))
(setq tparam param)
(while (<= param endparam)
(setq pt (vlax-curve-getPointAtParam obj param))
(if (not (equal pt (car ptlst) 1e-12))
(setq ptlst (cons pt ptlst)))
(if (and (/= param endparam)
(setq blg (abs (vlax-invoke obj 'GetBulge param)))
(/= 0 blg))
(progn
(setq delta (* 4 (atan blg)) ;included angle
inc (/ 1.0 (1+ (fix (/ delta anginc))))
arcparam (+ param inc))
(while (< arcparam (1+ param))
(setq pt (vlax-curve-getPointAtParam obj arcparam)
ptlst (cons pt ptlst)
arcparam (+ inc arcparam))))
)
(setq param (1+ param))
)
(if (and (apply 'and ptlst)
(> (length ptlst) 1))
(ZClosed (reverse ptlst))
)
)
)
)
;; Copyright © 2009, Lee McDonnell
;; (Contact Lee Mac, CADTutor.net)
(defun insidep (pt Obj / Obj Tol ang doc spc flag int lin xV yV)
(defun vlax-list->3D-point (lst flag)
(if lst
(cons ((if flag car cadr) lst)
(vlax-list->3D-point (cdddr lst) flag))))
(or (eq 'VLA-OBJECT (type Obj))
(setq Obj (vlax-ename->vla-object Obj)))
(if (not(vlax-curve-getParamAtPoint Obj pt))
(progn
(setq Tol (/ pi 6) ; Uncertainty
ang 0.0 flag T)
(setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object))
spc (if (zerop (vla-get-activespace doc))
(if (= (vla-get-mspace doc) :vlax-true)
(vla-get-modelspace doc)
(vla-get-paperspace doc))
(vla-get-modelspace doc)))
(while (and (< ang (* 2 pi)) flag)
(setq flag (and
(setq int
(vlax-invoke
(setq lin
(vla-addLine spc
(vlax-3D-point pt)
(vlax-3D-point
(polar pt ang
(if (vlax-property-available-p Obj 'length)
(vla-get-length Obj) 1.0)))))
'IntersectWith Obj
acExtendThisEntity))
(<= 6 (length int))
(setq xV (vl-sort (vlax-list->3D-point int T) '<)
yV (vl-sort (vlax-list->3D-point int nil) '<))
(or (<= (car xV) (car pt) (last xV))
(<= (car yV) (cadr pt) (last yV))))
ang (+ ang Tol))
(vla-delete lin))
flag
)
T
))
;;; Author: Copyrightｩ 2006-2008 Charles Alan Butler
;;; Contact @ www.TheSwamp.org
;;===========================================================================
;; get all objects touching entities in the sscross
;; limited obj types to "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE"
;; returns a list of enames
;;===========================================================================
(defun gettouching (sscros / ss lst lstb lstc objl)
(and
(setq lstb (vl-remove-if 'listp (mapcar 'cadr (ssnamex sscros)))
objl (mapcar 'vlax-ename->vla-object lstb)
)
(setq ss (ssget "_A" (list (cons 0 "LINE,ARC,SPLINE,LWPOLYLINE,POLYLINE,CIRCLE,ELLIPSE")
(cons 410 (getvar "ctab"))))
)
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq lst (mapcar 'vlax-ename->vla-object lst))
(mapcar
'(lambda (x)
(mapcar
'(lambda (y)
(if (not
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(vlax-safearray->list
(vlax-variant-value
(vla-intersectwith y x acextendnone)
))))))
(setq lstc (cons (vlax-vla-object->ename x) lstc))
)
) objl)
) lst)
)
lstc
)
;;; Author: Copyrightｩ 2006-2008 Charles Alan Butler
;;; Contact @ www.TheSwamp.org
(defun break_with (ss2brk ss2brkwith self Gap / cmd intpts lst masterlist ss ssobjs
onlockedlayer ssget->vla-list list->3pair GetNewEntities oc
get_interpts break_obj GetLastEnt LastEntInDatabase ss2brkwithList
)
;; ss2brk selection set to break
;; ss2brkwith selection set to use as break points
;; self when true will allow an object to break itself
;; note that plined will break at each vertex
;;
;; return list of enames of new objects
(vl-load-com)
(princ "\nCalculating Break Points, Please Wait.\n")
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S U B F U N C T I O N S
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; return T if entity is on a locked layer
(defun onlockedlayer (ename / entlst)
(setq entlst (tblsearch "LAYER" (cdr (assoc 8 (entget ename)))))
(= 4 (logand 4 (cdr (assoc 70 entlst))))
)
;; return a list of objects from a selection set
;| (defun ssget->vla-list (ss)
(mapcar 'vlax-ename->vla-object (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss ))))
)|;
(defun ssget->vla-list (ss / i ename allobj) ; this is faster, changed in ver 1.7
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(setq allobj (cons (vlax-ename->vla-object ename) allobj))
)
allobj
)
;; return a list of lists grouped by 3 from a flat list
(defun list->3pair (old / new)
(while (setq new (cons (list (car old) (cadr old) (caddr old)) new)
old (cdddr old)))
(reverse new)
)
;;=====================================
;; return a list of intersect points
;;=====================================
(defun get_interpts (obj1 obj2 / iplist)
(if (not (vl-catch-all-error-p
(setq iplist (vl-catch-all-apply
'vlax-safearray->list
(list
(vlax-variant-value
(vla-intersectwith obj1 obj2 acextendnone)
))))))
iplist
)
)
;;========================================
;; Break entity at break points in list
;;========================================
(defun break_obj (ent brkptlst BrkGap / brkobjlst en enttype maxparam closedobj
minparam obj obj2break p1param p2param brkpt2 dlst idx brkptS
brkptE brkpt result GapFlg result ignore dist tmppt
#ofpts 2gap enddist lastent obj2break stdist
)
(or BrkGap (setq BrkGap 0.0)) ; default to 0
(setq BrkGap (/ BrkGap 2.0)) ; if Gap use 1/2 per side of break point
(setq obj2break ent
brkobjlst (list ent)
enttype (cdr (assoc 0 (entget ent)))
GapFlg (not (zerop BrkGap)) ; gap > 0
closedobj (vlax-curve-isclosed obj2break)
)
;; when zero gap no need to break at end points
(if (zerop Brkgap)
(setq spt (vlax-curve-getstartpoint ent)
ept (vlax-curve-getendpoint ent)
brkptlst (vl-remove-if '(lambda(x) (or (< (distance x spt) 0.0001)
(< (distance x ept) 0.0001)))
brkptlst)
)
)
(if brkptlst
(progn
;; sort break points based on the distance along the break object
;; get distance to break point, catch error if pt is off end
;; ver 2.0 fix - added COND to fix break point is at the end of a
;; line which is not a valid break but does no harm
(setq brkptlst (mapcar '(lambda(x) (list x (vlax-curve-getdistatparam obj2break
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break x))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break x))))))
) brkptlst))
;; sort primary list on distance
(setq brkptlst (vl-sort brkptlst '(lambda (a1 a2) (< (cadr a1) (cadr a2)))))
(if GapFlg ; gap > 0
;; Brkptlst starts as the break point and then a list of pairs of points
;; is creates as the break points
(progn
;; create a list of list of break points
;; ((idx# stpoint distance)(idx# endpoint distance)...)
(setq idx 0)
(foreach brkpt brkptlst
;; ----------------------------------------------------------
;; create start break point, then create end break point
;; ((idx# startpoint distance)(idx# endpoint distance)...)
;; ----------------------------------------------------------
(setq dist (cadr brkpt)) ; distance to center of gap
;; subtract gap to get start point of break gap
(cond
((and (minusp (setq stDist (- dist BrkGap))) closedobj )
(setq stdist (+ (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break)) stDist))
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
((minusp stDist) ; off start of object so get startpoint
(setq dlst (cons (list idx (vlax-curve-getstartpoint obj2break) 0.0) dlst))
)
(t
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
)
;; add gap to get end point of break gap
(cond
((and (> (setq stDist (+ dist BrkGap))
(setq endDist (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break)))) closedobj )
(setq stdist (- stDist endDist))
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
((> stDist endDist) ; off end of object so get endpoint
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getendparam obj2break))
endDist) dlst))
)
(t
(setq dlst (cons (list idx
(vlax-curve-getpointatparam obj2break
(vlax-curve-getparamatdist obj2break stDist))
stDist) dlst))
)
)
;; -------------------------------------------------------
(setq idx (1+ IDX))
) ; foreach brkpt brkptlst
(setq dlst (reverse dlst))
;; remove the points of the gap segments that overlap
(setq idx -1
2gap (* BrkGap 2)
#ofPts (length Brkptlst)
)
(while (<= (setq idx (1+ idx)) #ofPts)
(cond
((null result) ; 1st time through
(setq result (list (car dlst)) ; get first start point
result (cons (nth (1+(* idx 2)) dlst) result))
)
((= idx #ofPts) ; last pass, check for wrap
(if (and closedobj (> #ofPts 1)
(<= (+(- (vlax-curve-getdistatparam obj2break
(vlax-curve-getendparam obj2break))
(cadr (last BrkPtLst))) (cadar BrkPtLst)) 2Gap))
(progn
(if (zerop (rem (length result) 2))
(setq result (cdr result)) ; remove the last end point
)
;; ignore previous endpoint and present start point
(setq result (cons (cadr (reverse result)) result) ; get last end point
result (cdr (reverse result))
result (reverse (cdr result)))
)
)
)
;; Break Gap Overlaps
((< (cadr (nth idx Brkptlst)) (+ (cadr (nth (1- idx) Brkptlst)) 2Gap))
(if (zerop (rem (length result) 2))
(setq result (cdr result)) ; remove the last end point
)
;; ignore previous endpoint and present start point
(setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get present end point
)
;; Break Gap does Not Overlap previous point
(t
(setq result (cons (nth (* idx 2) dlst) result)) ; get this start point
(setq result (cons (nth (1+(* idx 2)) dlst) result)) ; get this end point
)
) ; end cond stmt
) ; while
(setq dlst (reverse result)
brkptlst nil)
(while dlst ; grab the points only
(setq brkptlst (cons (list (cadar dlst)(cadadr dlst)) brkptlst)
dlst (cddr dlst))
)
)
)
;; -----------------------------------------------------
;; (if (equal a ent) (princ)) ; debug CAB -------------
(foreach brkpt (reverse brkptlst)
(if GapFlg ; gap > 0
(setq brkptS (car brkpt)
brkptE (cadr brkpt))
(setq brkptS (car brkpt)
brkptE brkptS)
)
;; get last entity created via break in case multiple breaks
(if brkobjlst
(progn
(setq tmppt brkptS) ; use only one of the pair of breakpoints
;; if pt not on object x, switch objects
(if (not (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint (list obj2break tmppt))))
(progn ; find the one that pt is on
(setq idx (length brkobjlst))
(while (and (not (minusp (setq idx (1- idx))))
(setq obj (nth idx brkobjlst))
(if (numberp (vl-catch-all-apply
'vlax-curve-getdistatpoint (list obj tmppt)))
(null (setq obj2break obj)) ; switch objects, null causes exit
t
)
)
)
)
)
)
)
(setq closedobj (vlax-curve-isclosed obj2break))
(if GapFlg ; gap > 0
(if closedobj
(progn ; need to break a closed object
(setq brkpt2 (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getDistAtPoint obj2break brkptE) 0.00001)))
(command "._break" obj2break "_non" (trans brkpt2 0 1)
"_non" (trans brkptE 0 1))
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(setq BrkptE brkpt2)
)
)
(if (and closedobj
(not (setq brkptE (vlax-curve-getPointAtDist obj2break
(+ (vlax-curve-getdistatparam obj2break
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001))))
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break brkpts))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))))
(setq brkptE (vlax-curve-getPointAtDist obj2break
(- (vlax-curve-getdistatparam obj2break
;;(vlax-curve-getparamatpoint obj2break brkpts)) 0.00001)))
;; ver 2.0 fix
(cond ((vlax-curve-getparamatpoint obj2break brkpts))
((vlax-curve-getparamatpoint obj2break
(vlax-curve-getclosestpointto obj2break brkpts))))) 0.00001)))
)
) ; endif
;; (if (null brkptE) (princ)) ; debug
(setq LastEnt (GetLastEnt))
(command "._break" obj2break "_non" (trans brkptS 0 1) "_non" (trans brkptE 0 1))
(and *BrkVerbose* (princ (setq *brkcnt* (1+ *brkcnt*))) (princ "\r"))
(and (= "CIRCLE" enttype) (setq enttype "ARC"))
(if (and (not closedobj) ; new object was created
(not (equal LastEnt (entlast))))
(setq brkobjlst (cons (entlast) brkobjlst))
)
)
)
) ; endif brkptlst
) ; defun break_obj
;;====================================
;; CAB - get last entity in datatbase
(defun GetLastEnt ( / ename result )
(if (setq result (entlast))
(while (setq ename (entnext result))
(setq result ename)
)
)
result
)
;;===================================
;; CAB - return a list of new enames
(defun GetNewEntities (ename / new)
(cond
((null ename) (alert "Ename nil"))
((eq 'ENAME (type ename))
(while (setq ename (entnext ename))
(if (entget ename) (setq new (cons ename new)))
)
)
((alert "Ename wrong type."))
)
new
)
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; S T A R T S U B R O U T I N E H E R E
;;+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(setq LastEntInDatabase (GetLastEnt))
(if (and ss2brk ss2brkwith)
(progn
(setq oc 0
ss2brkwithList (ssget->vla-list ss2brkwith))
(if (> (* (sslength ss2brk)(length ss2brkwithList)) 5000)
(setq *BrkVerbose* t)
)
(and *BrkVerbose*
(princ (strcat "Objects to be Checked: "
(itoa (* (sslength ss2brk)(length ss2brkwithList))) "\n")))
;; CREATE a list of entity & it's break points
(foreach obj (ssget->vla-list ss2brk) ; check each object in ss2brk
(if (not (onlockedlayer (vlax-vla-object->ename obj)))
(progn
(setq lst nil)
;; check for break pts with other objects in ss2brkwith
(foreach intobj ss2brkwithList
(if (and (or self (not (equal obj intobj)))
(setq intpts (get_interpts obj intobj))
)
(setq lst (append (list->3pair intpts) lst)) ; entity w/ break points
)
(and *BrkVerbose* (princ (strcat "Objects Checked: " (itoa (setq oc (1+ oc))) "\r")))
)
(if lst
(setq masterlist (cons (cons (vlax-vla-object->ename obj) lst) masterlist))
)
)
)
)
(and *BrkVerbose* (princ "\nBreaking Objects.\n"))
(setq *brkcnt* 0) ; break counter
;; masterlist = ((ent brkpts)(ent brkpts)...)
(if masterlist
(foreach obj2brk masterlist
(break_obj (car obj2brk) (cdr obj2brk) Gap)
)
)
)
)
;;==============================================================
(and (zerop *brkcnt*) (princ "\nNone to be broken."))
(setq *BrkVerbose* nil)
(GetNewEntities LastEntInDatabase) ; return list of enames of new objects
)
Mình đã chạy thử và có thông báo như sau: << Error: too many arguments >>
Chắc là trong quá trình copy lên diễn đàn bị lỗi. Bác có thể gửi kèm luôn file được không?
<<
|
Tác giả: Tue_NV
Bài viết gốc: 44746
Tên lệnh: vd |
Tính tổng có điều kiện để thống kê thép cường độ cao
Bạn chạy thử lisp sau, lệnh VD:
;;;---------------------------------------------------
(defun ss2ent(ss / sodt index ent lstent) ;;;Convert ss to list of entities
(setq
sodt (if ss...
>>
Bạn chạy thử lisp sau, lệnh VD:
;;;---------------------------------------------------
(defun ss2ent(ss / sodt index ent lstent) ;;;Convert ss to list of entities
(setq
sodt (if ss (sslength ss) 0)
index 0
)
(repeat sodt
(setq
ent (ssname ss index)
index (1+ index)
lstent (cons ent lstent)
)
)
(reverse lstent)
)
;;;---------------------------------------------------
(defun SumSpec(L1 L2 / i Res v1 v2 old) ;;;Sum Special
(setq i 0)
(foreach v1 L1
(setq v2 (nth i L2))
(if (setq old (assoc v1 Res))
(setq Res (subst (cons v1 (+ v2 (cdr old))) old Res))
(setq Res (append Res (list (cons v1 v2))))
)
(setq i (1+ i))
)
Res
)
;;;---------------------------------------------------
(defun Upper (e1 e2) ;;;Return T if e1 upper e2, otherwise return nil
(> (cadr (cdr (assoc 10 (entget e1)))) (cadr (cdr (assoc 10 (entget e2)))))
)
;;;---------------------------------------------------
(defun Ent2Real(Le / e Lr) ;;;Convert list of text entities to list of real
(foreach e Le (setq Lr (append Lr (list (atof (cdr (assoc 1 (entget e))))))))
)
;;;---------------------------------------------------
(defun C:VD( / ss1 ss2 L1 L2 Res Temp x)
(prompt "\nChon cac text o cot duong kinh...")
(setq ss1 (ssget '((0 . "TEXT"))))
(prompt "\nChon cac text o cot khoi luong...")
(setq ss2 (ssget '((0 . "TEXT"))))
(setq
L1 (ent2real (vl-sort (ss2ent ss1) 'Upper))
L2 (ent2real (vl-sort (ss2ent ss2) 'Upper))
Res (sumspec L1 L2)
Temp ""
)
(foreach x Res (setq Temp (strcat Temp "\nD = " (rtos (car x)) " -> " (rtos (cdr x)) " kg")))
(alert Temp)
)
;;;---------------------------------------------------
;;;That is a example only! Replace alert by other, according your purpose...
;;;Maybe you should add check conditions for input data if necessary...
;;;Success!
;;;---------------------------------------------------
Đề nghị:
1. Phân tích kỹ các code sử dụng trong các functions con và cách áp dụng chúng trong chương trình chính. Nếu thấy hơi khó hiểu, thử làm vài ví dụ đơn giản áp dụng các function con, bạn sẽ hiểu ra vấn đề.
2. Kết quả tổng hợp nằm trong biến Res. Hàm alert chỉ là ví dụ thể hiện kết quả. Bạn hãy tìm cách chuyển data trong Res theo mục đích và cách thức trình bày kết quả của bạn. Tham khảo cách tạo nên giá trị của biến Temp sau khi kết thúc vòng foreach sẽ rất hữu ích.
3. Bài này là một trong những "cột mốc" quan trọng trong quá trình "làm chủ AutoLisp". Vượt qua nó, bạn sẽ có một nền tảng kiến thức Lisp khá vững chắc để có thể tạo nên những ứng dụng hiệu quả. Hãy cố lên!
Rất chân thành cảm ơn bác SSG. Em sẽ cố gắng nghiên cứu bài học cột mốc quý giá này để tạo nên những ứng dụng hiệu quả nhờ AutoLisp.
<<
|
Tác giả: BOYMHANGHEO
Bài viết gốc: 369200
Tên lệnh: xln xld xltcd xltpl cpl |
Lisp chọn đối tượng theo chiều dài (tương tự qselect)
Bạn tham khảo code
;;;(Alert (strcat "\n X\U+00F3a Line c\U+00F3 chi\U+1EC1u d\U+00E0i nh\U+1ECF...
>>
Bạn tham khảo code
;;;(Alert (strcat "\n X\U+00F3a Line c\U+00F3 chi\U+1EC1u d\U+00E0i nh\U+1ECF h\U+01A1n gi\U+00E1 tr\U+1ECB nh\U+1EADp v\U+00E0o: XLN "
;;; "\n X\U+00F3a Line c\U+00F3 chi\U+1EC1u d\U+00E0i b?ng v\U+1EDBi gi\U+00E1 tr\U+1ECB nh\U+1EADp v\U+00E0o: XLTCD"
;;; "\n X\U+00F3a Line c\U+00F3 \U+0111\U+1EC9nh n?m tr\U+00EAn Polyline: XLTPL"
;;; )
;;;)
;;;(Prompt (strcat "\n X\U+00F3a Line c\U+00F3 chi\U+1EC1u d\U+00E0i nh\U+1ECF h\U+01A1n gi\U+00E1 tr\U+1ECB nh\U+1EADp v\U+00E0o: XLN "
;;; "\n X\U+00F3a Line c\U+00F3 chi\U+1EC1u d\U+00E0i b?ng v\U+1EDBi gi\U+00E1 tr\U+1ECB nh\U+1EADp v\U+00E0o: XLTCD"
;;; "\n X\U+00F3a Line c\U+00F3 \U+0111\U+1EC9nh n?m tr\U+00EAn Polyline: XLTPL"
;;; )
;;;)
(defun Length1(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
;;;--------------------------------------------------------------------
(defun C:XLN( / ss L e );;;Xoa line ngan
(or *KCNGAN* (setq *KCNGAN* 1.0))
(setq KCNGAN (getdist (strcat "\nNh\U+1EADp chi\U+1EC1u d\U+00E0i nh\U+1ECF h\U+01A1n s\U+1EBD b\U+1ECB x\U+00F3a: <"
(rtos *KCNGAN* 2 2)
">: "
)
)
)
(if (not KCNGAN) (setq KCNGAN *KCNGAN*) (setq *KCNGAN* KCNGAN))
(setq
ss (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))
L 0.0
)
(vl-load-com)
(setq n 0)
(foreach e (LM:ss->ent ss)
(if (< (length1 e) KCNGAN)
(progn
(setq n (+ n 1))
(entdel e)
)
)
)
(alert (strcat "\nC\U+00F3 t\U+1EA5t c\U+1EA3: " (rtos n 2 0) " c\U+1EA1nh b\U+1ECB x\U+00F3a"))
(princ)
)
(defun C:XLD( / ss L e );;;Xoa line ngan
(or *KCDAI* (setq *KCDAI* 1.0))
(setq KCDAI (getdist (strcat "\nNh\U+1EADp chi\U+1EC1u d\U+00E0i l\U+1EDBn h\U+01A1n s\U+1EBD b\U+1ECB x\U+00F3a: <"
(rtos *KCDAI* 2 2)
">: "
)
)
)
(if (not KCDAI) (setq KCDAI *KCDAI*) (setq *KCDAI* KCDAI))
(setq
ss (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))
L 0.0
)
(vl-load-com)
(setq n 0)
(foreach e (LM:ss->ent ss)
(if (> (length1 e) KCDAI)
(progn
(setq n (+ n 1))
(entdel e)
)
)
)
(alert (strcat "\nC\U+00F3 t\U+1EA5t c\U+1EA3: " (rtos n 2 0) " c\U+1EA1nh b\U+1ECB x\U+00F3a"))
(princ)
)
(defun C:XLTCD( / ss L e);;;Xoa line theo chieu dai
(setq KC (getdist "\nNhap chieu dai LINE: "))
(setq
ss (ssget (list (cons 0 "LINE,ARC,CIRCLE,POLYLINE,LWPOLYLINE,ELLIPSE,SPLINE")))
L 0.0
)
(vl-load-com)
(foreach e (LM:ss->ent ss)
(if (equal (length1 e) KC 0.01)
(entdel e)
)
)
(princ)
)
(defun c:XLTPL();;;xoa line tren Pline
(setq obj (vlax-ename->vla-object (car (entsel "\nChon Line hoac Polyline:"))))
(Alert "\nQuet chon Line")
(setq ss (ssget '((0 . "LINE"))))
(setq LtsEnameLine (LM:ss->ent ss))
(foreach EnameL LtsEnameLine
(setq P1 (cdr (assoc 10 (entget EnameL))))
(setq P2 (cdr (assoc 11 (entget EnameL))))
(setq PVG1 (vlax-curve-getClosestPointTo obj P1 T))
(setq PVG2 (vlax-curve-getClosestPointTo obj P2 T))
(if (or (equal P1 PVG1 0.0001) (equal P2 PVG1 0.0001))
(entdel EnameL)
)
)
(princ)
)
(defun C:CPL( / ss L e);;Chon Pline
(MakeLayer_ "PlVang" 2)
(or *KC* (setq *KC* 10.0))
(setq KC (getreal (strcat "\nNhap chieu dai: <"
(rtos *KC* 2 2)
"> :"
)
)
)
(if (not KC) (setq KC *KC*) (setq *KC* KC))
(setq
ss (ssget (list (cons 0 "*POLYLINE,LWPOLYLINE,LINE")(cons 62 2 )))
L 0.0
)
(vl-load-com)
(foreach e (LM:ss->ent ss)
(if (> (length1 e) KC)
(PUTLAYER e "PlVang")
)
)
(princ)
)
(defun MakeLayer_ ( name colour /)
(if (null (tblsearch "LAYER" name))
(entmake
(list
'(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(70 . 0)
(cons 2 name)
(cons 62 colour)
)
)
)
)
(defun PUTLAYER (ent NameLayer / s)
(setq s (vlax-ename->vla-object ent) )
(vla-put-layer s NameLayer )
)
(defun LM:ss->ent ( ss / i l )
(if ss
(repeat (setq i (sslength ss))
(setq l (cons (ssname ss (setq i (1- i))) l))
bác có lip nào lọc được thanh theo chiều dài bằng 1 giá tri cụ thể không cho em xin với
<<
|
|
Filename: 369200_xln_xld_xltcd_xltpl_cpl.lsp
|
|
Tác giả: ssg
Bài viết gốc: 944
Tên lệnh: caltxt |
Lisp tính toán công thức toán học của đối tượng text
---------------------------------------------- Nhân đây, có 1 lisp có thể tính toán hiệu quả giá trị của text trong AutoCAD xin tặng các thành viên cadviet:
>>
---------------------------------------------- Nhân đây, có 1 lisp có thể tính toán hiệu quả giá trị của text trong AutoCAD xin tặng các thành viên cadviet:
(defun c:caltxt ( / ent tt old new gt gtm kq)
(setq ent (car (entsel "\nHay pick vao 1 doi tuong text: "))
tt (entget ent)
old (assoc 1 tt)
gt (cdr old)
)
(if (setq kq (c:cal gt))
(progn
(setq
gtm (rtos kq)
new (cons 1 gtm)
tt (subst new old tt)
)
(entmod tt)
(princ "\nText da duoc sua gia tri!")
)
(princ "\nText chua cong thuc sai!")
)
(princ)
)
lisp này với lệnh caltxt có tác dụng thay thế một đối tượng text chứa công thức bằng giá trị của công thức đó.
VD: text có giá trị: (1+2-3+4*5)/6 sẽ được thay bằng 3.3333
Ssg xin bổ sung một chút:
Nếu bạn mới khởi động Acad và chưa gọi Command: Cal lần nào, hàm C:caltxt không thể thực hiện được mã lệnh (c:cal gt) và báo error (Cad 2002 báo "too many arguments"; Cad 2007 báo "no function definition: C:CAL").
Nguyên nhân:
Hàm C:CAL được lập bởi geomcal.arx. Khi người dùng mới khởi động Acad và chưa gọi lệnh Command: Cal lần nào, geomcal.arx chưa được load vào memory. Đây là cách mà Acad sử dụng tiết kiệm memory, cái nào chưa cần thì không cho autoload khi khởi động.
Khắc phục:
Thêm vào đầu chương trình đoạn: (if (not cal) (arxload "geomcal"))
<<
|
Tác giả: sumi
Bài viết gốc: 184989
Tên lệnh: btk |
Đo chiều dài và ghi ra text
Bác Bình nhiệt tình quá. Trong code bác còn cho phép tính cả với từng đoạn 1 của 1 Pline (dù việc này chính chủ topic cũng chưa nghĩ tới) :)...
>>
Bác Bình nhiệt tình quá. Trong code bác còn cho phép tính cả với từng đoạn 1 của 1 Pline (dù việc này chính chủ topic cũng chưa nghĩ tới) :) Tks bác.
E cũng đóng góp thêm cách add table. Rộng - cao trong bảng do người dùng tự quyết định
(defun c:btk ( / cao rong iText vla_table 2t e i length1 lstCol lst lstAll fw fn)
(defun Length1(e) (* (getvar "dimlfac")(vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))))
(vl-load-com)
(command "undo" "be")
(setq cao 1.2 rong 5.5 iText (lambda(x y)(vla-settext vla_table i x y))
vla_table (vla-addtable (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) (vlax-3d-point (getpoint "\nChon diem dat BTK :")) 2 4 cao rong)
2t vl-princ-to-string
i 1 lstAll ""
lstCol '(0 1 2 3))
(vla-settext vla_table 0 0 "BANG THONG KE")
(mapcar 'iText lstCol '("TT" "FROM" "TO" "LENGTH"))
(while (setq e (entsel "\nChon doan can thong ke"))
(setq
e (vlax-ename->vla-object (car e))
lst
(append
(list (2t i))
(list (strcat "X = " (2t (car (setq st (vlax-curve-getStartPoint e)))) " Y = " (2t (cadr st))))
(list (strcat "X = " (2t (car (setq st (vlax-curve-getEndPoint e)))) " Y = " (2t (cadr st))))
(list (2t (length1 e)))
)
lstAll (strcat lstAll (vl-string-right-trim "," (apply 'strcat (mapcar '(lambda(x)(strcat x ",")) lst))) "\n")
)
(vla-InsertRows vla_table (setq i (1+ i)) cao 1)
(mapcar '(lambda(x)(vla-SetCellAlignment vla_table i x acMiddleCenter ))lstCol)
(mapcar 'iText lstCol lst)
)
(if (= (strcase (getstring "\n Ban muon luu sang file cvs khong?? <Y or N>: ")) "Y")
(progn
(setq fn (getfiled "Chon file de save" "" "csv" 1)
fw (open fn "w"))
(princ "BANG XUAT TOA DO RA FILE CSV \n" fw)
(princ lstAll fw)
)
)
(close fw)
(command "undo" "end")
)
lisp này e chạy tốt, nhưng cho e hỏi là sửa cái tiêu đề của bảng thành chữ có dấu như lisp của a phamthanhbinh như thế nào vậy a?
thanks!
<<
|
Tác giả: hkkh11
Bài viết gốc: 192612
Tên lệnh: cal1 |
Vấn đề với lisp tính khối lượng đào đắp
Trước giờ em vẫn load các lisp sau để tính khối lượng nạo vét:
Area.lsp
>>
Trước giờ em vẫn load các lisp sau để tính khối lượng nạo vét:
Area.lsp
;;*****************************************
;;*****************************************
(defun Tinh_dt (list_pt p1 p2 p3 p4 mep_ngang / diem1 diem2 d1 d2 bl kt i)
(progn
(setq dientich nil)
(setq bl (- (length list_pt) 1))
(setq d1 (list (nth 0 p2) cdmax))
(setq d2 (list (nth 0 p2) cdmin))
(setq d3 (list (nth 0 p3) cdmax))
(setq d4 (list (nth 0 p3) cdmin))
(setq i 0 dc1 nil dc2 nil diem1 nil diem2 nil)
(repeat bl
(progn
(setq dc1 (inters d1 d2 (nth i list_pt) (nth (1+ i) list_pt)))
(setq dc2 (inters d3 d4 (nth i list_pt) (nth (1+ i) list_pt)))
(if (/= dc1 nil) (setq diem1 dc1))
(if (/= dc2 nil) (setq diem2 dc2))
)
(setq i (1+ i))
)
(setq dc1 nil dc2 nil dk1 nil)
(setq list_dc '());; khai bao list diem cat
(setq i 0 h 0 dc nil)
(repeat bl
(progn
(setq dc (inters (nth i list_pt) (nth (1+ i) list_pt) p1 p2))
(if (/= dc nil) (progn (setq list_dc (cons dc list_dc) dk1 1 h (1+ h))))
)
(setq i (1+ i))
)
(setq i 0 dc nil)
(repeat bl
(progn
(setq dc (inters (nth i list_pt) (nth (1+ i) list_pt) p2 p3))
(if (/= dc nil) (setq list_dc (cons dc list_dc)))
)
(setq i (1+ i))
)
(setq i 0 k 0 dc nil dk2 nil)
(repeat bl
(progn
(setq dc (inters (nth i list_pt) (nth (1+ i) list_pt) p3 p4))
(if (/= dc nil)
(progn
(setq list_dc (cons dc list_dc))
(setq dk2 1)
(setq k (1+ k))
)
)
)
(setq i (1+ i))
)
(setq dc nil)
(if (and (= k 1) (< (nth 1 diem2) mep_ngang))
(setq list_dc (cdr list_dc))
)
(setq list_dc (reverse list_dc))
(if (and (= h 1) (< (nth 1 diem1) mep_ngang))
(setq list_dc (cdr list_dc))
)
(if (and (/= dk1 nil) (> h 1))
(progn
(setq listt1 '())
(setq so1 (car list_dc))
(setq list_dc (cdr list_dc))
(setq so2 (car list_dc))
(setq list_dc (cdr list_dc))
(setq kt T i 0)
(setq listt1 (cons so1 listt1))
(while kt
(progn
(setq p (nth i list_pt))
(if (<= (nth 1 p) (nth 1 so2)) (setq kt nil))
(if (and (> (nth 0 p) (nth 0 so1)) (> (nth 1 p) (nth 1 so2)))
(setq listt1 (cons p listt1))
)
(setq i (1+ i))
)
)
(setq listt1 (cons so2 listt1))
(command "AREA")
(foreach n listt1 (command n))
(command "" "")
(setq dt1 (getvar "AREA"))
)
)
(if (and (/= dk2 nil) (> k 1))
(progn
(setq listt1 '())
(setq list_dc (reverse list_dc))
(setq list_pt (reverse list_pt))
(setq so1 (car list_dc))
(setq list_dc (cdr list_dc))
(setq so2 (car list_dc))
(setq list_dc (cdr list_dc))
(setq kt T i 0)
(setq listt1 (cons so1 listt1))
(while kt
(progn
(setq p (nth i list_pt))
(if (<= (nth 1 p) (nth 1 so2)) (setq kt nil))
(if (and (< (nth 0 p) (nth 0 so1)) (> (nth 1 p) (nth 1 so2)))
(setq listt1 (cons p listt1))
)
(setq i (1+ i))
)
)
(setq listt1 (cons so2 listt1))
(command "AREA")
(foreach n listt1 (command n))
(command "" "")
(setq dt2 (getvar "AREA"))
(setq list_dc (reverse list_dc))
(setq list_pt (reverse list_pt))
)
)
(setq listt1 nil so1 nil so2 nil h nil k nil)
(setq list_dc (reverse list_dc))
(setq list_dc1 '())
(if (> (length list_dc) 0)
(progn
(setq i 0)
(repeat (length list_dc)
(if (/= (nth i list_dc) nil)
(setq list_dc1 (cons (nth i list_dc) list_dc1)))
(setq i (1+ i))
)
)
)
(setq list_dc list_dc1 list_dc1 nil)
(if (> (length list_dc) 1)
(progn
(setq i 0)
(setq list_up '())
(repeat (- (length list_dc) 1)
(progn
(setq ptu1 (nth i list_dc))
(setq ptu2 (nth (1+ i) list_dc))
(if (/= ptu1 nil)
(progn
(setq list_up (cons ptu1 list_up))
;;(setq kt T)
(setq j 0)
(repeat (length list_pt)
(progn
(setq p5 (nth j list_pt))
(if (/= ptu2 nil)
(if (and (> (nth 0 p5) (nth 0 ptu1))
(<= (nth 0 p5) (nth 0 ptu2))
(>= (nth 1 p5) (nth 1 p2)))
(setq list_up (cons p5 list_up))))
)
(setq j (1+ j))
)
))
(setq i (1+ i))
;;(setq kt T j 0)
)
)
(setq list_up (cons (last list_dc) list_up))
))
(setq ptu1 nil ptu2 nil i nil j nil)
(if (and (/= diem2 nil) (> (nth 1 diem2) mep_ngang) (= dk2 1))
(setq list_up (cons p3 list_up)))
(if (and (/= diem1 nil) (> (nth 1 diem1) mep_ngang) (= dk1 1))
(setq list_up (cons p2 list_up)))
(if (and (/= diem1 nil) (< (nth 1 diem1) mep_ngang))
(setq list_up (cons p2 list_up)))
(setq list_up (reverse list_up))
(if (/= list_up nil)
(progn
(command "AREA")
(foreach n list_up (command n))
(command "" "")
(setq dientich (getvar "AREA"))
)
)
(if (= dientich nil) (setq dientich 0))
(if (/= dt1 nil) (setq dientich (+ dientich dt1)))
(if (/= dt2 nil) (setq dientich (+ dientich dt2)))
(setq p1 nil p2 nil p3 nil p4 nil p5 nil dc nil d nil so_dc nil d1 nil i nil)
(setq list_up nil list_dc nil bl nil dt1 nil dt2 nil)
)
);;end_tinh_dt
;;*******************************************
;;Tinh dien tich du ra giua cac mep + duong sai so voi duong tu nhien
(defun dientich_phu (list_diem d1 d2)
(setq b_lap (- (length list_diem) 1))
(setq i 0)
(setq dientich1 0)
(setq list_midpoint '())
(repeat b_lap
(progn
(setq diem (nth i list_diem))
(if (and (> (nth 0 diem) (nth 0 d1)) (< (nth 0 diem) (nth 0 d2)))
(setq list_midpoint (cons diem list_midpoint))
)
)
(setq i (1+ i))
)
(setq diem nil i nil b_lap nil)
(if (>= (length list_midpoint) 0)
(progn
(setq list_midpoint (reverse (cons d2 list_midpoint)))
(setq list_midpoint (cons d1 list_midpoint))
(command "AREA")
(foreach n list_midpoint (command n))
(command "" "")
(setq dientich1 (getvar "AREA"))
)
)
(setq list_midpoint nil)
);;end_fun
;;*******************************************
(defun ham1 (list_pt p11 p21 p31 p51 midpoint)
(setq lst '() dientich2 0 point1 nil)
(progn
(setq i 0 dc1 nil)
(repeat (- (length list_pt) 2)
(setq dc1 (inters (nth i list_pt) (nth (1+ i) list_pt) p11 p51))
(setq i (1+ i)))
(if (/= dc1 nil) (setq point1 dc1))
(if (= point1 nil)
(progn
(setq i 0 kt T dc1 nil)
(while kt
(progn
(if (= i (- (length list_pt) 2)) (setq kt nil))
(setq dc1 (inters (nth i list_pt) (nth (1+ i) list_pt) p21 p31))
(if (/= dc1 nil) (progn (setq point1 dc1) (setq kt nil)))
(setq i (1+ i))))
)
)
(if (= point1 nil)
(progn
(setq i 0 kt T dc1 nil)
(while kt
(progn
(if (= i (- (length list_pt) 2)) (setq kt nil))
(setq dc1 (inters (nth i list_pt) (nth (1+ i) list_pt) p51 p31))
(if (/= dc1 nil) (progn (setq point1 dc1) (setq kt nil)))
(setq i (1+ i))))
)
)
(setq lst (cons p11 lst))
(setq lst (cons midpoint lst))
(setq i 0)
(repeat (- (length list_pt) 1)
(if (and (> (nth 0 (nth i list_pt)) (nth 0 midpoint))
(< (nth 0 (nth i list_pt)) (nth 0 point1)))
(setq lst (cons (nth i list_pt) lst)))
(setq i (1+ i))
)
(setq lst (cons point1 lst))
(if (> (nth 0 point1) (nth 0 p21)) (setq lst (cons p21 lst)))
(if (> (nth 0 point1) (nth 0 p51)) (setq lst (cons p51 lst)))
(if (/= lst nil)
(progn
(command "AREA")
(foreach n lst (command n))
(command "" "")
(setq dientich2 (getvar "AREA")))
)
)
(setq lst nil i nil t nil midpoint nil point1 nil dc1 nil dc2 nil)
);;end_fun
;;********************************************
(defun ham2 (list_pt p41 p31 p21 p61 midpoint)
(setq lst '() dientich3 0)
(progn
(setq i 0 dc nil)
(repeat (- (length list_pt) 2)
(setq dc (inters (nth i list_pt) (nth (1+ i) list_pt) p61 p41))
(if (and (/= dc nil) (> (nth 0 dc) (nth 0 p61))) (setq point2 dc))
(setq i (1+ i))
)
(if (= point2 nil)
(progn
(setq i 0 dc nil)
(repeat (- (length list_pt) 2)
(setq dc (inters (nth i list_pt) (nth (1+ i) list_pt) p21 p31))
(if (/= dc nil) (setq point2 dc))
(setq i (1+ i))
)
))
(if (= point2 nil)
(progn
(setq i 0 dc nil)
(repeat (- (length list_pt) 2)
(setq dc (inters (nth i list_pt) (nth (1+ i) list_pt) p61 p31))
(if (/= dc nil) (setq point2 dc))
(setq i (1+ i))
)
))
(setq lst (cons point2 lst))
(setq i 0)
(repeat (- (length list_pt) 2)
(if (and (> (nth 0 (nth i list_pt)) (nth 0 point2))
(< (nth 0 (nth i list_pt)) (nth 0 midpoint)))
(setq lst (cons (nth i list_pt) lst)))
(setq i (1+ i))
)
(setq lst (cons midpoint lst))
(setq lst (cons p41 lst))
(if (> (nth 0 p61) (nth 0 point2) ) (setq lst (cons p61 lst)))
(if (> (nth 0 p31) (nth 0 point2) ) (setq lst (cons p31 lst)))
(if (/= lst nil)
(progn
(command "AREA")
(foreach n lst (command n))
(command "" "")
(setq dientich3 (getvar "AREA")))
)
)
(setq lst nil i nil t nil midpoint nil point2 nil dc1 nil dc2 nil)
);;end_fun
;;*******************************************
(defun DIEN_TICH ()
(setvar "LUNITS" 2)
(setvar "LUPREC" 2)
(setq cdss (- cdd ssd))
(setq pt1 (list (- mt (* (- cdmax cdd) n1)) cdmax))
(setq pt2 (list mt cdd))
(setq pt3 (list mn cdd))
(setq pt4 (list (+ mn (* (- cdmax cdd) n2)) cdmax))
(setq pt11 (list (- (nth 0 pt1) ssn) (nth 1 pt1)))
(setq pt41 (list (+ (nth 0 pt4) ssn) (nth 1 pt4)))
(setq pt51 (list (- mt ssn) cdd))
(setq pt61 (list (+ mn ssn) cdd))
(setq pt21 (list mt (- cdd ssd)))
(setq pt31 (list mn (- cdd ssd)))
(setq pt71 (inters pt11 pt51 pt31 pt21 nil))
(setq pt81 (inters pt41 pt61 pt21 pt31 nil))
(setq dientichthua1 (* (abs (- (nth 0 pt71) mt)) (/ ssd 2)))
(setq dientichthua2 (* (abs (- (nth 0 pt81) mn)) (/ ssd 2)))
(if (< (nth 0 pt71) mt)
(setq dientichthua1 (- 0 dientichthua1)))
(if (> (nth 0 pt81) mn)
(setq dientichthua2 (- 0 dientichthua2)))
(setq dientichdoira (/ (* ssn ssd) 4))
;; Tim giao diem cua duong sau nao vet voi duong sai so du kien
(setq so_buoc (- (length kccdsnv) 1))
(setq i 0)
(repeat so_buoc
(progn
(setq pt5 (list (nth i kccdsnv) (nth i cdsnv)))
(setq pt6 (list (nth (1+ i) kccdsnv) (nth (1+ i) cdsnv)))
(setq dc1 (inters pt5 pt6 pt11 pt51 T))
(setq dc2 (inters pt5 pt6 pt61 pt41 T))
(if (/= dc1 nil) (setq diem_luu1 dc1))
(if (/= dc2 nil) (setq diem_luu2 dc2))
)
(setq i (1+ i))
)
;;Phan tim giao diem cat cua 2 mep voi duong tu nhien
(setq i 0 bdd1 nil bdd2 nil bdd3 nil bdd4 nil dc1 nil dc2 nil)
2(setq so_buoc (- (length kccdtn) 1))
(repeat so_buoc
(progn
(setq pt5 (list (nth i kccdtn) (nth i cdtn)))
(setq pt6 (list (nth (1+ i) kccdtn) (nth (1+ i) cdtn)))
(setq dc1 (inters pt5 pt6 pt1 pt2 T))
(setq dc2 (inters pt5 pt6 pt11 pt51 T))
(setq dc3 (inters pt5 pt6 pt21 pt51 T))
(if (/= dc1 nil) (progn (setq pt1 dc1 bdd1 T)))
(if (/= dc2 nil) (progn (setq pt11 dc2 bdd2 T)))
(if (/= dc3 nil) (progn (setq pt11 dc3 bdd5 T)))
(setq dc1 (inters pt5 pt6 pt3 pt4 T))
(setq dc2 (inters pt5 pt6 pt61 pt41 T))
(setq dc3 (inters pt5 pt6 pt31 pt61 T))
(if (/= dc1 nil) (progn (setq pt4 dc1 bdd3 T)))
(if (/= dc2 nil) (progn (setq pt41 dc2 bdd4 T)))
(if (/= dc3 nil) (progn (setq pt11 dc3 bdd6 T)))
)
(setq i (1+ i))
)
(setq dc1 nil dc2 nil i 0 bdd7 nil bdd8 nil)
(repeat so_buoc
(progn
(setq pt5 (list (nth i kccdsnv) (nth i cdsnv)))
(setq pt6 (list (nth (1+ i) kccdsnv) (nth (1+ i) cdsnv)))
(setq dc1 (inters pt5 pt6 pt11 pt51 T))
(setq dc2 (inters pt5 pt6 pt41 pt61 T))
(if (/= dc1 nil) (setq bdd7 T))
(if (/= dc2 nil) (setq bdd8 T))
)
(setq i (1+ i))
)
(if (/= bdd5 nil)
(progn
(setq pt11 pt51)
)
)
(if (/= bdd6 nil)
(progn
(setq pt41 pt61)
)
)
(if (and (= bdd2 nil) (= bdd5 nil) (/= bdd1 nil))
(setq pt11 (list (- (nth 0 pt1) ssn) (nth 1 pt1)))
)
(if (and (= bdd4 nil) (= bdd6 nil) (/= bdd3 nil))
(setq pt41 (list (+ (nth 0 pt4) ssn) (nth 1 pt4)))
)
;;kiem tra xem duong sau nao vet co cat duong tu nhien o giua cua pt1 va pt11 khong?
(setq i 0 pt11_luu nil pt5 nil pt6 nil kt T dc nil)
(while kt
(progn
(setq pt5 (list (nth i kccdsnv) (nth i cdsnv)))
(setq pt6 (list (nth (1+ i) kccdsnv) (nth (1+ i) cdsnv)))
(setq dc (inters pt5 pt6 pt11 pt1 T))
(if (/= dc nil) (setq pt11_luu dc))
(if (or (/= dc nil) (> (nth i kccdsnv) (nth 0 pt2))) (setq kt nil))
(setq i (1+ i))
)
)
;;kiem tra xem duongn sau nao vet co cat duong tu nhien o giua cua pt4 va pt41 khong?
(setq i 0 pt41_luu nil pt5 nil pt6 nil dc nil kt T)
(setq kccdsnv (reverse kccdsnv))
(setq cdsnv (reverse cdsnv))
(while kt
(progn
(setq pt5 (list (nth i kccdsnv) (nth i cdsnv)))
(setq pt6 (list (nth (1+ i) kccdsnv) (nth (1+ i) cdsnv)))
(setq dc (inters pt5 pt6 pt4 pt41 T))
(if (/= dc nil) (setq pt41_luu dc))
(if (or (/= dc nil) (< (nth i kccdsnv) (nth 0 pt3))) (setq kt nil))
(setq i (1+ i))
)
)
(setq kccdsnv (reverse kccdsnv))
(setq cdsnv (reverse cdsnv))
(setq dc nil)
;;Giao diem voi day thiet ke
(setq i 0)
(setq so_buoc (- (length kccdtn) 1))
(setq list1 '())
(repeat so_buoc
(progn
(setq pt5 (list (nth i kccdtn) (nth i cdtn)))
(setq pt6 (list (nth (1+ i) kccdtn) (nth (1+ i) cdtn)))
(setq dc (inters pt5 pt6 pt2 pt3 T))
(if (/= dc nil)
(cond
((or (and (> (nth 1 pt5) cdd) (< (nth 1 pt6) cdd))
(and (< (nth 1 pt5) cdd) (> (nth 1 pt6) cdd)))
(setq list1 (cons dc list1))
)
((if (and (> i 0) (< i (- so_buoc 1)))
(cond
((and (= (equal (nth 1 pt6) cdd) T)
(<= (nth (+ i 2) cdtn) cdd)
(> (nth 1 pt5) cdd))
(setq list1 (cons dc list1))
)
((and (= (equal (nth 1 pt5) cdd) T)
(> (nth 1 pt6) cdd)
(<= (nth (- i 1) cdtn) cdd))
(setq list1 (cons dc list1))
)
)
)
)
)
)
)
(setq i (1+ i))
)
(setq dc nil pt5 nil pt6 nil)
(setq so_buoc (length kccdsnv) i 0)
(setq list_snv '() list_tn '())
(repeat so_buoc
(setq list_snv (cons (list (nth i kccdsnv) (nth i cdsnv)) list_snv))
(setq list_tn (cons (list (nth i kccdtn) (nth i cdtn)) list_tn))
(setq i (1+ i))
)
(setq list_snv (reverse list_snv))
(setq list_tn (reverse list_tn))
(setq bl (- (length list_tn) 1))
(setq d1 (list (nth 0 pt2) cdmax))
(setq d2 (list (nth 0 pt2) cdmin))
(setq d3 (list (nth 0 pt3) cdmax))
(setq d4 (list (nth 0 pt3) cdmin))
(setq i 0)
(repeat bl
(progn
(setq dc1 (inters d1 d2 (nth i list_tn) (nth (1+ i) list_tn)))
(setq dc2 (inters d3 d4 (nth i list_tn) (nth (1+ i) list_tn)))
(if (/= dc1 nil) (setq moc1 dc1))
(if (/= dc2 nil) (setq moc2 dc2))
)
(setq i (1+ i))
)
(setq i 0 kiemtra nil)
(repeat bl
(progn
(setq pt5 (list (nth i kccdsnv) (nth i cdsnv)))
(setq pt6 (list (nth (1+ i) kccdsnv) (nth (1+ i) cdsnv)))
(setq dc1 (inters pt5 pt6 pt11 pt51 T))
(setq dc2 (inters pt5 pt6 pt21 pt51))
(setq dc3 (inters pt5 pt6 pt61 pt41 T))
(setq dc4 (inters pt5 pt6 pt31 pt61))
(setq dc5 (inters pt5 pt6 pt21 pt31 T))
(if (or (/= dc1 nil) (/= dc2 nil) (/= dc3 nil) (/= dc4 nil) (/= dc5 nil))
(setq kiemtra T)
)
)
(setq i (1+ i))
)
(setq dc1 nil dc2 nil d1 nil d2 nil d3 nil d4 nil bl nil)
;;phan tinh toan
(progn
(setq list1 (reverse list1))
(setq so_ptu (length list1))
(print list1)
(cond
( (= so_ptu 0)
(if (and (= bdd1 T) (= bdd3 T))
(progn
(setq list_lt '() kt T i 0)
(setq list_lt (cons pt1 list_lt))
(while kt
(if (and (> (nth i kccdtn) (nth 0 pt1))
(< (nth i kccdtn) (nth 0 pt4)))
(setq list_lt (cons (list (nth i kccdtn) (nth i cdtn)) list_lt))
)
(setq i (1+ i))
(if (> (nth i kccdtn) (nth 0 pt4)) (setq kt nil))
)
(setq list_lt (cons pt4 list_lt))
(setq list_lt (reverse (cons pt2 (cons pt3 list_lt))))
(if (> (length list_lt) 2)
(progn
(command "AREA")
(foreach n list_lt (command n))
(command "")
(setq dthh (getvar "AREA"))
(command "AREA" pt1 pt2 pt3 pt4 pt41 pt61 pt31 pt21 pt51 pt11 "")
(setq dtss (getvar "AREA"))
)
)
(dientich_phu list_tn pt11 pt1)
(setq dtss (+ dtss dientich1))
(dientich_phu list_tn pt4 pt41)
(setq dtss (+ dtss dientich1))
(if (= kiemtra T)
(progn
(if (/= pt11_luu nil)
(progn
(ham1 list_snv pt11 pt21 pt31 pt51 pt11_luu)
(if (/= dientich2 nil) (setq dtsnv (+ dtsnv dientich2)))
)
)
(if (/= pt41_luu nil)
(progn
(ham2 list_snv pt41 pt31 pt21 pt61 pt41_luu)
(if (/= dientich3 nil) (setq dtsnv (+ dtsnv dientich3)))
)
)
(if (/= pt11_luu nil) (setq pt11 pt71))
(if (/= pt41_luu nil) (setq pt41 pt81))
(tinh_dt list_snv pt11 pt71 pt81 pt41 cdss)
(setq dtsnv (+ dtsnv dientich))
(if (/= bdd7 nil) (setq dtsnv (+ dtsnv dientichthua1)))
(if (/= bdd8 nil) (setq dtsnv (+ dtsnv dientichthua2)))
))
)))
( (/= so_ptu 0)
(progn
(TINH_DT list_tn pt1 pt2 pt3 pt4 cdd)
(setq dthh dientich)
(setq list2 '())
(setq i 0)
(repeat so_ptu
(progn
(setq dc (list (nth 0 (nth i list1)) (- cdd ssd)))
(setq list2 (cons dc list2))
)
(setq i (1+ i))
)
(setq list2 (reverse list2))
(cond
((= (rem so_ptu 2) 0)
(progn
(setq t1 (car list2) t2 (last list2))
(setq t3 (car list1) t4 (last list1))
(if (and (/= bdd1 nil) (> (nth 1 moc1) cdd))
(progn
(setq t3 (list (+ (nth 0 t3) ssn) (nth 1 t3)))
(command "AREA" pt11 pt51 pt21 t1 t3 pt2 pt1 "")
(setq dtss (getvar "AREA"))
(dientich_phu list_tn pt11 pt1)
(setq dtss (+ dtss dientich1))
(if (> dtss dientichdoira) (setq dtss (- dtss dientichdoira)))
(if (= kiemtra T)
(progn
(if (/= pt11_luu nil)
(progn
(ham1 list_snv pt11 pt21 pt31 pt51 pt11_luu)
(if (/= dientich2 nil) (setq dtsnv (+ dtsnv dientich2)))
)
)
(if (= pt11_luu nil) (progn (tinh_dt list_snv pt11 pt71 t1 t3 cdss) (setq dtsnv (+ dtsnv dientich))))
(if (/= bdd7 nil) (setq dtsnv (+ dtsnv dientichthua1)))
))
(setq list1 (cdr list1))
(setq list2 (cdr list2))
)
)
(if (and (/= bdd3 nil) (> (nth 1 moc2) cdd))
(progn
(setq t4 (list (- (nth 0 t4) ssn) (nth 1 t4)))
(command "AREA" t4 t2 pt31 pt61 pt41 pt4 pt3 "")
(setq dtss (+ dtss (getvar "AREA")))
(dientich_phu list_tn pt4 pt41)
(setq dtss (+ dtss dientich1))
(if (> dtss dientichdoira) (setq dtss (- dtss dientichdoira)))
(if kiemtra
(progn
(if (/= pt41_luu nil)
(progn
(ham2 list_snv pt41 pt31 pt21 pt61 pt41_luu)
(if (/= dientich3 nil) (setq dtsnv (+ dtsnv dientich3)))
)
)
(if (= pt41_luu nil) (progn (tinh_dt list_snv t4 t2 pt81 pt41 cdss) (setq dtsnv (+ dtsnv dientich))))
(if (/= bdd8 nil) (setq dtsnv (+ dtsnv dientichthua2)))
))
(setq list1 ( reverse (cdr (reverse list1))))
(setq list2 ( reverse (cdr (reverse list2))))
)
)
(if (> (length list1) 1)
(progn
(setq i 0)
(repeat (/ (length list1) 2)
(progn
(setq t1 (nth i list1) t2 (nth i list2))
(setq t3 (nth (1+ i) list2) t4 (nth (1+ i) list1))
(setq t1 (list (- (nth 0 t1) ssn) (nth 1 t1)))
(setq t4 (list (+ (nth 0 t4) ssn) (nth 1 t4)))
(command "AREA" t1 t2 t3 t4 "")
(setq dtss (+ dtss (getvar "AREA")))
(if (> dtss (* dientichdoira 2)) (setq dtss (- dtss (* dientichdoira 2))))
(tinh_dt list_snv t1 t2 t3 t4 cdss)
(setq dtsnv (+ dtsnv dientich))
)
(setq i (+ i 2))
)
)
)
))
((= (rem so_ptu 2) 1)
(progn
(if (/= bdd1 nil)
(if (and (/= moc1 nil) (> (nth 1 moc1) cdd))
(progn
(setq t1 (car list2) t2 (car list1))
(setq t2 (list (+ (nth 0 t2) ssn) (nth 1 t2)))
(command "AREA" pt11 pt51 pt21 t1 t2 pt2 pt1 "")
(setq dtss (getvar "AREA"))
(dientich_phu list_tn pt11 pt1)
(setq dtss (+ dtss dientich1))
(if (> dtss dientichdoira) (setq dtss (- dtss dientichdoira)))
(if (= kiemtra T)
(progn
(if (/= pt11_luu nil)
(progn
(ham1 list_snv pt11 pt21 pt31 pt51 pt11_luu)
(if (/= dientich2 nil) (setq dtsnv (+ dtsnv dientich2)))
)
)
(if (= pt11_luu nil) (progn (tinh_dt list_snv pt11 pt71 t1 t2 cdss) (setq dtsnv (+ dtsnv dientich))))
(if (/= bdd7 nil) (setq dtsnv (+ dtsnv dientichthua1)))
))
(setq list1 (cdr list1))
(setq list2 (cdr list2))
)
))
(if (/= bdd3 nil)
(if (and (/= moc2 nil) (> (nth 1 moc2) cdd))
(progn
(setq t1 (last list1) t2 (last list2))
(setq t1 (list (- (nth 0 t1) ssn) (nth 1 t1)))
(command "AREA" t1 t2 pt31 pt61 pt41 pt4 pt3 "")
(setq dtss (getvar "AREA"))
(dientich_phu list_tn pt4 pt41)
(setq dtss (+ dtss dientich1))
(if (> dtss dientichdoira) (setq dtss (- dtss dientichdoira)))
(if (= kiemtra T)
(progn
(if (/= pt41_luu nil)
(progn
(ham2 list_snv pt41 pt31 pt21 pt61 pt41_luu)
(if (/= dientich3 nil) (setq dtsnv (+ dtsnv dientich3)))
)
)
(if (= pt41_luu nil) (progn (tinh_dt list_snv t1 t2 pt81 pt41 cdss) (setq dtsnv (+ dtsnv dientich))))
(if (/= bdd8 nil) (setq dtsnv (+ dtsnv dientichthua1)))
))
(setq list1 ( reverse (cdr (reverse list1))))
(setq list2 ( reverse (cdr (reverse list2))))
)
))
(if (> (length list1) 0)
(progn
(setq i 0)
(repeat (/ (length list1) 2)
(progn
(setq t1 (nth i list1) t2 (nth i list2))
(setq t1 (list (- (nth 0 t1) ssn) (nth 1 t1)))
(setq t3 (nth (1+ i) list2) t4 (nth (1+ i) list1))
(setq t4 (list (- (nth 0 t1) ssn) (nth 1 t4)))
(command "AREA" t1 t2 t3 t4 "")
(setq dtss (+ dtss (getvar "AREA")))
(if (> dtss (* dientichdoira 2)) (setq dtss (- dtss (* dientichdoira 2))))
(if kiemtra
(progn
(tinh_dt list_snv t1 t2 t3 t4 cdss)
(setq dtsnv (+ dtsnv dientich))
))
)
(setq i (+ i 2))
)
)
)
))
)
))
)
)
(setq dtsnv (- dtss dtsnv))
)
;;************************************
(defun CAL_AREA ()
(setq dthh 0 dtss 0 dtsnv 0)
(dien_tich)
(command "COLOR" "GREEN" "")
(command "_.STYLE" "KC1" ".VnTimeI" "0" "1" "5" "N" "N" "")
(setq ddat (list (/ ghmn 2) 15))
(command "TEXT" "J" "C" ddat "2" "0" (strcat "Shh = " (rtos dthh) " m2"))
(setq ddat (list (/ ghmn 2) 12))
(command "TEXT" "J" "C" ddat "2" "0" (strcat "Sss = " (rtos dtss) " m2"))
(setq ddat (list (/ ghmn 2) 9))
(command "TEXT" "J" "C" ddat "2" "0" (strcat "Ssnv = " (rtos dtsnv) " m2"))
(setq d11 (list -85 (- ghd 70)))
(setq d12 (list -85 50))
(setq d13 (list (+ ghmn 10) 50))
(setq d14 (list (+ ghmn 10) (- ghd 70)))
(command "_.LINE" d11 d12 d13 d14 d11 "")
(setq d1 (list (- (nth 0 d11) 5) (- (nth 1 d11) 10)))
(setq d3 (list (+ (nth 0 d13) 5) (+ (nth 1 d13) 5)))
(command "ZOOM" "WINDOW" d1 d3 "")
(setq d12 (list ( - (nth 0 d13) 30) 50))
(setq d11 (list (nth 0 d12) 30))
(setq d14 (list (nth 0 d13) 30))
(command "_.LINE" d11 d12 "")
(command "_.LINE" d11 d14 "")
(setq ddat (list ( - (nth 0 d13) 15) 43))
(command "_.STYLE" "KC2" ".VnTimeH" "0" "1" "15" "N" "N" "")
(command "TEXT" "J" "C" ddat "5" "0" namect "")
(setq d11 (list (nth 0 d12) 40))
(setq d14 (list (nth 0 d13) 40))
(command "_.LINE" d11 d14 "")
(setq d11 nil d12 nil d13 nil d14 nil ghmn nil ghd nil d1 nil d3 nil so_ptu nil)
(setq filename nil dthh nil dtss nil dtsnv nil list_midpoint nil cd nil)
(setq list_lt nil list_up nil dientich nil dientich1 nil dientich2 nil)
(setq dientich3 nil list1 nil list2 nil t1 nil t2 nil t3 nil mdtrong nil n2 nil)
(setq t4 nil cd1 nil dc2 nil i nil j nil cdss nil list_snv nil mdngoai nil)
(setq pt1 nil pt2 nil pt3 nil pt4 nil bdd1 nil bdd2 nil bdd4 nil tlx nil tln nil bdd5 nil bdd6 nil)
(setq pt11 nil pt21 nil pt31 nil pt41 nil list_tn nil so_buoc nil)
(setq cdtn nil kcltn nil kccdtn nil cdsnv nil kclsnv nil kccdsnv nil)
(setq mt nil dtrong nil mn nil dngoai nil cdd nil cdday nil ssd nil deta_X nil)
(setq ssn nil deta_Y nil cdmax nil cdmax nil cdmin nil cdmin nil n1 nil)
(setq point1 nil point2 nil moc1 nil moc2 nil ghmn nil ddat nil dc nil)
(setq dientichthua1 nil dientichthua2 nil dientichdoira nil kiemtra nil)
(setvar "BLIPMODE" 1)
(setvar "LUPREC" 4)
(command "_.REGENALL")
);;end
;;**************************************
;;END_FILE
Cal1.lsp
(defun C:CAL1 ()
(DRAW)
(CAL_AREA)
)
Draw.lsp
;;*******************************************
(defun mytext (diem st)
(command "TEXT" "J" "C" diem "3.0" "0" st "")
(setq diem nil)
);;end defun viet chu ra man hinh
;;*******************************************
;;Chuong trinh ve
(defun DRAW ()
(READ_DATA)
(setvar "LUPREC" 4)
(setvar "TEXTFILL" 1)
(setvar "LUNITS" 2)
(setq st '("Cao ®é tù nhiªn (m)" "K/c lÎ tù nhiªn (m)" "K/c céng dån TN (m)"
"Cao ®é thiÕt kÕ (m)" "K/c lÎ thiÕt kÕ (m)"
"Cao ®é SNV (m)" "K/c lÎ SNV (m)" "K/c céng dån SNV (m)" ""))
(if (and (>= (last cdtn) cdd) (< (last kccdtn) mn) (> (last kccdtn) (- mn 20)))
(bao_loi ""
(strcat "D÷ liÖu cha ®îc n¹p gÇn ®Õn mÐp ngoµi."
"\nB¹n nªn n¹p thªm mét vµi cao ®é n÷a ®Ó vÏ!."))
)
(if (> n1 100)
(setq pt1 (list mt cdmax))
(setq pt1 (list (- mt (* (- cdmax cdd) n1)) cdmax))
)
(setq pt2 (list mt cdd))
(setq pt3 (list mn cdd))
(if (> n2 100)
(setq pt4 (list mn cdmax))
(setq pt4 (list (+ mn (* (- cdmax cdd) n2)) cdmax))
)
(command "LTSCALE" "10" "")
(cond
((<= (abs (- cdmax cdmin)) 15) (setq buoc 1))
((and (> (abs (- cdmax cdmin)) 15) (<= (abs (- cdmax cdmin)) 30)) (setq buoc 2))
((and (> (abs (- cdmax cdmin)) 30) (<= (abs (- cdmax cdmin)) 45)) (setq buoc 4))
((> (abs (- cdmax cdmin)) 45) (setq buoc 1))
)
(setvar "BLIPMODE" 0)
(command "LAYER" "M" "DRAW" "")
(command "COLOR" "WHITE" "")
(setq pt11 (list (- (nth 0 pt1) ssn) (nth 1 pt1)))
(setq pt41 (list (+ (nth 0 pt4) ssn) (nth 1 pt4)))
(setq pt21 (list mt (- cdd ssd)))
(setq pt31 (list mn (- cdd ssd)))
(setq pt51 (list (- mt ssn) cdd))
(setq pt61 (list (+ mn ssn) cdd))
(setq i 0 bdd1 nil bdd2 nil bdd3 nil bdd4 nil)
(setq so_buoc (- (length kccdtn) 1))
(repeat so_buoc
(progn
(setq pt5 (list (nth i kccdtn) (nth i cdtn)))
(setq pt6 (list (nth (1+ i) kccdtn) (nth (1+ i) cdtn)))
(setq dc1 (inters pt5 pt6 pt1 pt2))
(setq dc2 (inters pt5 pt6 pt11 pt51))
(setq dc3 (inters pt5 pt6 pt21 pt51))
(if (/= dc1 nil) (progn (setq pt1 dc1 bdd1 T)))
(if (/= dc2 nil) (progn (setq pt11 dc2 bdd2 T)))
(if (/= dc3 nil) (progn (setq pt11 dc3 bdd5 T)))
(setq dc1 (inters pt5 pt6 pt3 pt4))
(setq dc2 (inters pt5 pt6 pt41 pt61))
(setq dc3 (inters pt5 pt6 pt31 pt61))
(if (/= dc1 nil) (progn (setq pt4 dc1 bdd3 T)))
(if (/= dc2 nil) (progn (setq pt41 dc2 bdd4 T)))
(if (/= dc3 nil) (progn (setq pt41 dc3 bdd6 T)))
)
(setq i (1+ i))
)
(if (/= bdd5 nil)
(progn
(setq pt11 pt51)
)
)
(if (/= bdd6 nil)
(progn
(setq pt41 pt61)
)
)
(if (and (= bdd1 nil) (= bdd5 nil))
(setq pt1 pt2 pt11 pt21))
(if (and (= bdd6 nil) (= bdd3 nil))
(setq pt4 pt3 pt41 pt31))
(if (and (= bdd2 nil) (/= bdd1 nil))
(setq pt11 (list (- (nth 0 pt1) ssn) (nth 1 pt1)))
)
(if (and (= bdd4 nil) (/= bdd3 nil))
(setq pt41 (list (+ (nth 0 pt4) ssn) (nth 1 pt4)))
)
;;Dat diem so sanh de ve duong sai so sau nay
(setq diemss1 pt1 diemss2 pt4)
(setq mn1 (+ (nth 0 pt4) ssn))
(setq gt1 (last kccdtn))
(setq gt2 (last kccdsnv))
(setq gt (max gt1 gt2 mn mn1))
(setq tln (getreal "\nNhap vao ti le ngang cho ban ve (1 / 1.5 / 2 / ...):"))
(if (= tln nil)
(setq tln 1.5)
)
(setq ghmn (+ (* gt tln) 10))
(setq tlx (/ 10.0 buoc))
(setq gt1 nil gt2 nil mn1 nil gt nil)
(setq ddcd (- 0 cdmax))
;;Ve he toa do
(setq pt_up (fix cdmax) pt_dow (fix cdmin))
(if (= (equal pt_up cdmax) nil)
(progn (setq pt_up (+ pt_up 1) ddcd (- ddcd (- pt_up cdmax)))))
(if (= (equal pt_dow cdmin) nil) (setq pt_dow (- pt_dow 1)))
(command "COLOR" "GREEN" "")
(command "_.STYLE" "KC1" ".VnTime" "0" "1" "15" "N" "N" "")
(setq ddcd (* ddcd tlx))
(setq tdy 0)
(setq stt pt_up)
(while (<= pt_dow stt)
(progn
(setq diem1 (list -10 (* tdy 10)))
(setq diem2 (list -9 (* tdy 10)))
(setq startptext (list -20 (* tdy 10)))
(setq stttext (strcat (itoa stt) ".0"))
(command "LINE" diem1 diem2 "")
(command "TEXT" startptext "2.0" "0" stttext "")
(if (= (rem tdy 2) 0)
(progn
(setq diem3 (list -10 (* (+ tdy 1) 10)))
(setq diem4 (list -9 (* (+ tdy 1) 10)))
(command "SOLID" diem1 diem2 diem3 diem4 "")
)
)
)
(setq tdy (1- tdy))
(setq stt (- stt buoc))
)
(setq ghd (* tdy 10))
(setq diem1 (list -10 0))
(setq diem2 (list -10 (* (+ tdy 1) 10)))
(command "LINE" diem1 diem2 "")
(setq diem1 (list -9 0))
(setq diem2 (list -9 (* (+ tdy 1) 10)))
(command "LINE" diem1 diem2 "")
(setq stt nil tdy nil startptext nil stttext nil diem1 nil diem2 nil tdy1 nil)
;; Tinh toan va ve duong tu nhien
(setq list1 '())
(setq i 0)
(repeat (length cdtn)
(progn
(setq td (+ (* (nth i cdtn) tlx) ddcd))
(setq hd (* (nth i kccdtn) tln))
(setq ptu (list hd td))
(setq list1 (cons ptu list1))
)
(setq i (1+ i))
)
(setq list1 (reverse list1))
(setq ptu nil i nil td nil hd nil i nil)
(command "LINETYPE" "LOAD" "DASHED" "ACAD.LIN" "SET" "DASHED" "")
(command "COLOR" "RED" "")
(command "PLINE")
(foreach n list1 (command n))
(command "")
(setq list1 '())
(setq i 0)
(repeat (length cdsnv)
(progn
(setq td (+ (* (nth i cdsnv) tlx) ddcd))
(setq hd (* (nth i kccdsnv) tln))
(setq ptu (list hd td))
(setq list1 (cons ptu list1))
)
(setq i (1+ i))
)
(setq list1 (reverse list1))
(setq ptu nil i nil td nil hd nil)
(command "LINETYPE" "SET" "CONTINUOUS" "")
(command "COLOR" "CYAN" "")
(command "PLINE" )
(foreach n list1 (command n))
(command "")
(setq list1 nil)
;; Xem tai mt, mn giao diem voi duong tu nhien o dau
(setq i 0)
(setq so_buoc (- (length kccdtn) 1))
(setq list1 '())
(repeat so_buoc
(progn
(setq pt5 (list (nth i kccdtn) (nth i cdtn)))
(setq pt6 (list (nth (1+ i) kccdtn) (nth (1+ i) cdtn)))
(setq dc (inters pt5 pt6 pt2 pt3))
(if (/= dc nil)
(cond
((or (and (> (nth 1 pt5) cdd) (< (nth 1 pt6) cdd))
(and (< (nth 1 pt5) cdd) (> (nth 1 pt6) cdd)))
(setq list1 (cons dc list1))
)
((or (and (> (nth 1 pt5) cdd) (= (nth 1 pt6) cdd))
(and (= (nth 1 pt5) cdd) (> (nth 1 pt6) cdd)))
(setq list1 (cons dc list1))
)
((if (and (> i 0) (< i (- so_buoc 1)))
(cond
((and (= (equal (nth 1 pt6) cdd) T)
(<= (nth (+ i 2) cdtn) cdd)
(> (nth 1 pt5) cdd)
)
(setq list1 (cons dc list1))
)
((and (= (equal (nth 1 pt5) cdd) T)
(> (nth 1 pt6) cdd)
(<= (nth (- i 1) cdtn) cdd))
(setq list1 (cons dc list1))
)
)
)
)
)
)
)
(setq i (1+ i))
)
(setq list1 (reverse list1))
(setq dc nil pt5 nil pt6 nil so_buoc nil i nil)
(setq pt1text pt1 pt4text pt4)
;;Ve duong thiet ke
(setq pt1 (list (* (nth 0 pt1) tln) (+ (* (nth 1 pt1) tlx) ddcd)))
(setq pt4 (list (* (nth 0 pt4) tln) (+ (* (nth 1 pt4) tlx) ddcd)))
(setq pt2 (list (* mt tln) (+ (* cdd tlx) ddcd)))
(setq pt3 (list (* mn tln) (+ (* cdd tlx) ddcd)))
(command "LINETYPE" "SET" "CONTINUOUS" "")
(command "COLOR" "MAGENTA" "")
(command "LINE" pt1 pt2 pt3 pt4 "")
(command "COLOR" "RED" "")
(command "LINE" (list (nth 0 pt1) ghd) pt1 "")
(command "LINE" (list (nth 0 pt2) ghd) pt2 "")
(command "LINE" (list (nth 0 pt3) ghd) pt3 "")
(command "LINE" (list (nth 0 pt4) ghd) pt4 "")
(command "COLOR" "GREEN" "")
(command "LINE" (list (nth 0 pt1) (- ghd 32)) (list (nth 0 pt1) (- ghd 40)) "")
(command "LINE" (list (nth 0 pt2) (- ghd 32)) (list (nth 0 pt2) (- ghd 40)) "")
(command "LINE" (list (nth 0 pt3) (- ghd 32)) (list (nth 0 pt3) (- ghd 40)) "")
(command "LINE" (list (nth 0 pt4) (- ghd 32)) (list (nth 0 pt4) (- ghd 40)) "")
;; Ve duong sai so
(setq pt11 (list (* (nth 0 pt11) tln) (+ (* (nth 1 pt11) tlx) ddcd)))
(setq pt41 (list (* (nth 0 pt41) tln) (+ (* (nth 1 pt41) tlx) ddcd)))
(setq pt21 (list (* (nth 0 pt21) tln) (+ (* (nth 1 pt21) tlx) ddcd)))
(setq pt31 (list (* (nth 0 pt31) tln) (+ (* (nth 1 pt31) tlx) ddcd)))
(setq pt51 (list (* (nth 0 pt51) tln) (+ (* (nth 1 pt51) tlx) ddcd)))
(setq pt61 (list (* (nth 0 pt61) tln) (+ (* (nth 1 pt61) tlx) ddcd)))
(command "LINETYPE" "LOAD" "CENTER" "ACAD.LIN" "SET" "CENTER" "")
(command "COLOR" "WHITE" "")
(setq sd (length list1))
(cond
( (= sd 0)
(if (and (= bdd4 T) (= bdd1 T))
(command "LINE" pt11 pt51 pt21 pt31 pt61 pt41 ""))
)
( (/= sd 0)
(progn
(setq list2 '())
(setq i 0)
(repeat sd
(progn
(setq dc (list (nth 0 (nth i list1)) (- cdd ssd)))
(setq list2 (cons dc list2))
)
(setq i (1+ i))
)
(setq list2 (reverse list2))
(cond
((= (rem sd 2) 0)
(progn
(setq t1 (list (* (nth 0 (car list2)) tln) (+ (* (nth 1 (car list2)) tlx) ddcd)))
(setq t2 (list (* (nth 0 (last list2)) tln) (+ (* (nth 1 (last list2)) tlx) ddcd)))
(setq t3 (list (* (+ (nth 0 (car list1)) (/ ssn 2)) tln) (+ (* (- (nth 1 (car list1)) (/ ssd 2)) tlx) ddcd)))
(setq t4 (list (* (- (nth 0 (last list1)) (/ ssn 2)) tln) (+ (* (- (nth 1 (last list1)) (/ ssd 2)) tlx) ddcd)))
(if (and (/= bdd3 nil) (> (nth 1 diemss2) cdd)) (command "LINE" pt41 pt61 pt31 t2 t4 ""))
(if (and (/= bdd1 nil) (> (nth 1 diemss1) cdd)) (command "LINE" pt11 pt51 pt21 t1 t3 ""))
(if (and (/= bdd1 nil) (> (length list1) 2))
(progn
(setq i 1)
(repeat (/ (- sd 2) 2)
(progn
(setq t1 (list (* (- (nth 0 (nth i list1)) (/ ssn 2)) tln) (+ (* (- (nth 1 (nth i list1)) (/ ssd 2)) tlx) ddcd)))
(setq t2 (list (* (nth 0 (nth i list2)) tln) (+ (* (nth 1 (nth i list2)) tlx) ddcd)))
(setq t3 (list (* (nth 0 (nth (1+ i) list2)) tln) (+ (* (nth 1 (nth (1+ i) list2)) tlx) ddcd)))
(setq t4 (list (* (+ (nth 0 (nth (1+ i) list1)) (/ ssn 2)) tln) (+ (* (- (nth 1 (nth (1+ i) list1)) (/ ssd 2)) tlx) ddcd)))
(command "LINE" t1 t2 t3 t4 "")
)
(setq i (+ i 2))
)
)
)
(if (and (= bdd1 nil) (>= (length list1) 2))
(progn
(setq i 0)
(repeat (/ sd 2)
(progn
(setq t1 (list (* (- (nth 0 (nth i list1)) (/ ssn 2)) tln) (+ (* (- (nth 1 (nth i list1)) (/ ssd 2)) tlx) ddcd)))
(setq t2 (list (* (nth 0 (nth i list2)) tln) (+ (* (nth 1 (nth i list2)) tlx) ddcd)))
(setq t3 (list (* (nth 0 (nth (1+ i) list2)) tln) (+ (* (nth 1 (nth (1+ i) list2)) tlx) ddcd)))
(setq t4 (list (* (+ (nth 0 (nth (1+ i) list1)) (/ ssn 2)) tln) (+ (* (- (nth 1 (nth (1+ i) list1)) (/ ssd 2)) tlx) ddcd)))
(command "LINE" t1 t2 t3 t4 "")
)
(setq i (+ i 2))
)
)
)
))
((= (rem sd 2) 1)
(progn
(setq t1 (list (* (nth 0 (car list2)) tln) (+ (* (nth 1 (car list2)) tlx) ddcd)))
(setq t2 (list (* (+ (nth 0 (car list1)) (/ ssn 2)) tln) (+ (* (- (nth 1 (car list1)) (/ ssd 2)) tlx) ddcd)))
(if (and (/= bdd1 nil) (> (nth 1 diemss1) cdd)) (command "LINE" pt11 pt51 pt21 t1 t2 ""))
(setq t1 (list (* (- (nth 0 (last list1)) (/ ssn 2)) tln) (+ (* (- (nth 1 (last list1)) (/ ssd 2)) tlx) ddcd)))
(setq t2 (list (* (nth 0 (last list2)) tln) (+ (* (nth 1 (last list2)) tlx) ddcd)))
(if (and (/= bdd3 nil) (> (nth 1 diemss2) cdd)) (command "LINE" t1 t2 pt31 pt61 pt41 ""))
(if (and (/= bdd1 nil) (> (length list1) 1))
(progn
(setq i 1)
(repeat (/ (- sd 1) 2)
(progn
(setq t1 (list (* (- (nth 0 (nth i list1)) (/ ssn 2)) tln) (+ (* (- (nth 1 (nth i list1)) (/ ssd 2)) tlx) ddcd)))
(setq t2 (list (* (nth 0 (nth i list2)) tln) (+ (* (nth 1 (nth i list2)) tlx) ddcd)))
(setq t3 (list (* (nth 0 (nth (1+ i) list2)) tln) (+ (* (nth 1 (nth (1+ i) list2)) tlx) ddcd)))
(setq t4 (list (* (+ (nth 0 (nth (1+ i) list1)) (/ ssn 2)) tln) (+ (* (- (nth 1 (nth (1+ i) list1)) (/ ssd 2)) tlx) ddcd)))
(command "LINE" t1 t2 t3 t4 "")
)
(setq i (+ i 2))
)
)
)
(if (and (= bdd1 nil) (> (length list1) 2))
(progn
(setq i 0)
(repeat (/ (- sd 1) 2)
(progn
(setq t1 (list (* (- (nth 0 (nth i list1)) ssn) tln) (+ (* (nth 1 (nth i list1)) tlx) ddcd)))
(setq t2 (list (* (nth 0 (nth i list2)) tln) (+ (* (nth 1 (nth i list2)) tlx) ddcd)))
(setq t3 (list (* (nth 0 (nth (1+ i) list2)) tln) (+ (* (nth 1 (nth (1+ i) list2)) tlx) ddcd)))
(setq t4 (list (* (+ (nth 0 (nth (1+ i) list1)) ssn) tln) (+ (* (nth 1 (nth (1+ i) list1)) tlx) ddcd)))
(command "LINE" t1 t2 t3 t4 "")
)
(setq i (+ i 2))
)
)
)
)
)
)
)
)
)
(command "LINETYPE" "SET" "DASHED" "")
(command "COLOR" "RED" "")
(if (and (= bdd4 nil) (/= bdd3 nil)) (command "LINE" pt4 pt41 ""))
(setq pt11 nil pt31 nil pt21 nil pt41 nill t1 nil t2 nil t3 nil t4 nil)
(setq bdd1 nil bdd2 nil bdd3 nil bdd4 nil list1 nil list2 nil diemss1 nil diemss2 nil)
(setq dc1 nil dc2 nil p1 nil p2 nil ptt1 nil ptt2 nil so_buoc nil)
(command "LINETYPE" "SET" "CONTINUOUS" "")
(command "COLOR" "GREEN" "")
(command "_.STYLE" "KC1" ".VnTime" "0" "1" "15" "N" "N" "")
;;ve duong dong cua duong tu nhien va duong phan cach khoang cach le duong tu nhien
(setvar "LUPREC" 1)
(setvar "LUNITS" 2)
(setq i 0)
(repeat (length cdtn)
(progn
(setq td1 (+ (* (nth i cdtn) tlx) ddcd))
(setq hd1 (* (nth i kccdtn) tln))
(setq d1 (list hd1 td1))
(setq d2 (list hd1 ghd))
(setq starttext (list hd1 (- ghd 6)))
(command "LINE" d1 d2 "")
(mytext starttext (rtos (nth i cdtn)))
(setq d1 (list hd1 (- ghd 8)))
(setq d2 (list hd1 (- ghd 16)))
(setq starttext (list hd1 (- ghd 22)))
(command "LINE" d1 d2 "")
(mytext starttext (rtos (nth i kccdtn)))
(if (> i 0)
(progn
(setq hd (+ (nth i kccdtn) (nth (- i 1) kccdtn)))
(setq hd (* (/ hd 2.0) tln))
(setq starttext (list hd (- ghd 14)))
(mytext starttext (rtos (nth i kcltn)))
))
)
(setq i (1+ i))
)
(setq td1 nil hd1 nil d1 nil d2 nil starttext nil i nil)
(setq text1 (rtos (nth 1 pt1text)))
(mytext (list (nth 0 pt1) (- ghd 30)) text1)
(mytext (list (nth 0 pt2) (- ghd 30)) cdday)
(mytext (list (nth 0 pt3) (- ghd 30)) cdday)
(setq text1 (rtos (nth 1 pt4text)))
(mytext (list (nth 0 pt4) (- ghd 30)) text1)
(setq text1 nil l nil)
(setq hd1 (/ (+ (nth 0 pt2) (nth 0 pt1)) 2.0))
(setq text (rtos (- mt (nth 0 pt1text))))
(mytext (list hd1 (- ghd 38)) text)
(setq hd1 (/ (+ (nth 0 pt3) (nth 0 pt2)) 2.0))
(setq text (rtos (- mn mt)))
(mytext (list hd1 (- ghd 38)) text)
(setq hd1 (/ (+ (nth 0 pt4) (nth 0 pt3)) 2.0))
(setq text (rtos (- (nth 0 pt4text) mn)))
(mytext (list hd1 (- ghd 38)) text)
(setq pt1text nil pt4text nil)
;;ve duong dong cua duong sau nao vet va duong phan cach khoang cach le snv
(setq i 0)
(repeat (length cdsnv)
(progn
(setq td1 (+ (* (nth i cdsnv) tlx) ddcd))
(setq hd1 (* (nth i kccdsnv) tln))
(setq d1 (list hd1 td1))
(setq d2 (list hd1 ghd))
(setq starttext (list hd1 (- ghd 46)))
(command "LINETYPE" "SET" "DASHED" "")
(command "COLOR" "8" "")
(command "LINE" d1 d2 "")
(command "LINETYPE" "SET" "CONTINUOUS" "")
(command "COLOR" "GREEN" "")
(mytext starttext (rtos (nth i cdsnv)))
(setq d1 (list hd1 (- ghd 48)))
(setq d2 (list hd1 (- ghd 56)))
(setq starttext (list hd1 (- ghd 62)))
(command "LINE" d1 d2 "")
(mytext starttext (rtos (nth i kccdsnv)))
(if (> i 0)
(progn
(setq hd (+ (nth i kccdsnv) (nth (- i 1) kccdsnv)))
(setq hd (* (/ hd 2.0) tln))
(setq starttext (list hd (- ghd 54)))
(mytext starttext (rtos (nth i kclsnv)))
)
)
)
(setq i (1+ i))
)
(setq td1 nil hd1 nil d1 nil d2 nil starttext nil i nil)
;;Viet chu trong khung
(setq tdy ghd)
(setq i 0)
(repeat 9
(progn
(setq tdytext (- tdy 6.0))
(setq diem1 (strcat "-75," (rtos tdy)))
(setq diem2 (strcat (rtos ghmn) "," (rtos tdy)))
(setq startptext (strcat "-70," (rtos tdytext)))
(command "LINE" diem1 diem2 "")
(command "TEXT" startptext "3.0" "0" (nth i st) "")
)
(setq tdy (- tdy 8))
(setq i (1+ i))
)
(setq diem1 (strcat "-75," (rtos ghd)))
(setq diem2 (strcat "-75," (rtos (- ghd 64))))
(command "LINE" diem1 diem2 "")
(setq diem1 (strcat "-9," (rtos ghd)))
(setq diem2 (strcat "-9," (rtos (- ghd 64))))
(command "LINE" diem1 diem2"")
(setq diem1 (strcat (rtos ghmn) "," (rtos ghd)))
(setq diem2 (strcat (rtos ghmn) "," (rtos (- ghd 64))))
(command "LINE" diem1 diem2 "")
(setq ddat (list (/ ghmn 2) 20))
(command "_.STYLE" "KC2" ".VnTimeH" "0" "1" "15" "N" "N" "")
(command "TEXT" "J" "C" ddat "3" "0" (strcat "MÆt c¾t: " SHBV) "")
(command "_.STYLE" "KC1" ".VnTime" "0" "1" "15" "N" "N" "")
(setq i nil tdy nil diem1 nil diem2 nil tdytext nil startptext nil ddcd nil)
)
;;*******************************
;;END_FILE
error.lsp
//Ham bao loi ban dau khi tim file chuong trinh
(defun bao_loi (file_ct msg)
(defun *error* (s)
(if old_error (setq *error* old_error)) (princ))
(if msg (alert (strcat " Ch¬ng tr×nh bÞ lçi ! " File_ct "\n\n" msg " \n")))
(setq filename nil)
(exit)
);;end defun
//****************************
và Read.lsp
*****************************************************************************
(defun Read_data (/ fo)
(setvar "LUNITS" 2)
(setvar "LUPREC" 2)
(if (= filename nil) (setq filename (getfiled "Open Data" "C:/NAOVET/" "TXT" 8)))
(if (/= filename nil)
(progn
(setq cdtn '() kcltn '() kccdtn '() cdsnv '() kclsnv '() kccdsnv'())
(setq sodong 0)
(setq fo (open filename "r"))
(if fo
(progn
(while (and (setq st (read-line fo)) (/= st ""))
(setq sodong (1+ sodong))
(cond
((= sodong 1) (setq namect st))
((= sodong 2) (setq shbv st))
((= sodong 3) (setq mt (distof st)))
((= sodong 4) (setq mn (distof st)))
((= sodong 5) (setq cdd (distof st)))
((= sodong 6) (setq n1 (distof st)))
((= sodong 7) (setq n2 (distof st)))
((= sodong 8) (setq cdmax (distof st)))
((= sodong 9) (setq cdmin (distof st)))
((= sodong 10) (setq ssd (distof st)))
((= sodong 11) (setq ssn (distof st)))
((>= sodong 12)
(progn
(setq d (strlen st))
(setq dem 0)
(setq vitri '())
(repeat d
(setq dem (1+ dem))
(setq s (substr st dem 1))
(if (= s "\t")
(setq vitri (cons dem vitri))
)
)
(setq vitri (reverse vitri))
(setq cdtn (cons (distof (substr st 1 (nth 0 vitri)) 2) cdtn))
(setq kcltn (cons (distof (substr st (nth 0 vitri) (- (nth 1 vitri) (nth 0 vitri))) 2) kcltn))
(setq kccdtn (cons (distof (substr st (nth 1 vitri) (- (nth 2 vitri) (nth 1 vitri))) 2) kccdtn))
(setq cdsnv (cons (distof (substr st (nth 2 vitri) (- (nth 3 vitri) (nth 2 vitri))) 2) cdsnv))
(setq kclsnv (cons (distof (substr st (nth 3 vitri) (- (nth 4 vitri) (nth 3 vitri))) 2) kclsnv))
(setq kccdsnv (cons (distof (substr st (nth 4 vitri)) 2) kccdsnv))
)
)
)
)
)
)
(close fo)
)
)
(setq cdtn (reverse cdtn))
(setq kcltn (reverse kcltn))
(setq kccdtn (reverse kccdtn))
(setq cdsnv (reverse cdsnv))
(setq kclsnv (reverse kclsnv))
(setq kccdsnv (reverse kccdsnv))
(setq d (strlen shbv))
(setq dem d)
(repeat d
(setq s (substr shbv dem 1))
(if (= s "\t") (setq shbv (substr shbv 1 (1- dem))))
(setq dem (1- dem))
)
(setq dem nil s nil vitri nil fo nil sodong nil d nil st nil filename nil)
)
***********************************************************
với lệnh cal1 để nhập số liệu mặt cắt có dạng:
17.5
44.5
-1.68
5
5
2
-6
0
0
-0.16 0 0 -0.16 0 0
-0.77 2.5 2.5 -0.77 2.5 2.5
-1.38 2.5 5 -1.55 2.5 5
-1.94 2.5 7.5 -1.80 2.5 7.5
-2.31 2.5 10 -2.05 2.5 10
-2.67 2.5 12.5 -2.30 2.5 12.5
-3.04 2.5 15 -2.55 2.5 15
-3.41 2.5 17.5 -2.80 2.5 17.5
-3.77 2.5 20 -3.05 2.5 20
-4.14 2.5 22.5 -3.10 2.5 22.5
-4.38 2.5 25 -3.15 2.5 25
-4.01 2.5 27.5 -3.20 2.5 27.5
-3.58 2.5 30 -3.25 2.5 30
-3.16 2.5 32.5 -3.30 2.5 32.5
-2.74 2.5 35 -3.35 2.5 35
-2.32 2.5 37.5 -3.40 2.5 37.5
-2 2.5 40 -3.45 2.5 40
-1.57 2.5 42.5 -3.45 2.5 42.5
-1.12 2.5 45 -3.45 2.5 45
-0.65 2.5 47.5 -3.45 2.5 47.5
-0.31 2.5 50 -3.45 2.5 50
-0.01 2.5 52.5 -3.48 2.5 52.5
0.28 2.5 55 -3.50 2.5 55
0.56 2.5 57.5 0.56 2.5 57.5
0.84 2.5 60 0.84 2.5 60
Vấn đề em gặp phải là số liệu xuất ra phần thập phân làm tròn đến 1 chữ số sau dấu "." chứ không phải là 2 như em mong muốn (1.6 thay vì 1.56). Vậy rất mong các bác giỏi lisp chỉ bảo giúp em giải quyết vấn đề này với ạ. Em xin cảm ơn.
E là thành viên mới còn ngu ngơ về lisp. A có thể hướng dẫn e sữ dụng đoạn lisp này được ko ak. Thanks
<<
|
|
Filename: 192612_cal1.lsp
|
|
Tác giả: phamthanhbinh
Bài viết gốc: 280529
Tên lệnh: cpi |
lisp copy text tăng dần
Không can thiệp nội dung
(defun c:CPI (/ Block ent Numtext Blk Symbol sym ans pt1 pt2 gr code data NewObj...
>>
Không can thiệp nội dung
(defun c:CPI (/ Block ent Numtext Blk Symbol sym ans pt1 pt2 gr code data NewObj end)
;;; pBe 23 June 2012 ;;;
;;;http://forums.autode.../3507198/page/2 ;;;
(setvar 'cmdecho 0)
(prompt "\rSelect Block/Text:")
(cond
((and
(setq Block (ssget "_+.:S:L" '((0 . "INSERT,*TEXT"))))
(setq Block (ssname Block 0))
(setq NumText
(if
(and
(eq (cdr (assoc 0(entget Block)))"INSERT")
(setq Blk (member '(66 . 1)(entget Block)))
)
(cdr (assoc 1 (entget (entnext Block))))
(cdr (assoc 1 (entget Block)))
)
)
(progn
(if (not Symbol)(setq Symbol "+"))
(initget "+ -")
(setq Symbol
(cond ((getkword (strcat "\nChoose : <" Symbol ">: ")))
(Symbol))
)
(initget "Y N")
(setq ans (cond ( (getkword "\nPrefix <No>: ") ) ( "N" )))
)
(setq sym (eval (read symbol)))
(setq ent (vlax-ename->vla-object Block))
(setq end nil pt1 (vlax-get ent 'insertionpoint))
(setq NewObj (vla-copy ent))
(while (null end)
(while
(progn
(prompt "\rPick Next Point/Press / Right Click to Increase / Any key to Exit")
(setq gr (grread t 15 0)
code (car gr)
data (cadr gr)
)
(cond
((= 5 code)
(vlax-invoke NewObj 'Move pt1 (setq pt2 data))
(setq pt1 pt2))
((= 2 code)
(setq sym (cond
((= data 43) +)
((= data 45) -)
((= data 61) *)
((setq end T) (entdel (entlast)))))
nil)
((= 3 code)
(vlax-invoke NewObj 'Move pt1 (setq pt2 data))
(vla-put-textstring
(if (not Blk)
NewObj
(car (vlax-invoke
NewObj
'GetAttributes))
)
(progn
(setq NumText
(itoa (eval (sym (atoi Numtext) 1
))))
(if (and (< (strlen NumText) 2)
(eq ans "Y"))
(strcat "0" NumText)
Numtext)
)
)
(setq ent NewObj)
(setq NewObj (vla-copy ent))
nil)
((= 25 code)(setq NumText (itoa (1+ (atoi NumText)))))
)
)
)
)
)
)
)
(princ)
)
anh ketxu ơi, trong phần này anh giúp em là pick chuột phải để tăng nhưng sao em pick chuột phải nó không có tác dụng tăng mà nó cứ ì ra đấy nhỉ, pick chuột trái nó lại vẫn là số tăng tiếp theo của số cũ!
Hề hề hề,
Với gợi ý của bác Ket và suy nghĩ của mình thay vì click chuột phải nhiều lần để tăng giá trị bước nhảy thi mỗi lần click chuột phãi lisp sẽ yêu cầu nhập gia số, nếu có nhập gia số thì lần click chuột trái tiếp theo giá trị số sẽ được tăng lên bằng bước nhảy, còn nếu không nhập gia số thì lần click chuột trái tiếp theo sẽ chỉ tăng giá trị là 1. Như vậy nếu phải tăng bước nhảy lớn hơn 2 thì sẽ có lợi về thao tác click chuột. còn nếu bước nhảy là 2 thì sẽ bị chậm về thao tác nhập gia số.
Để làm như vậy bạn hãy thay đoạn code mà bác Ketxu bổ sung bằng đoạn code sau:
(( = 25 code) (setq gs (getint "\n Hay nhap gia so: "))
(setq NumText (itoa (eval (sym (atoi Numtext) (if gs (1- gs) 0)))))
)
Lưu lại file và test thử coi sao nhé.
<<
|
Tác giả: leemindjan
Bài viết gốc: 22277
Tên lệnh: 3 4 5 |
Cần gấp lisp tăng giá trị khi chọn
Bạn xem lisp dồn số hiệu bản vẽ ở đây: >>
(defun myerror (s)
(cond
((= s "quit / exit abort") (princ))
((/= s "Function cancelled") (princ (strcat "\nError: " s)))
)
(setvar "cmdecho" CMD) ; Restore saved modes
(setvar "osmode" OSM)
(setq *error* OLDERR) ; Restore old *error* handler
(princ)
)
(defun intro ()
(princ "\nCopyright by Nguyen Gia Dat (Datnggia@gmail.com - 0915169886)")
)
(defun bocchu (ss1 c)
(setq ob (entget (ssname ss1 c)))
(setq ts (assoc 1 ob))
(setq a (cdr ts))
)
(defun sothanhchu (num) (rtos num 2 2))
(defun connumint (num) (rtos num 2 0))
(defun thaychu (Ob newstr)
(setq txtstr (assoc 1 Ob))
(setq newstr (cons 1 newstr))
(entmod (subst newstr txtstr Ob))
)
(defun chonchu (dongnhac)
(prompt dongnhac)
(ssget
'((-4 . "<OR") (0 . "text") (0 . "mtext") (-4 . "OR>"))
)
)
(defun chon (str) (ssget '((cons (0 str)))))
(defun bamchon (st) (entget (car (entsel st))))
(defun bocdt (ss1 c) (entget (ssname ss1 c)))
;;; Sua nhieu text (cong tru gia tri thuc)
(defun c:3 ()
(command "undo" "mark")
(intro)
(setq ss1 (chonchu "\nChon text can cong them ...")
)
(if (= Ostr nil)
(setq Ostr "\nNhap gia tri tang them <>...: ")
)
(while (= ss1 nil)
(setq ss1 (chonchu "\nChon text can cong them ...")
)
)
(setq i 0
num2 (getreal Ostr)
sslen (sslength ss1)
)
(if (/= num2 nil)
(setq
numadd num2
)
)
(if (/= numadd nil)
(setq Ostr (strcat "\nNhap gia tri tang them <"
(rtos numadd 2 2)
"> : "
)
)
)
(while (<= i (1- sslen))
(setq num1 (atof (bocchu ss1 i))
)
(setq num (+ num1 numadd))
(setq ob (bocdt ss1 i))
;(if (< num 10)
; (setq st (strcat "0" (connumint num)))
(setq st (sothanhchu num))
; )
(thaychu ob st)
(princ)
(setq i (1+ i))
)
)
;;; Sua nhieu text (cong tru gia tri nguyen)
(defun c:4 ()
(intro)
(command "undo" "mark")
(setq ss1 (chonchu "\nChon text can cong them ...")
)
(if (= Ostr nil)
(setq Ostr "\nNhap gia tri tang them <>...: ")
)
(while (= ss1 nil)
(setq ss1 (chonchu "\nChon text can cong them ...")
)
)
(setq i 0
num2 (getint Ostr)
sslen (sslength ss1)
)
(if (/= num2 nil)
(setq
numadd num2
)
)
(if (/= numadd nil)
(setq Ostr (strcat "\nNhap gia tri tang them <"
(rtos numadd 2 0)
"> : "
)
)
)
(while (<= i (1- sslen))
(setq num1 (atof (bocchu ss1 i))
)
(setq num (+ num1 numadd))
(setq ob (bocdt ss1 i))
(if (< num 10)
(setq st (strcat "0" (connumint num)))
(setq st (connumint num))
)
(thaychu ob st)
(princ)
(setq i (1+ i))
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:5 ()
(intro)
(command "undo" "mark")
(setq ss1 (chonchu "\nChon text can cong them ...")
)
(if (= Ostr nil)
(setq Ostr "\nNhap gia tri tang them <>...: ")
)
(while (= ss1 nil)
(setq ss1 (chonchu "\nChon text can cong them ...")
)
)
(setq i 0
num2 (getreal Ostr)
sslen (sslength ss1)
)
(if (/= num2 nil)
(setq
numadd num2
)
)
(if (/= numadd nil)
(setq Ostr (strcat "\nNhap gia tri tang them <"
(rtos numadd 2 2)
"> : "
)
)
)
(while (<= i (1- sslen))
(setq num1 (atof (bocchu ss1 i))
)
(setq num (+ num1 numadd))
(setq ob (bocdt ss1 i))
(if (> num 0)
(setq st (strcat "+" (sothanhchu num)))
(setq st (sothanhchu num))
)
(thaychu ob st)
(princ)
(setq i (1+ i))
)
)
Lệnh "3": tăng giảm nhiều số dưới dạng số thực
Lệnh "4": tăng giảm các số nguyên (dạng số thứ tự)
Lện "5": tăng giảm các số nguyên có chứa dấu (dạng cao độ)
Hy vọng giúp ích cho bạn
Chết thật! trong lúc em post bài thì bác Hoanh đã kịp trả lời trước rồi. Lisp của mình có thể kết hợp với các biện pháp chọn lọc đối tượng text - sẽ đem lại hiệu quả nhanh hơn (Tất nhiên ko thể so sánh với bộ công cụ trên của bác Hoành :mellow:
Thanks các bác nhiều lắm.Mình đã làm được rồi.
<<
|
|
Filename: 22277_3_4_5.lsp
|
|
Tác giả: htqk9
Bài viết gốc: 49207
Tên lệnh: movenha |
lisp dựng phối cảnh nhà trong quy hoạch
Đợt vừa rồi viết được một lisp move nhà trong quy hoạch vào đúng địa hình.
Chia sẻ cùng mọi người:
(defun...
>>
Đợt vừa rồi viết được một lisp move nhà trong quy hoạch vào đúng địa hình.
Chia sẻ cùng mọi người:
(defun c:movenha()
(defun 2d(p)
(list (car p) (cadr p))
)
(defun timcao (p)
(setq ss1 (ssget "F" (list (2d p) (setq pf1 (2d (polar p (* 0.0 pi) 80000.0)))) '((0 . "LWPOLYLINE")))
ss2 (ssget "F" (list (2d p) (setq pf2 (2d (polar p (* 0.5 pi) 80000.0)))) '((0 . "LWPOLYLINE")))
ss3 (ssget "F" (list (2d p) (setq pf3 (2d (polar p (* 1.0 pi) 80000.0)))) '((0 . "LWPOLYLINE")))
ss4 (ssget "F" (list (2d p) (setq pf4 (2d (polar p (* 1.5 pi) 80000.0)))) '((0 . "LWPOLYLINE")))
z1 10000.0
z2 10000.0
z3 10000.0
z4 10000.0
)
(setq test false)
(if test (progn
(command ".line" p pf1 "")
(command ".line" p pf2 "")
(command ".line" p pf3 "")
(command ".line" p pf4 ""))
)
(if ss1
(setq z1 (cdr (assoc 38 (entget (ssname ss1 0)))))
)
(if ss2
(setq z2 (cdr (assoc 38 (entget (ssname ss2 0)))))
)
(if ss3
(setq z3 (cdr (assoc 38 (entget (ssname ss3 0)))))
)
(if ss4
(setq z4 (cdr (assoc 38 (entget (ssname ss4 0)))))
)
(if (not (or ss1 ss2 ss3 ss4)) (princ "\nXay ra loi"))
(min z1 z2 z3 z4)
)
(defun movz (ent z)
(command ".move" ent "" (list 0.0 0.0 0.0) (list 0.0 0.0 z))
)
(defun moveone(ent)
(setq
entver (entnext ent)
tt (entget entver)
p (cdr (assoc 10 tt))
)
(movz ent (timcao p))
)
(init)
(setq ss (ssget '((0 . "POLYLINE"))))
(luuos)
(setvar "OSMODE" 0)
(sudung moveone ss)
(traos)
(done)
)
dùng lệnh MOVENHA để sử dụng.
Đối tượng nhà phải là Mesh.
Đối tượng đường đồng mức phải là LWPolyline đã được nâng
Mặt bằng
Mặt đứng khi chưa nâng
Mặt đứng khi đã nâng
Phối cảnh khi đã nâng
Pro thật tuyệt vời! thank u so much!
<<
|
|
Filename: 49207_movenha.lsp
|
|
Tác giả: Hoangvulandscape
Bài viết gốc: 153518
Tên lệnh: tkh1 |
Lisp thống kê diện tích Hatch theo Layer
Bạn thử xem.
(defun c:tkh1 (/ lst msp pt ss lay ar txtsiz pt)
(if (> (atof (substr (getvar "ACADVER") 1 4)) 16.1)
(progn
...
>>
Bạn thử xem.
(defun c:tkh1 (/ lst msp pt ss lay ar txtsiz pt)
(if (> (atof (substr (getvar "ACADVER") 1 4)) 16.1)
(progn
(vl-load-com)
(acet-sysvar-set (list "cmdecho" 0))
(grtext -1 "S\U+01A1n T\U+00F9ng' Lisp")
(Princ "\nCh\U+1ECDn c\U+00E1c \U+0111\U+1ED1i t\U+01B0\U+1EE3ng Hatch \U+0111\U+1EC3 t\U+00EDnh di\U+1EC7n t\U+00EDch : ")
(if (setq ss (ssget(list (cons 0 "HATCH"))))
(progn
(foreach e (mapcar 'vlax-ename->vla-object (st-ss->ent ss))
(setq lay (vlax-get-property e 'Layer))
(if (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-get-area (list e))))
(setq ar (* 0.000001 (vlax-get-property e 'Area)))
(progn
(setq ar 0)(princ (strcat "\nC\U+00F3 Hatch thu\U+1ED9c layer " lay " kh\U+00F4ng t\U+00EDnh \U+0111\U+01B0\U+1EE3c di\U+1EC7n t\U+00EDch.\n\U+0110\U+00E3 highlight v\U+00E0 t\U+00EDnh di\U+1EC7n t\U+00EDch b\U+1EB1ng 0"))
(redraw (vlax-vla-object->ename e) 3)
)
)
(if (not (assoc lay lst))
(setq lst (cons (cons lay ar) lst))
(setq lst (subst (cons lay (+ ar (cdr (assoc lay lst))))
(assoc lay lst) lst))))
(setq lst (vl-sort lst '(lambda (x y) (< (car x) (car y))))
txtsiz (* (getvar "dimtxt")(getvar "dimscale"))
msp (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))) i -1)
(while (setq e (nth (setq i (1+ i)) lst))
(while (not(wcmatch(cdadr
(entget (setq ent (car(entsel (strcat "\n\U+0110i\U+1EC3m Text ghi ch\U+00FA t\U+1ED5ng di\U+1EC7n t\U+00EDch Hatch thu\U+1ED9c layer " (car e))))))) "*TEXT"))
(setq ent (car(entsel (strcat "\n\U+0110i\U+1EC3m Text ghi ch\U+00FA t\U+1ED5ng di\U+1EC7n t\U+00EDch Hatch thu\U+1ED9c layer " (car e)))))
)
(vla-put-textstring (vlax-ename->vla-object ent) (strcat (car e) " : " (rtos (cdr e) 2 2) "m2"))
)
(princ "\n\U+0110\U+00E3 th\U+1EF1c hi\U+1EC7n xong !")
)
(alert "Kh\U+00F4ng c\U+00F3 Hatch n\U+00E0o \U+0111\U+01B0\U+1EE3c ch\U+1ECDn !"))
)
(alert "Phi\U+00EAn b\U+1EA3n CAD c\U+1EE7a b\U+1EA1n kh\U+00F4ng h\U+1ED7 tr\U+1EE3 t\U+00EDnh di\U+1EC7n t\U+00EDch Hatch !")
)
(acet-sysvar-restore)(princ))
Bạn ơi, sao nó chỉ bảo chọn Hatch cần tính rồi im ln, ko ra tiếp yêu cầu chọn text nữa vậy bạn? Nhờ bạn kiểm tra giùm. Thanks
<<
|
|
Filename: 153518_tkh1.lsp
|
|
Tác giả: duy782006
Bài viết gốc: 6061
Tên lệnh: test reset |
code giới hạn thời gian sử dụng File lisp
Với file lisp thì rất khó để làm được điều này. Bởi người biết sử dụng lisp sẽ vô hiệu hoá ngay nếu như đọc được mã lisp. Tuy nhiên, có thể làm được... >>
Với file lisp thì rất khó để làm được điều này. Bởi người biết sử dụng lisp sẽ vô hiệu hoá ngay nếu như đọc được mã lisp. Tuy nhiên, có thể làm được điều này với 1 file VLX đã được mã hoá. Cách làm thông thường như sau: Ghi thông tin các lần sử dụng lệnh vào 1 vị trí trên registry, hoặc vào file config của AutoCAD. Sau đó, đọc các thông tin này để có hành động phù hợp.
Sau đây là 1 ví dụ đơn giản:
(defun c:TEST()
;;; Doc gia tri
(setq tmp (getcfg "AppData/CADViet/Count")
sl (cond
((or (not tmp) (= tmp "")) "5")
(t tmp)
)
)
;;; Kiem tra va thong bao
(if (/= sl "0")
(progn
;;; Thuc thi ma lenh
(princ (strcat "\nBan con " sl " lan su dung nua"))
;;; Luu gia tri
(setcfg "AppData/CADViet/Count" (itoa (1- (atoi sl))))
)
(princ "\nBan da het han su dung!")
)
(princ)
)
(defun c:RESET()
;;; Reset lai gia tri
(setcfg "AppData/CADViet/Count" "")
(princ)
)
Lệnh TEST để xác định số lần thực thi. Chỉ thực thi lệnh được 5 lần. Không quan trọng ngày tháng, không quan trọng số lần sử dụng ACAD, cứ dùng lệnh TEST quá 5 lần là hết hạn.
Lệnh RESET để khởi tạo lại giá trị.
Tất nhiên, ví dụ trên là 1 cái khoá đơn giản chỉ khoá được người ngay chứ không khoá được kẻ gian.
Cad 14 thi có file acad14.cfg còn các cad đời mới thì hông tìm thấy file này là sao hở bác!
Bác chỉ cho cách ghi và đọc thông tin vào registry luôn đi!
<<
|
|
Filename: 6061_test_reset.lsp
|
|
Tác giả: Bee
Bài viết gốc: 415983
Tên lệnh: at |
Cộng, Trừ, Nhân, Chia Hàng Loạt Att Cùng Tagname Trong Block Với Cùng 1 Số
Em có tham khảo lisp đánh số thứ tự bản vẽ để viết Cộng, trừ, nhân, chia hàng loạt Att cùng tagName trong Block với 1 số, nhưng...
>>
Em có tham khảo lisp đánh số thứ tự bản vẽ để viết Cộng, trừ, nhân, chia hàng loạt Att cùng tagName trong Block với 1 số, nhưng khả năng có hạn nên chưa thể viết được. Mong các bác giúp em
Lisp đánh sốt thứ tự Block
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/index.php?showtopic=38369&st=0&p=139366&hl=esport113&fromsearch=1entry139366
(defun c:stt (/ ans ins lst blkName tagName ent);Block Order
;; By : Gia_Bach, www.CadViet.com ;;
(vl-load-com)
(while (not (and
(setq ent (car (nentsel "\n Chon thuoc tinh can danh so: ")))
(if ent (eq (cdr (assoc 0 (entget ent))) "ATTRIB") ) ) )
(princ "\n Ban chon nham roi! ") )
(setq blkName (cdr (assoc 2 (entget (cdr (assoc 330 (entget ent))))))
tagName (cdr (assoc 2 (entget ent))) )
(initget 1 "Yes No")
(setq x (getkword "\nBan co muon nhap Tien to ? (Yes or No) "))
(if (= x "Yes")
(progn
(or prefix (setq prefix "KC-"))
(setq ans (getstring t (strcat "\n Nhap tien to <<"prefix ">> :")))
(if (/= ans "")(setq prefix ans)) )
(setq prefix ""))
(or stt (setq stt 1))
(initget 6)
(setq ans (getint (strcat "\n Nhap so bat dau <<"(itoa stt) ">> :")))
(if ans (setq stt ans))
(if (> stt 9)
(setq str (strcat prefix (itoa stt)))
(setq str (strcat prefix "0" (itoa stt))) )
(princ "\nChon Khung ten can danh so thu tu :")
(if (ssget(list (cons 0 "INSERT")(cons 66 1)(cons 2 blkName)))
(progn
(vlax-for e (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(setq ins (vlax-safearray->list (variant-value (vla-get-InsertionPoint e)))
lst (cons (list e ins)lst)) )
(setq lst (vl-sort lst '(lambda (x y) (or (> (cadr (cadr x)) (cadr (cadr y)))
(and (< (car (cadr x)) (car (cadr y)))
(= (cadr (cadr x)) (cadr (cadr y))) ) ) ) ))
(foreach e (append (mapcar 'car lst) )
(foreach Att (vlax-invoke e 'GetAttributes)
(if (= (vla-get-TagString att) tagName)
(vla-put-TextString att str) ))
(setq stt (+ 1 stt))
(if (> stt 9)
(setq str (strcat prefix (itoa stt)))
(setq str (strcat prefix "0" (itoa stt))) ) ) ) )
(princ))
Lisp cộng trừ nhân chia ATT với 1 số
(defun c:at (/ goc cal e1 en numb Kieudoc)
(setq Kieudoc (cond (Kieudoc) ("Cong")))
(initget "1 2 3 4")
(setq Kieudoc (cond ((getkword (strcat "\Chon kieu can text <" Kieudoc ">"))) (Kieudoc)))
(setq goc1 (car (nentsel "\n Chon ATT can tinh")))
(redraw goc1 3)
(setq goc (atof (cdr (assoc 1 (entget goc1 )))))
(setq numb (getreal "\nNhap so Or bo qua de chon so: "))
(if (or (= numb nil) (= numb ""))
(setq numb (atof (cdr (assoc 1 (entget (car (entsel "\nChon so : "))))))))
(cond
((eq Kieudoc "1") (setq goc (+ goc numb)))
((eq Kieudoc "2") (setq goc (- goc numb)))
((eq Kieudoc "3") (setq goc (* goc numb)))
((eq Kieudoc "4") (setq goc (/ goc numb))))
(entmod (subst (cons 1 (rtos goc 2 2)) (assoc 1 (entget goc1)) (entget goc1)))
(entupd goc1))
Lisp chạy cho 1 att rồi còn gì.! Chạy nhiều thì cứ enter tiếp tục thoai. ^_^
<<
|
Tác giả: luc_xd
Bài viết gốc: 388562
Tên lệnh: vmb |
Nhờ Viết Lisp: Mặt Bích Trong Kết Cấu Thép
Thử xem sao: Lệnh là VMB
>>
Thử xem sao: Lệnh là VMB
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(Defun duy:xd_listngngancach<kytu (chuoi kytu / chuoi kytu ckq)
(setq lkq nil)
(setq bdd 1)
(setq b 1)
(setq l (fix (strlen chuoi)))
(repeat l
(setq a (substr chuoi b 1))
(cond
((= a kytu)
(setq dkt (substr chuoi bdd (- b bdd)))
(setq lkq (append lkq (list dkt)))
(setq bdd (+ b 1))
)
)
(setq b (+ b 1))
)
(setq dkt (substr chuoi bdd (+ (- l bdd) 1)))
(setq lkq (append lkq (list dkt)))
lkq)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:vmb ()
(setq matbich (getstring "\nNhap kich thuoc mat bich <Cao * Rong>"))
(setq daimatbich (atoi (car (duy:xd_listngngancach<kytu matbich "*"))))
(setq rongmatbich (atoi (cadr (duy:xd_listngngancach<kytu matbich "*"))))
(setq diemve (getpoint "Diem tren ben trai mat bich"))
(command ".RECTANG" "_non" diemve "_non" (list (+ (car diemve) rongmatbich) (- (cadr diemve) daimatbich)) )
(or canhngang (setq canhngang 100))
(setq canhngang (cond ((getreal (strcat "\nKhoang cach ngang giua 2 cot bolon < " (rtos canhngang 2 2) " >:")))(canhngang)))
(setq bulong (getstring "\nNhap khoang cach doc tinh tu tren xuong <khoang1 + khoang2 +...+ khoangn"))
(setq khoangbulong (duy:xd_listngngancach<kytu bulong "+"))
(setq khoangvebulong 0.0)
(foreach khoangbulonghh khoangbulong
(setq khoangvebulong (+ khoangvebulong (atoi khoangbulonghh)))
(command ".insert" "BU LONG" "_non" (list (+ (+ (car diemve) (/ rongmatbich 2)) (/ canhngang 2)) (- (cadr diemve) khoangvebulong)) 0.01 0.01 0)
(command ".insert" "BU LONG" "_non" (list (- (+ (car diemve) (/ rongmatbich 2)) (/ canhngang 2)) (- (cadr diemve) khoangvebulong)) 0.01 0.01 0)
)
(princ)
)
Thanks a PHẠM QUỐC DUY rất nhiều, Lisp này rất đúng ý của e. Nêu được a có thể gom luôn nhiều khoảng cách giống nhau thành 1 bước. Ví dụ 3 khoảng 100 thì nhập là 3*100 . Được voi đòi 2 Bà Trưng :lol:
<<
|
Tác giả: hugo007
Bài viết gốc: 166729
Tên lệnh: test |
Lisp chia khoảng cách giữa 2 đối tượng là donut
:) Mình dần dần thấy yêu cầu của bạn giồng copyarray rồi đó ^^ Nhưng thôi, cố thì cố cho trót, lần sau hi vọng bạn nói đầy đủ yêu...
>>
:) Mình dần dần thấy yêu cầu của bạn giồng copyarray rồi đó ^^ Nhưng thôi, cố thì cố cho trót, lần sau hi vọng bạn nói đầy đủ yêu cầu luôn từ đầu :
(defun c:test (/ lstVar lstVal dump ST:Geom-Center ss ent1 ent2 p1 p2 i n dis)
(grtext -1 "Free lisp from CadViet @Ketxu")
(setq lstVar '("osmode" "cmdecho")
lstVal (mapcar 'getvar lstVar)
dump (mapcar 'setvar lstVar '(0 0))
)
(defun ST:Geom-Center (ent / p1 p2)
(vla-getboundingbox (vlax-ename->vla-object ent) 'p1 'p2)
(mapcar '(lambda (a B) (* 0.5 (+ a B)))
(vlax-safearray->list p1) (vlax-safearray->list p2))
)
(or ans (setq ans "D"))
(setq ss (ssget (list (cons 0 "LWPOLYLINE")(cons 90 2)(cons 70 1))))
(initget "A D")
(setq ans (cond ((getkword (strcat "\nDivied (D) / Array (A) < " ans " > : ") ))(ans)))
(if (= (sslength ss) 2)
(progn
(setq ent1 (ssname ss 0) ent2 (ssname ss 1)
P1 (ST:Geom-Center ent1)
P2 (ST:Geom-Center ent2)
ang (angle P1 P2)
i 0
)
(cond ((wcmatch ans "D") (setq n (1- (setq number (getint "\nNumber Divide :"))) dis (/ (distance P1 P2) number)))
(T (setq dis (getreal "\nLeng to array : ") n ( fix (+ (/ (distance P1 P2) dis) 1e-8))))
)
(repeat n
(command ".copy" ent1 "" P1 (polar P1 ang (* (setq i (1+ i)) dis)))
)
)(Princ "Wrong! Do again!")
)
)
!
P/S : giờ mới đọc lại yêu cầu, các donut tạo ra chưa nằm giữa 2 donut, các bác khác sửa giúp e với hén, e phải đi khổ sai đây :wacko:
Cảm ơn bác nhiều,lisp quá tốt,khi chọn DIVIDE tạo donut nằm tại các điểm chia đều giữa 2 donut ,ARRAY thì cách khoảng theo yêu cầu nhập vào,đâu cần donut nằm giữa 2 donut bác.1 lần nữa cảm ơn bác nhiều.
<<
|
|
Filename: 166729_test.lsp
|
|
Tác giả: tieu_ngu_nhi_43
Bài viết gốc: 81938
Tên lệnh: mmo |
Viết lisp theo yêu cầu [phần 2]
Bổ sung phần Highlight đối tuợng đuợc chọn và dùng getdist để nhập kh/cách. Thanks to duy782006.
(defun c:mmo(/ ang dis pt ss)
(defun *error*...
>>
Bổ sung phần Highlight đối tuợng đuợc chọn và dùng getdist để nhập kh/cách. Thanks to duy782006.
(defun c:mmo(/ ang dis pt ss)
(defun *error* (msg)
(if ss (ssredraw ss 4))
(if (not(wcmatch (strcase msg) "*BREAK,*EXIT*,*CANCEL*"))
(princ (strcat "\n** Error: " msg " **")))
(princ))
(defun ssredraw (ss mode / i ename)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(redraw (ssname ss i) mode)
)
)
(or *dis* (setq *dis* 200))
(or *ang* (setq *ang* 0))
(princ "\nChon doi tuong muon di chuyen :")
(while (setq ss (ssget))
(ssredraw ss 3)
(setq ang (getangle (strcat "\nNhap goc muon di chuyen <" (angtos *ang*) ">: ")))
(if ang (setq *ang* ang))
(initget 2)
(setq dis (getdist (strcat "\nNhap khoang cach <" (rtos *dis*) ">: ")))
(if dis (setq *dis* dis))
(ssredraw ss 4)
(command "move" ss "" (setq pt (getvar "lastpoint")) (polar pt *ang* *dis*))
(princ "\nChon doi tuong muon di chuyen :")
)
(princ)
)
Thanks bác Gia Bach rất là nhiều!!!!
Cái lisp này rất là đúngvơui ý của em.
Lisp này có thể bỏ không cần câu lệnh nhập góc cần di chuyển ko vậy bác.
Nhân tiện bác có thể viết thêm lisp như trên nhưng với lệnh copy ko ạ?
Cũng như lệnh offset đó. Không cần phải nhập lại khoảng cách.
Cảm ơn bác lần nữa. Chúc bác sức khỏe!!!
<<
|