Info | File |
Tác giả: thanhduan2407
Bài viết gốc: 311404
Tên lệnh: xlt |
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)
Code dưới viết khác của thanhduan. Trong code có hạn chế số lần lặp (để đẩy nhanh tốc độ)
Dạ, cái anh Tue_NV chưa được ạ. Nó xóa nhiều thứ quá và vẫn bỏ xót đối tượng.
Cái Code em viết cũng tương đối nhưng cũng xóa không triệt để.
Có gì mong các anh xem và sửa...
>> Code dưới viết khác của thanhduan. Trong code có hạn chế số lần lặp (để đẩy nhanh tốc độ)
Dạ, cái anh Tue_NV chưa được ạ. Nó xóa nhiều thứ quá và vẫn bỏ xót đối tượng.
Cái Code em viết cũng tương đối nhưng cũng xóa không triệt để.
Có gì mong các anh xem và sửa giúp.
Code em viết đây ạ
(vl-load-com)
(defun c:XLT ( / ss Lts_EnameLine Lts_KC_Ename Lts_KC_Ename_Sort Lts_Ename Lts_Line_OK );;;XOA LINE TRUNG
(setvar "CMDECHO" 0)
(progn
(setq ss (ssget (list (cons 0 "LINE"))))
(setq Lts_EnameLine (vl-remove nil (mapcar '(lambda(x) (if (= (acet-dxf 0 (entget x)) "LINE") x nil)) (acet-ss-to-list ss))))
(setq Lts_KC_Ename (mapcar '(lambda (x) (cons (distance (acet-dxf 10 (entget x)) (acet-dxf 11 (entget x))) x)) Lts_EnameLine))
(setq Lts_KC_Ename_Sort (vl-sort Lts_KC_Ename '(lambda(e1 e2) (< (car e1) (car e2)))))
(setq Lts_Ename (mapcar '(lambda (x) (cdr x)) Lts_KC_Ename_Sort))
)
(setq Lts_Obj (TD:GetLineDup Lts_Ename ))
(setq Lts2 (LM:ListDifference Lts_Ename Lts_Obj ))
(foreach e Lts2
(entdel e)
)
(alert (strcat "\nDa xoa: " (rtos (length lts2) 2 0) " doi tuong"))
(princ )
)
(defun GetPnt (Ma x / P1)
(setq P1 (acet-dxf Ma (entget x)))
(setq P2 (list (car P1) (cadr P1)))
P2
)
;;;;;LOC RA NHUNG DOI TUONG LINE NAM TREN NHAU
(defun TD:GetLineDup (lst / lst1)
(foreach x lst
(if (not (member x lst1))
(setq lst1 (append lst1 (list x)))
)
(Progn
(foreach y lst1
(if (and (equal (+ (distance (GetPnt 10 y) (GetPnt 10 x)) (distance (GetPnt 10 y) (GetPnt 11 x))) (distance (GetPnt 10 x) (GetPnt 11 x)) 0.05)
(equal (+ (distance (GetPnt 11 y) (GetPnt 10 x)) (distance (GetPnt 11 y) (GetPnt 11 x))) (distance (GetPnt 10 x) (GetPnt 11 x)) 0.05)
(equal (angle (GetPnt 10 x) (GetPnt 10 y)) (angle (GetPnt 10 x) (GetPnt 11 x)) 0.0001)
(equal (angle (GetPnt 10 x) (GetPnt 11 y)) (angle (GetPnt 10 x) (GetPnt 11 x)) 0.0001)
)
(setq lst1 (vl-remove y lst1))
)
)
(setq lst1 (append lst1 (list x)) )
)
)
lst1
)
(defun LM:ListDifference ( l1 l2 )
(vl-remove-if '(lambda ( x ) (member x l2)) l1)
)
File test: http://www.cadviet.com/upfiles/3/36665_test.dwg
<<
|
Tác giả: thanhduan2407
Bài viết gốc: 311448
Tên lệnh: xlt |
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)
(defun c:XLT( / ss Lts_EnameLine Lts_KC_Ename Lts_KC_Ename_Sort Lts_Ename Lts_Line_OK );;;XOA LINE TRUNG
(setvar "CMDECHO" 0)
(setq ss (ssget (list (cons 0 "LINE"))))
(setq Lts_EnameLine (vl-remove nil (mapcar '(lambda(x) (if (= (acet-dxf 0 (entget x)) "LINE") x nil)) (acet-ss-to-list ss))))
(setq Lts_KC_Ename (mapcar '(lambda (x) (cons (distance (acet-dxf 10 (entget x)) (acet-dxf 11 (entget x))) x)) Lts_EnameLine))
(setq Lts_KC_Ename_Sort (vl-sort...
>>
(defun c:XLT( / ss Lts_EnameLine Lts_KC_Ename Lts_KC_Ename_Sort Lts_Ename Lts_Line_OK );;;XOA LINE TRUNG
(setvar "CMDECHO" 0)
(setq ss (ssget (list (cons 0 "LINE"))))
(setq Lts_EnameLine (vl-remove nil (mapcar '(lambda(x) (if (= (acet-dxf 0 (entget x)) "LINE") x nil)) (acet-ss-to-list ss))))
(setq Lts_KC_Ename (mapcar '(lambda (x) (cons (distance (acet-dxf 10 (entget x)) (acet-dxf 11 (entget x))) x)) Lts_EnameLine))
(setq Lts_KC_Ename_Sort (vl-sort Lts_KC_Ename '(lambda(e1 e2) (> (car e1) (car e2)))))
(setq Lts_Ename (mapcar '(lambda (x) (cdr x)) Lts_KC_Ename_Sort))
(setq Lts_Line_OK (TD:Remove-Obj-duplicates Lts_Ename))
(alert "Xong!")
(princ)
)
(defun GetPnt (Ma x /)
(acet-dxf Ma (entget x))
)
(defun GetLineDup (lst / lst1)
(setq lst1 (list (car lst)))
(while lst
(setq lst (cdr lst)
x (last lst1))
(foreach y lst
(if (and
(equal (+ (distance (GetPnt 10 x) (GetPnt 10 y)) (distance (GetPnt 10 y) (GetPnt 11 x))) (distance (GetPnt 10 x) (GetPnt 11 x)) 0.000001)
(equal (+ (distance (GetPnt 10 x) (GetPnt 11 y)) (distance (GetPnt 11 y) (GetPnt 11 x))) (distance (GetPnt 10 x) (GetPnt 11 x)) 0.000001)
)
(setq lst (vl-remove y lst))
)
)
(setq lst1 (append lst1 (list (car lst))))
)
)
(defun LM:ListDifference ( l1 l2 )
(vl-remove-if '(lambda ( x ) (member x l2)) l1)
)
(defun LM:RemoveOnce ( l1 l2 )
(if l1
(if (equal (car l1) l2)
(LM:RemoveOnce (cdr l1) l2)
(cons (car l1) (LM:RemoveOnce (cdr l1) l2))
)
)
)
(defun TD:Remove-Obj-duplicates (ss_list / Lts1 Lts2 )
(vl-load-com)
(setq Lts1 (GetLineDup ss_list ))
(setq Lts2 (LM:ListDifference ss_list Lts1))
(setq Lts3 (LM:RemoveOnce Lts1 ss_list))
(foreach e Lts2
(entdel e)
)
Lts3
)
Cái này thì ổn rồi anh ạ. Hii
<<
|
Tác giả: ketxu
Bài viết gốc: 110102
Tên lệnh: ffs |
Cùng nhau học LISP
Vấn đề đường tròn e cũng giải quyết tạm thế này..Còn những vấn đề kia vẫn vướng.Không những thế còn thêm 1 vấn đề là :e muoốn chọn nhiều pl chứ không phải chỉ thực hiện 1 lần.mong các bác giúp đỡ
|
Tác giả: ketxu
Bài viết gốc: 108526
Tên lệnh: recc |
Viết lisp theo yêu cầu [phần 2]
Vấn đề của mình là tạo HCN,sau đó "cầm" nó để pick vào các điểm tâm một cách trực quan,gần gần giống như copy vậy. code mình mới viết được như ở dưới.Nhưng bị vướng ở chỗ mình đã tạo điểm tâm rõ ràng rồi,nhưng không hiểu sao nếu user nhập vào bằng bàn phím chiều dài cạnh,thì Tâm lại là trung điểm 1 cạnh >>
Vấn đề của mình là tạo HCN,sau đó "cầm" nó để pick vào các điểm tâm một cách trực quan,gần gần giống như copy vậy. code mình mới viết được như ở dưới.Nhưng bị vướng ở chỗ mình đã tạo điểm tâm rõ ràng rồi,nhưng không hiểu sao nếu user nhập vào bằng bàn phím chiều dài cạnh,thì Tâm lại là trung điểm 1 cạnh Còn nếu user input chiều dài cạnh bằng cách pick điểm thì mới đúng ý mình.Thêm 1 ý nữa,lệnh copy chỉ thực hiện 1 lần,kể cả khi đã thêm dòng multiple trước khi thực hiện lệnh ,không đúng ý mình..Mọi người xem code giùm mình với.Vạn sự khởi đầu nan ( Cám ơn mọi người
<<
|
Filename: 108526_recc.lsp
|
|
Tác giả: hiepttr
Bài viết gốc: 311508
Tên lệnh: ll |
Nhờ các bác 1 lisp
Hồi chiều bận tí việc, giờ mới "trả bài" cho bạn đc đây
Mình ở xa, vui tay thì ấn like là đc rồi :D mà chưa thích thì hãy chỉ ném nhẹ thôi nhé ^^
Cũng là 1 cách để mình học bài mà :D :D :D
p/s: Bạn thích pick chọn hay quét chọn là tùy bạn
Mình lấy sau phẩy 3 số thập phân
Nếu là line 3d => thì chỉ nhận đc length 2d
>> Hồi chiều bận tí việc, giờ mới "trả bài" cho bạn đc đây
Mình ở xa, vui tay thì ấn like là đc rồi :D mà chưa thích thì hãy chỉ ném nhẹ thôi nhé ^^
Cũng là 1 cách để mình học bài mà :D :D :D
p/s: Bạn thích pick chọn hay quét chọn là tùy bạn
Mình lấy sau phẩy 3 số thập phân
Nếu là line 3d => thì chỉ nhận đc length 2d
;;;Lisp xuat chieu dai cac LINE
(defun c:LL(/ ss i ename info len lst fn pw)
;length line
(prompt "\nChon doi tuong *** chu y chi LINE duoc nhan ***")
(setq ss (ssget '((0 . "LINE")))
i -1)
(while ss
(progn
(repeat (sslength ss)
(setq ename (ssname ss (setq i (1+ i)))
info (entget ename)
len (distance (2d_dxf info 10) (2d_dxf info 11))
lst (append lst (list (list (+ i 1) len)))
)
) ;repeat
(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
(setq pw (open fn "w"))
(write-line "TT,Length" pw)
(foreach elem lst
(write-line (strcat (itoa(car elem)) "," (rtos (cadr elem) 2 3)) pw))
(close pw)
(princ)
) ;progn
)
)
;========================================================================
(defun 2d_dxf(info pt_code)
(list (cadr (assoc pt_code info)) (caddr (assoc pt_code info)) 0))
<<
|
Tác giả: nhoclangbat
Bài viết gốc: 311482
Tên lệnh: dkk |
nhờ viết giúp lips vẽ ống
_ ^^, vế sau nhoc ko hỉu chọn tâm ống làm gì, và bạn mún ghi kt thước = text hay dim
- nhoc quỡn viết đại đc vậy thui ^^
(defun c:dkk (/ w pt1 pt2 pt3 pt4 pt5 pt6 goc goc90 h)
(setvar "cmdecho" 0)
(defun RTD (a) (* 180 (/ a PI)))
(setq w (getreal "\ndo rong ong:"))
(setq h (getreal "\nhight text:"))
(setq pt1 (getpoint "\nchon diem dau ong:")
pt2 (getpoint pt1 "\nchon diem cuoi ong:"))
(setq goc (angle pt1 pt2)...
>> _ ^^, vế sau nhoc ko hỉu chọn tâm ống làm gì, và bạn mún ghi kt thước = text hay dim
- nhoc quỡn viết đại đc vậy thui ^^
(defun c:dkk (/ w pt1 pt2 pt3 pt4 pt5 pt6 goc goc90 h)
(setvar "cmdecho" 0)
(defun RTD (a) (* 180 (/ a PI)))
(setq w (getreal "\ndo rong ong:"))
(setq h (getreal "\nhight text:"))
(setq pt1 (getpoint "\nchon diem dau ong:")
pt2 (getpoint pt1 "\nchon diem cuoi ong:"))
(setq goc (angle pt1 pt2) goc90 (+ goc (/ pi 2)))
(setq pt3 (polar pt1 goc90 (* w 0.5))
pt4 (polar pt2 goc90 (* w 0.5)))
(command ".Mline" "s" w pt3 pt4 "")
(setq so (distance pt3 pt4)
pt5 (polar pt3 goc (/ so 2.0))
pt6 (polar pt5 goc90 (+ w 0.25)))
(command ".text" "M" pt6 h (rtd goc) (strcat "L = " (rtos so 2 2)))
(setvar "cmdecho" 1)
)
<<
|
Tác giả: ketxu
Bài viết gốc: 311805
Tên lệnh: lenfield |
nhờ kết hợp 2 lisp
Nói chung không có ý tranh luận làm gì, đơn giản là thấy field khó xài hơn reactor nên dùng reactor.
Nếu có ai rành về field và lisp thì làm thử bài toán trên để tôi được mở rộng tầm mắt.
Search nhẹ cái ra ngay này Tot77, ket post luôn code nhé ^^
>> Nói chung không có ý tranh luận làm gì, đơn giản là thấy field khó xài hơn reactor nên dùng reactor.
Nếu có ai rành về field và lisp thì làm thử bài toán trên để tôi được mở rộng tầm mắt.
Search nhẹ cái ra ngay này Tot77, ket post luôn code nhé ^^
;;--------------------=={ Length Field }==--------------------;;
;; ;;
;; Creates an MText Field referencing the sum of the lengths ;;
;; of selected objects. ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
(defun c:LenField ( / acdoc acspc format pt ss )
(setq format "%lu6%qf1") ;; Field Formatting
(setq acdoc (vla-get-activedocument (vlax-get-acad-object))
acspc (vlax-get-property acdoc (if (= 1 (getvar 'CVPORT)) 'Paperspace 'Modelspace))
)
(if
(and
(ssget '((0 . "LINE,*POLYLINE")))
(setq pt (getpoint "\nPick Point for Field: "))
)
(
(lambda ( ss fld )
(vlax-for obj ss
(setq fld
(strcat fld "%<\\AcObjProp Object(%<\\_ObjId "
(LM:GetObjectID acdoc obj) ">%).Length>% + "
)
)
)
(vla-addMText acspc (vlax-3D-point (trans pt 1 0)) 0.
(setq fld
(strcat
(substr fld 1
(- (strlen fld) (if (< 1 (vla-get-Count ss)) 3 5))
)
" \\f \"" format "\">%"
)
)
)
(vla-delete ss)
)
(setq ss (vla-get-ActiveSelectionSet acdoc))
(if (< 1 (vla-get-Count ss)) "%<\\AcExpr " "")
)
)
(princ)
)
;;-------------------=={ Get ObjectID }==---------------------;;
;; ;;
;; Returns the ObjectID string for the supplied VLA-Object ;;
;;------------------------------------------------------------;;
;; Author: Lee Mac, Copyright © 2011 - www.lee-mac.com ;;
;;------------------------------------------------------------;;
;; Arguments: ;;
;; doc - VLA Document Object (req'd for 64-bit systems) ;;
;; obj - VLA Object to query ;;
;;------------------------------------------------------------;;
;; Returns: ObjectID string for VLA-Object ;;
;;------------------------------------------------------------;;
(defun LM:GetObjectID ( doc obj )
(if (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
(vlax-invoke-method (vla-get-Utility doc) 'GetObjectIdString obj :vlax-false)
(itoa (vla-get-Objectid obj))
)
)
<<
|
Filename: 311805_lenfield.lsp
|
|
Tác giả: nhoclangbat
Bài viết gốc: 227573
Tên lệnh: kk kk1 kk2 kk3 kk4 |
Bài tập chương 4
anh Ket nhoc xin nộp bài lần đầu chắc sẽ có lần sau
;(command "-layer" "m" "hatch" "c" 3 "" "L" "Continuous" "" "LWeight" 0.15 "" "")
;(command "-layer" "m" "text" "c" 2 "" "L" "Continuous" "" "LWeight" 0.13 "" "")
;(command "-layer" "m" "dim" "c" 1 "" "L" "Continuous" "" "LWeight" 0.09 "" "")
(defun c:kk...
>> anh Ket nhoc xin nộp bài lần đầu chắc sẽ có lần sau
;(command "-layer" "m" "hatch" "c" 3 "" "L" "Continuous" "" "LWeight" 0.15 "" "")
;(command "-layer" "m" "text" "c" 2 "" "L" "Continuous" "" "LWeight" 0.13 "" "")
;(command "-layer" "m" "dim" "c" 1 "" "L" "Continuous" "" "LWeight" 0.09 "" "")
(defun c:kk ()
(command "-layer" "m" "hatch" "c" 3 "" "L" "Continuous" "" "LWeight" 0.15 "" "")
(command "-layer" "m" "text" "c" 2 "" "L" "Continuous" "" "LWeight" 0.13 "" "")
(command "-layer" "m" "dim" "c" 1 "" "L" "Continuous" "" "LWeight" 0.09 "" "")
)
;xong cau a va b ^^
(defun c:kk1 (/ p1 p2 oldos oldcl)
(setq oldos (getvar "osmode"))
(setq oldcl (getvar "clayer"))
(command "-layer" "m" "dim" "c" 1 "" "L" "Continuous" "" "LWeight" 0.09 "" "")
(setvar "osmode" 1)
(setvar "clayer" "dim")
(setq p1 (getpoint "\npick diem dau:"))
(setq p2 (getpoint p1 "\npick diem cuoi:"))
(command "DIMALIGNED" p1 p2)
(setvar "osmode" oldos)
(setvar "clayer" oldcl)
)
;xong cau tao dim ^^
(defun c:kk2 (/ p1 p2 oldos oldcl)
(setq oldos (getvar "osmode"))
(setq oldcl (getvar "clayer"))
(command "-layer" "m" "dim" "c" 1 "" "L" "Continuous" "" "LWeight" 0.09 "" "")
(setvar "osmode" 512)
(setvar "clayer" "dim")
(setq p1 (getpoint "\npick diem dau:"))
(setq p2 (getpoint p1 "\npick diem cuoi:"))
(command "leader" p1 p2 "" "chaizo" "")
(setvar "osmode" oldos)
(setvar "clayer" oldcl)
)
;xong leader ^^
(defun c:kk3 (/ p1 oldos oldcl)
(setq oldos (getvar "osmode"))
(setq oldcl (getvar "clayer"))
(command "-layer" "m" "hatch" "c" 3 "" "L" "Continuous" "" "LWeight" 0.15 "" "")
(setvar "osmode" 0)
(setvar "clayer" "hatch")
(setq p (getpoint "\nchon vung can hatch:"))
(command "-hatch" p1 "P" "ANSI31" 1 0 "A" "I" "Y" "S" "N" "" "")
(setvar "osmode" oldos)
(setvar "clayer" oldcl)
)
;xong cau tao hatch ^^
(defun c:kk4 (/ a b oldos oldcl)
(setq oldos (getvar "osmode"))
(setq oldcl (getvar "clayer"))
(command "-layer" "m" "text" "c" 2 "" "L" "Continuous" "" "LWeight" 0.13 "" "")
(setq a (getreal "\nnhap chieu cao:"))
(setq b (getpoint "\nchon diem dat chu"))
(command ".text" b a 0 "co len nao")
(setvar "osmode" oldos)
(setvar "clayer" oldcl)
)
;xong tao text ^^
Nhận xét :
- Bài làm khá tốt, tuy nhiên đã bỏ qua hết lợi ích của HÀM ??
- Các command nhóc viết lại coi như đã mất hết các Option của nó, liệu có hơn được nữa không ?
<<
|
Filename: 227573_kk_kk1_kk2_kk3_kk4.lsp
|
|
Tác giả: pphung183
Bài viết gốc: 311810
Tên lệnh: fixs fixstyle |
thiếu font simple.shx
Thấy bạn quan tâm nó quá thì dùng thử cái này, muốn thay font ji thì tùy bạn, lisp này tôi đang để font VNI-Helve-Condense :)
(defun c:FIXS (/) (c:FIXSTYLE))
(defun c:fixstyle (/ cmd OLD CO ST NEWHT TEMP OLDHT NEWWID)
(command "undo" "be")
(setq cmd (getvar "cmdecho")) (setvar "cmdecho" 0)
(command "_.-STYLE" "VNIHC" "VNI-Helve-Condense" "0" "0.75" "0" "N" "N") ;Neu font shx thi co duoi shx
(setq OLD (ssget '((-4 . "<OR") (0 ....
>> Thấy bạn quan tâm nó quá thì dùng thử cái này, muốn thay font ji thì tùy bạn, lisp này tôi đang để font VNI-Helve-Condense :)
(defun c:FIXS (/) (c:FIXSTYLE))
(defun c:fixstyle (/ cmd OLD CO ST NEWHT TEMP OLDHT NEWWID)
(command "undo" "be")
(setq cmd (getvar "cmdecho")) (setvar "cmdecho" 0)
(command "_.-STYLE" "VNIHC" "VNI-Helve-Condense" "0" "0.75" "0" "N" "N") ;Neu font shx thi co duoi shx
(setq OLD (ssget '((-4 . "<OR") (0 . "TEXT") (0 . "MTEXT") (-4 . "OR>"))))
(if OLD
(progn
(setq ST (getvar "textstyle"))
(if (tblsearch "style" ST)
(progn (setq NEWHT (assoc 40 (tblsearch "style" ST)))
(if (not (> (cdr NEWHT) 0))
(progn (prompt "\n The style you have chosen has a preset height of 0.")
(prompt "\n The existing height of the text will be maintained.")
)
)
(setq CO 0)
(while (< CO (sslength OLD))
(progn (setq TEMP (entget (ssname OLD CO))
CO (1+ CO)
)
(if (or (= "TEXT" (cdr (assoc 0 TEMP))) (= "MTEXT" (cdr (assoc 0 TEMP))))
(progn (setq OLDHT (assoc 40 TEMP))
(setq NEWWID (assoc 41 (tblsearch "style" ST))
NEWHT (assoc 40 (tblsearch "style" ST))
)
(if (= (cdr NEWHT) 0.0)
(setq NEWHT OLDHT)
)
(setq TEMP (subst (cons 7 ST) (assoc 7 TEMP) TEMP))
(setq TEMP (subst NEWWID (assoc 41 TEMP) TEMP))
(setq TEMP (subst NEWHT (assoc 40 TEMP) TEMP))
(entmod TEMP)
)
)
)
)
)
)
)
(prompt "\n Next time select a text style that exists.")
) (setvar "cmdecho" cmd)
(command "undo" "e")
(princ))
<<
|
Filename: 311810_fixs_fixstyle.lsp
|
|
Tác giả: Tot77
Bài viết gốc: 311928
Tên lệnh: v |
nhờ kết hợp 2 lisp
Vậy bạn thử cái này, lệnh V, chọn tỷ lệ, chọn vị trí đặt text kết quả, nhấp vùng cần chọn, xong enter.
Trước khi vào lệnh thì cho biến textsize to nhỏ tùy ý (trong bản vẽ bạn đưa thấy biến này hơi nhỏ).
Nếu nó không bắt được cái hatch naò trong vùng pick thì nó sẽ hỏi chọn đối tượng để lấy layer.
(defun c:v(/ tl1 ntl...
>> Vậy bạn thử cái này, lệnh V, chọn tỷ lệ, chọn vị trí đặt text kết quả, nhấp vùng cần chọn, xong enter.
Trước khi vào lệnh thì cho biến textsize to nhỏ tùy ý (trong bản vẽ bạn đưa thấy biến này hơi nhỏ).
Nếu nó không bắt được cái hatch naò trong vùng pick thì nó sẽ hỏi chọn đối tượng để lấy layer.
(defun c:v(/ tl1 ntl tl2 dtl ss hat hatlay oslast txtsiz pt1 et vsize dtcon elst)
(if (= tl nil)
(setq tl (getreal "\nDrawing scale : "))
)
(setq ntl (/ 1000 tl))
(setq tl2 (* ntl ntl))
(setq dtl 0)
(setq ss (ssadd) hat nil)
(setq oslast (getvar "OSMODE"))
(setvar "OSMODE" 0)
(print)
(if (not pt0) (setq pt0 (getpoint "\nChon diem dat text:")))
(setq txtsiz (getvar "textsize"))
(setq pt1 (getpoint "\nPick internal point : "))
(while (/= pt1 nil)
(if (not hat)
(progn
(setq hat (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget pt1 '((0 . "HATCH")))))))
(if hat (setq hatlay (cdr (assoc 8 (entget (car hat)))))))
)
(command "-boundary" pt1 "")
(setq et (entlast))
(ssadd et ss)
(command "area" "e" "last")
(setq vsize ( / (getvar "VIEWSIZE") 3 ))
(command "hatch" "ANSI31" vsize "0" "last" "")
(setq et (entlast))
(ssadd et ss)
(setq dtcon (getvar "AREA"))
(setq dtl (+ dtcon dtl))
(print)
(setq pt1 (getpoint "\nPick internal point : "))
)
(command "setvar" "OSMODE" oslast)
(command "erase" ss "")
(setq ss nil)
(command "redraw")
(setq dtl (/ dtl tl2))
(print dtl)
(if (not hatlay) (setq hatlay (cdr (assoc 8 (entget (car (entsel "\Chon layer theo:")))))))
(vla-addtext (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
(strcat hatlay " : " (rtos dtl 2 2)) (vlax-3d-point pt0) txtsiz)
(setq pt0 (polar pt0 -1.5708 (* 2 txtsiz)))
(print)
)
<<
|
Tác giả: luhaivinh
Bài viết gốc: 312033
Tên lệnh: ddd lll hhh ttt |
Bài tập chương 4
Nhờ mọi người giúp đỡ xem mình sai chổ nào mà layer không như đổi theo :( .Tìm miết không biết chổ nào sai hết.
(defun c:ddd(/ oldos oldcl p1 p2)
(setq oldos (getvar "osmode"))
(setq oldcl (getvar "clayer"))
(command "-layer" "n" "dim" "c" 1 "" "l" "continuous" "" "lw" 0.1 "" "")
(setvar "osmode" 1)
(setvar "clayer" "dim")
(setq p1 (getpoint "\nPick diem dau:"))
(setq p2 (getpoint P1 "\nPick diem cuoi:"))
...
>> Nhờ mọi người giúp đỡ xem mình sai chổ nào mà layer không như đổi theo :( .Tìm miết không biết chổ nào sai hết.
(defun c:ddd(/ oldos oldcl p1 p2)
(setq oldos (getvar "osmode"))
(setq oldcl (getvar "clayer"))
(command "-layer" "n" "dim" "c" 1 "" "l" "continuous" "" "lw" 0.1 "" "")
(setvar "osmode" 1)
(setvar "clayer" "dim")
(setq p1 (getpoint "\nPick diem dau:"))
(setq p2 (getpoint P1 "\nPick diem cuoi:"))
(command "DIMALIGNED" p1 p2)
(setvar "osmode" oldos)
(setvar "clayer" oldcl))
(defun c:lll(/ oldos oldcl p1 p2 p3)
(setq oldos (getvar "osmode"))
(setq oldcl (getvar "clayer"))
(command "-layer" "n" "leader" "c" 2 "" "l" "continuous" "" "lw" 0.13 "" "")
(setvar "osmode" 1)
(setvar "clayer" "leader")
(setq p1 (getpoint "\nPick diem dau:"))
(setq p2 (getpoint P1 "\nPick diem thu hai:"))
(setq p3 (getpoint p2 "\nPick diem cuoi:"))
(command "LEADER" p1 p2 p3)
(setvar "osmode" oldos)
(setvar "clayer" oldcl))
(defun c:hhh(/ oldos oldcl p1 p2)
(setq oldos (getvar "osmode"))
(setq oldcl (getvar "clayer"))
(command "-layer" "n" "hacth" "c" 3 "" "l" "continuous" "" "lw" 0.15 "" "")
(setvar "osmode" 1)
(setvar "clayer" "hacth")
(command "-HATCH")
(setvar "osmode" oldos)
(setvar "clayer" oldcl))
(defun c:ttt(/ oldos oldcl p1 p2)
(setq oldos (getvar "osmode"))
(setq oldcl (getvar "clayer"))
(command "-layer" "n" "text" "c" 4 "" "l" "continuous" "" "lw" 0.2 "" "")
(setvar "osmode" 1)
(setvar "clayer" "text")
(command "-TEXT")
(setvar "osmode" 1)
(setvar "clayer" "leader")
(setvar "osmode" oldos)
(setvar "clayer" oldcl))
<<
|
Filename: 312033_ddd_lll_hhh_ttt.lsp
|
|
Tác giả: hiepttr
Bài viết gốc: 278284
Tên lệnh: vct3 |
Chương 6 : Bài Tập
ok thầy Ket !
Mình sửa rồi đây !
:D :D :D
;;;Bai7_2: Viet chuong trinh ve m/c doc cau thang 1 ve, biet truoc:
;;a: So bac, kich thuoc bac
;;b: Chieu cao nha, so bac, be rong mat bac
;;c: Chieu cao nha, so bac, goc nghieng thang
(defun c:VCT3( / pt lst_va old C R n h goc ang)
(setq lst_va '("osmode" "cmdecho" "ANGDIR" "ANGBASE"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0 0 0))
(initget 1 "Sobackichthuocbac...
>> ok thầy Ket !
Mình sửa rồi đây !
:D :D :D
;;;Bai7_2: Viet chuong trinh ve m/c doc cau thang 1 ve, biet truoc:
;;a: So bac, kich thuoc bac
;;b: Chieu cao nha, so bac, be rong mat bac
;;c: Chieu cao nha, so bac, goc nghieng thang
(defun c:VCT3( / pt lst_va old C R n h goc ang)
(setq lst_va '("osmode" "cmdecho" "ANGDIR" "ANGBASE"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0 0 0))
(initget 1 "Sobackichthuocbac Chieucaonhasobacberongmatbac chieucaonhasobacGocnghiengthang _A B C")
(setq key (getkword "\nTuy chon < Sobac,kichthuocbac Chieucaonha,sobac,berongmatbac chieucaonha,sobac,Gocnghiengthang >: "))
(cond
((= key "A")
(if
(and
(setq pt (getpoint "\nChon diem chuan: "))
(setq C (getreal "\nChieu cao bac: "))
(setq R (getreal "\nChieu rong bac: "))
(setq n (getint "\nSo bac: "))
)
(ACT pt C R n)
)
)
((= key "B")
(if (and
(setq pt (getpoint "\nChon diem chuan: "))
(setq h (getreal "\nChieu cao nha: "))
(setq n (getint "\nSo bac: "))
(setq R (getreal "\nChieu rong bac: "))
)
(progn
(setq C (/ h n))
(ACT pt C R n)
)
)
)
((= key "C")
(if (and
(setq pt (getpoint "\nChon diem chuan: "))
(setq h (getreal "\nChieu cao nha: "))
(setq n (getint "\nSo bac: "))
(setq ang (getreal "\nGoc nghieng thang (deg): "))
)
(progn
(setq C (/ h n)
R (* C (/ (cos (setq goc (/ (* ang pi) 180))) (sin goc)))
)
(ACT pt C R n)
)
)
)
)
(mapcar 'setvar lst_va old)
(princ)
)
;;;;;;;;;;;=================================================================================
(defun ACT(pt h w n / pt1 l1 pt2 l2 SAng)
(command ".line" pt (setq pt1 (polar pt (/ pi 2) h)) "")
(setq l1 (entlast))
(command ".line" pt1 (setq pt2 (polar pt1 0 w)) "")
(setq l2 (entlast))
(setq SAng (getvar 'SnapAng))
(setvar 'SnapAng (angle pt pt2))
(command "-array" l1 l2 "" "R" 1 n (distance pt pt2))
(setvar 'SnapAng SAng)
)
<<
|
Filename: 278284_vct3.lsp
|
|
Tác giả: hiepttr
Bài viết gốc: 312098
Tên lệnh: hhh show mhide mshow game nhay hl |
Chương 10.2 : Text Window, Redraw
Mấy hôm nay bận "chạy đua", giờ mới trả bài đc đây
Hy vọng là ổn
;;Chuong 10. 2
;==============================
;;Bai 1: Lenh HIDE an mot nhom doi tuong, lenh duoc su dung 1 lan,
;sau do co the hien lai nhom doi tuong cu bang lenh SHOW
(defun c:HHH()
(prompt "\n Chon doi tuong can an !")
(setq ss_hide_25251325 (ssget))
(if ss_hide_25251325 (MREDRAW ss_hide_25251325 2))
)
(defun c:SHOW( / i)
(if ss_hide_25251325...
>> Mấy hôm nay bận "chạy đua", giờ mới trả bài đc đây
Hy vọng là ổn
;;Chuong 10. 2
;==============================
;;Bai 1: Lenh HIDE an mot nhom doi tuong, lenh duoc su dung 1 lan,
;sau do co the hien lai nhom doi tuong cu bang lenh SHOW
(defun c:HHH()
(prompt "\n Chon doi tuong can an !")
(setq ss_hide_25251325 (ssget))
(if ss_hide_25251325 (MREDRAW ss_hide_25251325 2))
)
(defun c:SHOW( / i)
(if ss_hide_25251325 (MREDRAW ss_hide_25251325 1))
)
;====================================
;;Bai 2: Lenh mHide an nhieu nhom doi tuong, lenh co the dung nhieu lan.
;Sau do co the dung lenh mShow de hien lai tat ca cac nhom da an bang lenh mHide
(defun c:mHide( / ss lst_ss i)
(prompt "\n Chon doi tuong can an <mHide>!")
(setq ss (ssget))
(if ss
(progn
(setq lst_ss (ss2lst ss)
ss_Mhide_25251325 (append lst_ss ss_Mhide_25251325)
)
(MREDRAW ss 2)
) ;progn
) ;if
)
(defun c:MSHOW( / i ss)
(if ss_Mhide_25251325
(progn
(setq ss (lst2ss ss_Mhide_25251325))
(MREDRAW ss 1)
(setq ss_Mhide_25251325 nil)
) ;progn
)
)
;==============================================
;;Bai 3: Lenh xoa tat ca doi tuong tren man hinh, chi de lai dong chu THIS IS A PRANK
;Sau do, yeu cau nguoi dung nhap dung chu Please thi tra va trang thai ban dau
(defun c:GAME( / cmd ss str)
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq ss (ssget "X"))
(if ss
(progn
(MREDRAW ss 2)
(entmake (list
'(0 . "TEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
'(10 0 0)
(cons 40 (/ (getvar "viewsize") 12))
'(1 . "THIS IS A PRANK")
(cons 72 1)
(list 11 (car (setq tam (getvar "viewctr"))) (cadr tam)))
) ;entmake
(setq tbao (entlast))
(while (or (not str) (/= str "Please")) (setq str (getstring "\nNhap dung chu: <Please> de hien thi lai cong viec: ")))
(if (= str "Please") (MREDRAW ss 1))
(entdel tbao)
) ;progn
) ;if
(setvar "cmdecho" cmd)
(princ)
)
;==================================================
;;Bai 4:
;Thu tuc nhap nhay 1 nhom doi tuong, trong do: Nhom doi tuong, so lan nhap nhay, toc do nhap nhay (lan/s)
;do nguoi dung chi dinh. Cuoi cung hien thi so doi tuong trong nhom, so lan nhay, thoi gian toi thieu thuc hien
;Quay ve man hinh ve neu nguoi dung an enter
(defun c:NHAY( / ss n v time cmd)
(prompt "\nChon doi tuong !")
(setq ss (ssget))
(if ss
(progn
(setq cmd (getvar 'cmdecho))
(setvar 'cmdecho 0)
(setq n (getint "\nSo lan nhay:")
v (getreal "\nToc do nhay <lan/giay>:")
time (fix (/ 500 v )))
(repeat n
(MREDRAW ss 2)
(command "delay" time)
(MREDRAW ss 1)
(command "delay" time)
)
(textscr)
(command "delay" 1000)
(princ (strcat "\nSo doi tuong da nhap nhay la: " (itoa (sslength ss)) " <doi tuong>"))
(command "delay" 1000)
(princ (strcat "\nSo lan nhay: " (itoa n) " <lan>"))
(command "delay" 1000)
(princ (strcat "\nToc do nhay: " (rtos v) " <lan/giay>"))
(command "delay" 1000)
(princ (strcat "\nThoi gian thuc hien: > " (itoa (* n 2 time)) " <mili giay>" ))
(if (= "" (getstring "\n***Enter de quay tro lai man hinh ve !***")) (graphscr))
(setvar 'cmdecho cmd)
(princ)
) ;progn
) ;if
)
;========================================================
;;Bai 5: Lenh highlight tat ca cac doi tuong co layer khac layer "0"
(defun c:HL(/ ss lst_lay lay str)
(setq ss (ssget "X" '((8 . "~0"))))
(if ss
(progn
(setq i -1)
(repeat (sslength ss)
(setq ename (ssname ss (setq i (1+ i)))
lay (cdr(assoc 8 (entget ename)))
info (entget (tblobjname "layer" lay)))
(cond
((< (cdr (assoc 62 info)) 0)
(LayOnOff lay)
(setq lst_lay (cons lay lst_lay))
)) ;cond
) ;repeat
(MREDRAW ss 3)
(while (or (not str) (/= str "")) (setq str (getstring "\nEnter de tro lai trang thai cu: ")))
(cond
((= str "")
(MREDRAW ss 4)
(foreach elem lst_lay
(LayOnOff elem)
) ;for
)) ;cond
) ;pro
) ;if
)
;================================================================================================================
;********************************************
(defun MREDRAW (ss code / i ename)
(setq i 0)
(repeat (sslength ss)
(setq ename (ssname ss i)
i (1+ i))
(redraw ename code)
) ;repeat
)
;*********************************************
(defun ss2lst (ss / ename i lst)
;chuyen ss thanh list
(setq i 0)
(repeat (sslength ss)
(setq ename (ssname ss i)
i (1+ i)
lst (cons ename lst))
)
(reverse lst)
)
;**********************************************
(defun lst2ss (lst / ename i ss)
;chuyen lst thanh ss
(setq i 0 ss (ssadd))
(repeat (length lst)
(setq ename (nth i lst)
i (1+ i)
ss (ssadd ename ss))
)
)
;**************************************************
(defun LayOnOff (layer_name / info)
;chg 9
(setq info (entget (tblobjname "layer" layer_name)))
(entmod (subst (cons 62 (* -1 (cdr (assoc 62 info)))) (assoc 62 info) info))
)
<<
|
Filename: 312098_hhh_show_mhide_mshow_game_nhay_hl.lsp
|
|
Tác giả: hiepttr
Bài viết gốc: 312247
Tên lệnh: mkl |
Mọi người hướng dẫn cách viết lisp mà mình muốn ?
Lại có cái khó hiểu muốn đc các bác chỉ giáo ^^
Thể theo nguyện vọng của haanh, mình mày mò viết lisp cho yêu cầu này:
http://www.cadviet.com/forum/topic/43060-hoi-lisp-thao-tac-trong-3d/page-3
>>> mình làm công cụ để tạo list dot pair biểu diễn sự liên quan giữa đường kính ống & chiều cao tâm cút 90 độ trong bảng excel
thuộc #41 như bên dưới (do chưa đủ trình để nhập dữ liệu từ excel):
(defun c:MKL(/ i so1 j so2 lst1 lst2)
(setq i 1 j 1)
(while (setq so1 (getint (strcat "\nNhap so hang thu " (itoa i) " thuoc day 1: ")))
(setq i (1+ i)
lst1 (append lst1 (list so1))))
(while (setq so2 (getreal (strcat "\nNhap so hang thu " (itoa j) " thuoc day 2: ")))
(setq j (1+ j)
lst2 (append lst2 (list so2))))
(if (= (length lst1) (length lst2))
(setq lst (mapcar 'cons lst1 lst2))
(alert "\n*** Da co loi xay ra _ _ _ Hai day so co chieu day khac nhau !***")
) ;if
)
khi mình chạy thử (dãy 1 tương ứng đường kính, dãy 2 tương ứng chiều cao tâm cút 90 độ thì xảy ra lỗi dưới đây
Nhap so hang thu 1 thuoc day 1: 12
Nhap so hang thu 2 thuoc day 1: 13
Nhap so hang thu 3 thuoc day 1: 18
Nhap so hang thu 4 thuoc day 1: 19
Nhap so hang thu 5 thuoc day 1: 22
Nhap so hang thu 6 thuoc day 1: 23
Nhap so hang thu 7 thuoc day 1: 28
Nhap so hang thu 8 thuoc day 1: 29
Nhap so hang thu 9 thuoc day 1: 35
Nhap so hang thu 10 thuoc day 1: 34
Nhap so hang thu 11 thuoc day 1: 40
Nhap so hang thu 12 thuoc day 1: 52
Nhap so hang thu 13 thuoc day 1: 53
Nhap so hang thu 14 thuoc day 1: 70
Nhap so hang thu 15 thuoc day 1: 69
Nhap so hang thu 16 thuoc day 1: 85
Nhap so hang thu 17 thuoc day 1: 84
Nhap so hang thu 18 thuoc day 1: 104
Nhap so hang thu 19 thuoc day 1: 129
Nhap so hang thu 20 thuoc day 1: 154
Nhap so hang thu 21 thuoc day 1: 204
Nhap so hang thu 22 thuoc day 1: 254
; error: Exception occurred: 0xC0000005 (Access Violation)
; warning: unwind skipped on exception
; error: Exception occurred: 0xC0000005 (Access Violation)
Khó hiểu quá, mình chỉ tạo list thôi mà ! ^^
Help me !!!
<<
|
Tác giả: Thaistreetz
Bài viết gốc: 79637
Tên lệnh: stext |
Hướng dẫn lập trình Lisp
hihi, em cũng đang thắc mắc vấn đề này.
về việc sắp xếp lại các điểm tọa độ đó bác thử nghiêm cứu lisp sắp xếp text của bác Hoành xem có mót được gì không. trong lisp này có đoạn code sắp xếp lại các đối tượng được chọn theo tọa độ Y.
còn việc loại bỏ các điểm có tọa độ trùng nhau em cũng đang thắc mắc.
Ps: em đoán hình như bác cũng đang... >>
hihi, em cũng đang thắc mắc vấn đề này.
về việc sắp xếp lại các điểm tọa độ đó bác thử nghiêm cứu lisp sắp xếp text của bác Hoành xem có mót được gì không. trong lisp này có đoạn code sắp xếp lại các đối tượng được chọn theo tọa độ Y.
còn việc loại bỏ các điểm có tọa độ trùng nhau em cũng đang thắc mắc.
Ps: em đoán hình như bác cũng đang nghiên cứu lisp nội suy mặt cắt ngang fải không ạ <<
|
Filename: 79637_stext.lsp
|
|
Tác giả: hiepttr
Bài viết gốc: 312218
Tên lệnh: ve |
Lisp thao tác trong 3D
Rảnh đc tí, xin đc đặt cục gạch đầu tiên (m[í chỉ vẽ ống) :D
Lệnh là VE
;lisp ve duong ong 3d
(defun c:VE(/ var old D lst_ver pt_w lst_w i n len dau cuoi dau_use cuoi_use)
(setq var '("osmode" "cmdecho")
old (mapcar 'getvar var))
(mapcar 'setvar var '(0 0))
(setq D (getdist "\nNhap duong kinh ong: ")
lst_TC_DUC '((12 . 26) (13 . 26) (18 . 35) (19 . 35) (22 . 40) (23 . 40) (28 . 50))
cao_tam_cut (cdr (assoc D...
>> Rảnh đc tí, xin đc đặt cục gạch đầu tiên (m[í chỉ vẽ ống) :D
Lệnh là VE
;lisp ve duong ong 3d
(defun c:VE(/ var old D lst_ver pt_w lst_w i n len dau cuoi dau_use cuoi_use)
(setq var '("osmode" "cmdecho")
old (mapcar 'getvar var))
(mapcar 'setvar var '(0 0))
(setq D (getdist "\nNhap duong kinh ong: ")
lst_TC_DUC '((12 . 26) (13 . 26) (18 . 35) (19 . 35) (22 . 40) (23 . 40) (28 . 50))
cao_tam_cut (cdr (assoc D lst_TC_DUC)))
(prompt "\nChon 3DPOLY: ")
(setq lst_ver (acet-geom-vertex-list (car(entsel))))
(foreach pt lst_ver
(setq pt_w (trans pt 1 0)
lst_w (append lst_w (list pt_w))))
(setq i 0)
(repeat (setq n (1- (length lst_w)))
(setq len (distance (setq dau (nth i lst_w)) (setq cuoi (nth (1+ i) lst_w))))
(command "UCS" "za" (trans dau 0 1) (trans cuoi 0 1))
(cond
((= i 0) (command "CYLINDER" (setq dau_use (trans dau 0 1)) (setq R (/ D 2.0)) (- len cao_tam_cut)))
((= i (1- n)) (command "CYLINDER" (setq dau_use (mapcar '+ (list 0 0 cao_tam_cut) (trans dau 0 1))) R (- len cao_tam_cut)))
(t (command "CYLINDER" (setq dau_use (mapcar '+ (list 0 0 cao_tam_cut) (trans dau 0 1))) R (- len (* 2 cao_tam_cut))))
)
(setq i (1+ i))
)
(mapcar 'setvar var old)
)
<<
|
Tác giả: hiepttr
Bài viết gốc: 312331
Tên lệnh: ve |
Lisp thao tác trong 3D
Hàng nóng hổi đây ! :D :D :D
Để chiều, nếu ko có ý kiến gì thì mình sẽ gom ống thành 1 cục, cút thành 1 cục theo ý của Hoằn
;lisp ve duong ong 3d
(defun c:VE(/ var old D lst_TC_DUC cao_tam_cut R path cut base_w lst_ver lst_w obj i n len dau cuoi)
(setq var '("osmode" "cmdecho")
old (mapcar 'getvar var))
(mapcar 'setvar var '(0 0))
(setq D (getdist "\nNhap duong kinh ong: ")
lst_TC_DUC '((12...
>> Hàng nóng hổi đây ! :D :D :D
Để chiều, nếu ko có ý kiến gì thì mình sẽ gom ống thành 1 cục, cút thành 1 cục theo ý của Hoằn
;lisp ve duong ong 3d
(defun c:VE(/ var old D lst_TC_DUC cao_tam_cut R path cut base_w lst_ver lst_w obj i n len dau cuoi)
(setq var '("osmode" "cmdecho")
old (mapcar 'getvar var))
(mapcar 'setvar var '(0 0))
(setq D (getdist "\nNhap duong kinh ong: ")
lst_TC_DUC '((12 . 26.0) (13 . 26.0) (18 . 35.0) (19 . 35.0) (22 . 40.0) (23 . 40.0) (28 .
50.0) (29 . 50.0) (35 . 55.0) (34 . 55.0) (40 . 60.0) (52 . 70.0) (53 . 70.0)
(70 . 80.0) (69 . 80.0) (85 . 90.0) (84 . 90.0) (104 . 100.0) (129 . 187.5)
(154 . 225.0) (204 . 300.0) (254 . 375.0))
cao_tam_cut (cdr (assoc D lst_TC_DUC))
) ;setq
;=================
;ve cut mau:
(command "arc" "c" '(0 0 0) (list cao_tam_cut 0 0) (list 0 cao_tam_cut 0))
(setq path (entlast))
(command "circle" '(0 0 0) (setq R (/ D 2.0)))
(command "sweep" (entlast) "" path)
(setq cut (entlast))
(setq base_w (mapcar '(lambda (x) (trans x 1 0)) (list (list cao_tam_cut 0 0) (list cao_tam_cut cao_tam_cut 0) (list 0 cao_tam_cut 0))))
;== xong cut mau ==
(prompt "\nChon 3DPOLY: ")
(setq lst_ver (acet-geom-vertex-list (setq ename (car(entsel))))
lst_w (mapcar '(lambda (x) (trans x 1 0)) lst_ver)
obj (vlax-ename->vla-object ename))
(setq i 0)
(repeat (setq n (1- (length lst_w)))
(setq len (distance (setq dau (nth i lst_w)) (setq cuoi (nth (1+ i) lst_w))))
(command "UCS" "za" (trans dau 0 1) (trans cuoi 0 1))
(cond
((= i 0) (command "CYLINDER" (trans dau 0 1) R (- len cao_tam_cut))
(command "_3dalign" cut "" "c"
(trans (car base_w) 0 1)
(trans (cadr base_w) 0 1)
(trans (last base_w) 0 1)
(trans (vlax-curve-getPointAtDist obj (- (vlax-curve-getDistAtParam obj 1) cao_tam_cut)) 0 1)
(trans (vlax-curve-getPointAtParam obj 1) 0 1)
(trans (vlax-curve-getPointAtDist obj (+ (vlax-curve-getDistAtParam obj 1) cao_tam_cut)) 0 1))
)
((= i (1- n)) (command "CYLINDER" (mapcar '+ (list 0 0 cao_tam_cut) (trans dau 0 1)) R (- len cao_tam_cut)))
(t (command "CYLINDER" (mapcar '+ (list 0 0 cao_tam_cut) (trans dau 0 1)) R (- len (* 2 cao_tam_cut)))
(command "_3dalign" cut "" "c"
(trans (car base_w) 0 1)
(trans (cadr base_w) 0 1)
(trans (last base_w) 0 1)
(trans (vlax-curve-getPointAtDist obj (- (vlax-curve-getDistAtParam obj (1+ i)) cao_tam_cut)) 0 1)
(trans (vlax-curve-getPointAtParam obj (1+ i)) 0 1)
(trans (vlax-curve-getPointAtDist obj (+ (vlax-curve-getDistAtParam obj (1+ i)) cao_tam_cut)) 0 1)))
)
(setq i (1+ i))
)
(mapcar 'entdel (list cut path))
(mapcar 'setvar var old)
)
(vl-load-com)
<<
|
Tác giả: nhoclangbat
Bài viết gốc: 312405
Tên lệnh: toado |
Lisp ghi toạ độ điểm ra màn hình !!!
hihi, có hứa với bạn ngochavn kiếm cho bạn nhưng hum nay nhoc đi đo từ sớm nên ko kịp giờ bù cho bạn hen kaka ^^
- lưu ý trước khi chạy bạn phải tạo rùi set ranh đất bạn muốn chạy tọa độ ở layer tên "ranh_38", lệnh là "toado"
(defun *error* (msg)
(princ "error: ")
(princ msg)
(princ)
)
(defun Wdis (p1 p2 / dis ang point point1)
(setq dis (distance p1 p2))
(setq ang (angle p1...
>> hihi, có hứa với bạn ngochavn kiếm cho bạn nhưng hum nay nhoc đi đo từ sớm nên ko kịp giờ bù cho bạn hen kaka ^^
- lưu ý trước khi chạy bạn phải tạo rùi set ranh đất bạn muốn chạy tọa độ ở layer tên "ranh_38", lệnh là "toado"
(defun *error* (msg)
(princ "error: ")
(princ msg)
(princ)
)
(defun Wdis (p1 p2 / dis ang point point1)
(setq dis (distance p1 p2))
(setq ang (angle p1 p2))
(if (and (> ang (/ Pi 2)) (< ang (* Pi 1.5)) )
(progn
(setq ang (+ Ang Pi))
(setq Point (polar p2 ang (/ dis 2.0)))
(setq Point1 (polar point (+ (/ pi 2) ang) (* 0.25 (/ TileBdHT 500))))
)
(progn
(setq Point (polar p1 ang (/ dis 2.0)))
(setq Point1 (polar point (+ (/ pi 2) ang) (* 0.25 (/ TileBdHT 500))))
)
)
(command "Text" "S" "vaptimn" "c" point1 (/ TileBdHT 500) (* (/ ang Pi) 180) (rtos dis 2 2) )
)
(defun ssgetLayer( La1 La2 / ss)
(setq ss (ssget "X" (list
(cons -4 "<OR")
(cons -4 "<AND")
(cons 8 La1)
(cons 0 "LWPOLYLINE")
(cons -4 "AND>")
(cons -4 "<AND")
(cons 8 La1)
(cons 0 "LINE")
(cons -4 "AND>")
(cons -4 "<AND")
(cons 8 La2)
(cons 0 "LWPOLYLINE")
(cons -4 "AND>")
(cons -4 "<AND")
(cons 8 La2)
(cons 0 "LINE")
(cons -4 "AND>")
(cons -4 "OR>")
)
))
ss
)
(defun pointpl (name t2 k / namem i bien t1 p1 diem)
(setq namem name)
(setq i 1)
(while (<= i k)
(progn
(setq bien (assoc t2 namem))
(setq t1 (member bien namem))
(setq p1 (car t1))
(setq namem (cdr t1))
(setq diem (cdr p1))
(setq i (+ 1 i))
)
)
diem
)
(defun c:Toado( / i k luuxy st p xoa)
(setvar "cmdecho" 0)
(setq st (ssgetLayer "Ranh_toado" "Ranh_38") )
(if (/= st nil)
(progn
(if (null (tblsearch "style" "vaptimn"))
(command "style" "vaptimn" "vni-avo" "" "" "" "" ""))
(if (null (tblsearch "style" "vhelveb"))
(command "style" "vhelveb" "vni-helve" "" "" "" "" ""))
(if (null (tblsearch "layer" "sohieu_diem"))
(command "_layer" "n" "sohieu_diem" ""))
(command "_layer" "c" "2" "sohieu_diem" "")
(if (null (tblsearch "layer" "canh"))
(command "_layer" "n" "canh" ""))
(command "_layer" "c" "3" "canh" "")
(if (null (tblsearch "layer" "bang_toado"))
(command "_layer" "n" "bang_toado" ""))
(command "_layer" "c" "7" "bang_toado" "")
(command "_layer" "c" "6" "Ranh_38" "")
(command "_layer" "c" "6" "Ranh_toado" "")
(if (null (tblsearch "layer" "Polygon"))
(command "_layer" "n" "Polygon" ""))
(command "_layer" "c" "8" "Polygon" "")
(if (not r1) (setq r1 500))
(setq TileBdHT (getreal (strcat "\nMau So Ti Le Cua BDHT" "(" (rtos r1 2 0) "):")))
(if (= TileBdHT nil)
(setq TileBdHT r1))
(setvar "blipmode" 0)
(setq old (getvar "osmode"))
(setvar "osmode" 0)
(setq p (getpoint "\n Pick"))
(command "_layer" "s" "Polygon" "")
(if (/= p nil)
(command "-Boundary" "a" "b" "n" st "" "" p "" )
)
(setq luuxy (entget (entlast)))
(setq pt (getpoint "\n Diem dat bang toa do :"))
;(entdel (entlast))
(setq k (cdr (assoc 90 luuxy)))
(if (/= pt nil)
(progn
(setq p01 pt)
(setq p02 (mapcar '+ pt '(10.0 0.0 0.0)))
(setq p03 (mapcar '+ pt '(22.5 -2.5 0.0)))
(setq p04 (mapcar '+ pt '(35.0 0.0 0.0)))
(setq p05 (mapcar '+ pt '(45.0 0.0 0.0)))
(setq p06 (mapcar '+ pt '(0.0 -5.0 0.0)))
(setq p07 (mapcar '+ pt '(10.0 -2.5 0.0)))
(setq p08 (mapcar '+ pt '(35.0 -2.5 0.0)))
(setq p09 (mapcar '+ pt '(45.0 -5.0 0.0)))
(if (<= k 10)
(progn
(setq p10 (mapcar '+ pt '(0.0 -40.0 0.0)))
(setq p11 (mapcar '+ pt '(10.0 -40.0 0.0)))
(setq p12 (mapcar '+ pt '(22.5 -40.0 0.0)))
(setq p13 (mapcar '+ pt '(35.0 -40.0 0.0)))
(setq p14 (mapcar '+ pt '(45.0 -40.0 0.0)))
)
(progn
(setq ty (* -1 (+ 10.0 (* k 3))))
(setq t0 (list 0.0 ty 0.0))
(setq t1 (list 10.0 ty 0.0))
(setq t2 (list 22.5 ty 0.0))
(setq t3 (list 35.0 ty 0.0))
(setq t4 (list 45.0 ty 0.0))
(setq p10 (mapcar '+ pt t0))
(setq p11 (mapcar '+ pt t1))
(setq p12 (mapcar '+ pt t2))
(setq p13 (mapcar '+ pt t3))
(setq p14 (mapcar '+ pt t4))
)
)
(command "layer" "s" "bang_toado" "")
(command "Line" p01 p05 "")
(command "Line" p01 p10 "")
(command "Line" p02 p11 "")
(command "Line" p03 p12 "")
(command "Line" p04 p13 "")
(command "Line" p05 p14 "")
(command "Line" p07 p08 "")
(command "Line" p06 p09 "")
(command "Line" p10 p14 "")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ pt '(22.5 2.0 0.0)) 1.25 0 "BAÛNG LIEÄT KEÂ TOÏA ÑOÄ GOÙC RANH")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ pt '(5.0 -1.5 0.0)) 1.15 0 "Soá hieäu")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ pt '(5.0 -3.5 0.0)) 1.15 0 "ñieåm")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ pt '(22.5 -1.25 0.0)) 1.15 0 "Toïa ñoä")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ pt '(16.25 -3.75 0.0)) 1.15 0 "X(m)")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ pt '(28.75 -3.75 0.0)) 1.25 0 "Y(m)")
(command "Text" "S" "vhelveb" "j" "M" (mapcar '+ pt '(40.0 -2.5 0.0)) 1.25 0 "Caïnh")
)
)
(setq i 1)
(while (<= i k)
(progn
(setq toado (pointpl luuxy 10 i))
(setq x (rtos (car toado) 2 2))
(setq y (rtos (cadr toado) 2 2))
(command "layer" "s" "sohieu_diem" "")
(setq doi (list (* 0.2 (/ TileBdHT 500)) (* 0.2 (/ TileBdHT 500)) 0.0))
(command "Text" "S" "vaptimn" (mapcar '+ toado doi) (/ TileBdHT 500) 0 i)
(command ".donut" 0 (* 0.25 (/ TileBdHT 500)) toado "")
(setq tsh (list 5.0 (- (* -3 i) 4.5) 0.0))
(setq txx (list 16.25 (- (* -3 i) 4.5) 0.0))
(setq tyy (list 28.75 (- (* -3 i) 4.5) 0.0))
(setq tgc (list 40.0 (- (* -3 i) 3.0) 0.0))
(setq psh (mapcar '+ pt tsh))
(setq pxx (mapcar '+ pt txx))
(setq pyy (mapcar '+ pt tyy))
(setq pgc (mapcar '+ pt tgc))
(if (= i 1)
(progn
(setq toado1 toado)
(setq x1 (rtos (car toado1) 2 2))
(setq y1 (rtos (cadr toado1) 2 2))
)
)
(if (>= i 2)
(progn
(setq canh (distance toado0 toado))
(command "layer" "s" "bang_toado" "")
(command "Text" "S" "vaptimn" "j" "M" pgc 1.2 0 (rtos canh 2 2) )
(command "layer" "s" "canh" "")
(wdis toado0 toado)
)
)
(command "layer" "s" "bang_toado" "")
(command "Text" "S" "vaptimn" "j" "M" psh 1.2 0 i)
(command "Text" "S" "vaptimn" "j" "M" pxx 1.2 0 y)
(command "Text" "S" "vaptimn" "j" "M" pyy 1.2 0 x)
(setq toado0 toado)
(setq i (+ i 1))
)
)
(command "layer" "s" "canh" "")
(wdis toado toado1)
(setq canh (distance toado toado1))
(setq tsh (list 5.0 (- (* -3 (+ k 1)) 4.5) 0.0))
(setq txx (list 16.25 (- (* -3 (+ k 1)) 4.5) 0.0))
(setq tyy (list 28.75 (- (* -3 (+ k 1)) 4.5) 0.0))
(setq tgc (list 40.0 (- (* -3 (+ k 1)) 3.0) 0.0))
(setq psh (mapcar '+ pt tsh))
(setq pxx (mapcar '+ pt txx))
(setq pyy (mapcar '+ pt tyy))
(setq pgc (mapcar '+ pt tgc))
(command "layer" "s" "bang_toado" "")
(command "Text" "S" "vaptimn" "j" "M" pgc 1.2 0 (rtos canh 2 2) )
(command "Text" "S" "vaptimn" "j" "M" psh 1.2 0 "1")
(command "Text" "S" "vaptimn" "j" "M" pxx 1.2 0 y1)
(command "Text" "S" "vaptimn" "j" "M" pyy 1.2 0 x1)
(setvar "osmode" old)
) ;(end progn)
) ;(end if)
(if (= st nil)
(progn
(setvar "cmdecho" 1)
(princ "Khong co layer Ranh_toado")
)
)
(command "_layer" "s" "0" "")
)
<<
|
Filename: 312405_toado.lsp
|
|
Tác giả: hiepttr
Bài viết gốc: 275295
Tên lệnh: vct2 |
Chương 6 : Bài Tập
Bài 8: (theo cách bác Tuệ)
;;;Bai8: Viet chuong trinh ve cau thang co dinh kem text danh so bac. Cac thong so da neu deu phai dc ghi nho cho lan sau:
(defun c:VCT2( / pt i lst_va old)
(if (not (tblsearch "style" "STT_cau_thang"))
(command ".style" "STT_cau_thang" ".vnArial" 20 "" "" "" "")
)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(if (setq pt (getpoint "\nPick diem chen:...
>> Bài 8: (theo cách bác Tuệ)
;;;Bai8: Viet chuong trinh ve cau thang co dinh kem text danh so bac. Cac thong so da neu deu phai dc ghi nho cho lan sau:
(defun c:VCT2( / pt i lst_va old)
(if (not (tblsearch "style" "STT_cau_thang"))
(command ".style" "STT_cau_thang" ".vnArial" 20 "" "" "" "")
)
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(if (setq pt (getpoint "\nPick diem chen: "))
(progn
;;chieu cao bac:
(setq #ht (nhan_gia_tri #ht 170.0 getreal "Nhap chieu cao bac"))
;;chieu rong bac:
(setq #bt (nhan_gia_tri #bt 250.0 getreal "Nhap chieu rong bac"))
;;so bac:
(setq #n (nhan_gia_tri #n 20 getint "Nhap so bac"))
;;ve:
(setq i 0)
(repeat #n
(command ".text" "s" "STT_cau_thang" (polar pt (/ pi 2) (+ 5 #ht)) "" (itoa (setq i (1+ i))))
(command ".line" pt (polar pt (/ pi 2) #ht) (setq pt (polar (polar pt (/ pi 2) #ht) 0 #bt)) "")
)
(command ".zoom" "e")
)
)
(mapcar 'setvar lst_va old)
(princ)
)
;;;===================================================================================================
(defun NHAN_GIA_TRI(a mac_dinh ham str_nhac)
(or a (setq a mac_dinh))
(setq a (cond ((ham (strcat "\n" str_nhac " <" (vl-princ-to-string a) ">: "))) (a)))
)
<<
|
Filename: 275295_vct2.lsp
|
|
Tác giả: Tot77
Bài viết gốc: 312484
Tên lệnh: dd |
Xin lisp tính độ dốc giữa 2 điểm nằm trên một đường polyline
Bạn thử cái này.
(defun c:dd(/ t1 t2 pl dai)
(setq t1 (car (entsel "\nChon text cao do 1:"))
t2 (car (entsel "\nChon text cao do 2:"))
pl (car (entsel "\nChon polyline:"))
dai (vlax-curve-getDistAtParam pl (vlax-curve-getEndParam pl)))
(princ (strcat "\nDo doc : " (rtos(/ (- (atof (cdr (assoc 1 (entget t1))))
(atof (cdr (assoc 1 (entget t2))))) dai))))
(princ)
)
|