Info | File |
Tác giả: Tue_NV
Bài viết gốc: 129852
Tên lệnh: ctn ctn |
Nhờ viết Lisp Match bề dày cho Line
Cái Line không có thuộc tính width đâu bạn nhé, LWPOLYLINE thì mới có thuộc tính width thôi ah. Thử đoạn code sau xem...
>>
Cái Line không có thuộc tính width đâu bạn nhé, LWPOLYLINE thì mới có thuộc tính width thôi ah. Thử đoạn code sau xem sao.
(defun C:CTN (/ obj Vla-obj 2Width 2obj) (vl-load-com) (setvar "CmdEcho" 0) (prompt "\n<< Match PLINE ConstantWidth - elleHCSC >>") (setq obj (car(entsel "\n1. Select source PLINE: "))) (if obj (progn (if (/= (cdr(assoc 0 (entget obj)))"LWPOLYLINE") (prompt "\n>>> Object must be PLINE !") (progn (setq Vla-obj (vlax-ename->vla-object obj)) (setq 2Width(vla-get-ConstantWidth Vla-obj)) (while (setq 2obj (car(entsel "\n2. Select destination LINE, PLINE:"))) .......
Chào bác elleHCSC Nếu đã sử dụng Lisp thì nên chọn đối tượng đích 1 loạt luôn, không cần phải chọn từng cái đâu, bác ạ. Tue_NV đã viết lại, sử dụnglệng MA của CAD, sử lý luôn cho ARC
<<
|
Filename: 129852_ctn_ctn.lsp
|
|
Tác giả: huynhphuoc
Bài viết gốc: 403569
Tên lệnh: xuatgoc |
Nhờ Viết Lisp Xuat Xyz Sang Góc Cạnh
-Trước tết mình nhận được cái yêu cầu i chang như vậy. Tin rằng với yêu cầu như của bạn với cái suy nghĩ ai biết...
>>
-Trước tết mình nhận được cái yêu cầu i chang như vậy. Tin rằng với yêu cầu như của bạn với cái suy nghĩ ai biết viết lisp thì mọi lĩnh vực chỉ cần nhá xèng cái video cái là viết theo được ngay thì bạn sẽ chờ đến muôn thu trừ khi cái người viết lisp làm cùng lĩnh vực với bạn.
-Còn cái tác giả theo như bạn nói cũng là mem của cadviet đấy thì phải.
-Kết quả của việc viết theo yêu cầu trước tết của mình là không thành mặc dù người yêu cầu ngồi bên cạnh mình nhưng vẩn ko giải thích được là mình phải làm gì. Vì trong dữ liệu nhập có chiều cao máy và chiều cao gương thì ko giải thích được nó tham gia vào việc tính toán như nào.
-Cái không thành phẩm của trước tết nó như này. Lệnh là xuatgoc
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:s_radian>do (gt / gt kq)
(setq kq (* (/ 180 pi) gt))
kq)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:3d>2d (diemtinh / diemtinh)
(setq diembet (list (car diemtinh) (cadr diemtinh)))
diembet)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:3point>gocnam (diemgoch diemdinhhuongh diemxacdinhh / diemgoch diemdinhhuongh diemxacdinhh gocnamh)
(setq gocnamh (- (angle (duy:3d>2d diemgoch) (duy:3d>2d diemxacdinhh)) (angle (duy:3d>2d diemgoch) (duy:3d>2d diemdinhhuongh)) ) )
(setq gocnamh (duy:s_radian>do gocnamh))
gocnamh)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:3point>gocdung (diemgoch diemdinhhuongh diemxacdinhh / diemgoch diemdinhhuongh diemxacdinhh gocdungh)
(setq diemgocnam ( duy:3d>2d diemgoch))
(setq diemdinhhuongnam ( duy:3d>2d diemdinhhuongh))
(setq diemxacdinhnam ( duy:3d>2d diemxacdinhh))
(setq kcgocdinhhuong (distance diemgocnam diemdinhhuongnam))
(setq kcgocgoc (distance diemgocnam diemgocnam))
(setq kcgocxacdinh (distance diemgocnam diemxacdinhnam))
(setq diemgocdung (list kcgocgoc (caddr diemgoch) ))
(setq diemxacdinhdung (list kcgocxacdinh (caddr diemxacdinhh) ))
(setq diemdinhhuongdung (list kcgocdinhhuong (caddr diemdinhhuongh) ))
(setq gocdungh (- (angle diemgocdung diemdinhhuongdung) (angle diemgocdung diemxacdinhdung)))
(setq gocdungh (duy:s_radian>do gocdungh))
(cond
((> gocdungh 90) (setq gocdungh (- 90 gocdungh) ))
((< gocdungh 90) (setq gocdungh (- 90 gocdungh) ))
)
gocdungh)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:point>dongnd (diemgoc diemdinhhuong diemxacdinh / diemgoc diemdinhhuong diemxacdinh)
(setq gocnam (rtos (duy:3point>gocnam diemgoc diemdinhhuong diemxacdinh) 2 6))
;(setq gocnam (rtos (duy:s_radian>do (- (angle (duy:3d>2d diemgoc) (duy:3d>2d diemdinhhuong)) (angle (duy:3d>2d diemgoc) (duy:3d>2d diemxacdinh)))) 2 6) )
(setq gocdung (rtos (duy:3point>gocdung diemgoc diemdinhhuong diemxacdinh) 2 6))
(setq kcxien (rtos (distance diemgoc diemxacdinh) 2 2))
(setq nddong (strcat gocnam dauphancach gocdung dauphancach kcxien))
nddong)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:xuatgoc ()
(command "undo" "be")
(setq dauphancach ",")
(setq cdiemgoc (getpoint "\nChon diem goc:"))
(setq tdiemgoc (getstring "\nNhap ten diem goc:"))
(setq cdiemdinhhuong (getpoint "\nChon diem dinh huong:"))
(setq tdiemdinhhuong (getstring "\nNhap ten diem dinh huong:"))
(setq docaoguong (getstring "\nNhap do cao guong:"))
(princ "\nChon cac diem can tinh toan")
(setq tapdiemchon (ssget (list (cons 0 "POINT"))))
(setq vitrifiledulieu (getfiled "File xuat du lieu " "" "csv" 1))
(setq nddong1 (strcat tdiemgoc dauphancach (rtos (car cdiemgoc) 2 4) dauphancach (rtos (cadr cdiemgoc) 2 4) dauphancach (rtos (caddr cdiemgoc) 2 4) dauphancach tdiemgoc))
(setq nddong2 (strcat tdiemdinhhuong dauphancach (rtos (car cdiemdinhhuong) 2 4) dauphancach (rtos (cadr cdiemdinhhuong) 2 4) dauphancach (rtos (caddr cdiemdinhhuong) 2 4) dauphancach tdiemdinhhuong))
(setq filedulieu (open vitrifiledulieu "w"))
(write-line nddong1 filedulieu)
(write-line nddong2 filedulieu)
(write-line "" filedulieu)
(write-line (strcat "stt" dauphancach "goc nam" dauphancach "gocdung" dauphancach "kcxien" dauphancach "Cao guong") filedulieu)
(setq stt 0)
(setq sodiem (sslength tapdiemchon))
(while (< stt sodiem)
(setq diemdocduoc (cdr (assoc 10 (entget (ssname tapdiemchon stt)))))
(setq nddongn (duy:point>dongnd cdiemgoc cdiemdinhhuong diemdocduoc))
(write-line (strcat (rtos (+ stt 1) 2 0) dauphancach nddongn dauphancach docaoguong) filedulieu)
(setq stt (+ stt 1))
)
(close filedulieu)
(command "undo" "end")
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(princ "\nLenh xuatgoc dung xuat tu XYZ sang goc")
https://www.youtube.com/watch?v=DbEuITh3JTw
TẠI SAO GÓC LẠI BỊ ÂM, NÓ CHỈ LÀM TRÒN 2 SỐ LẺ, KO LÀM TRÒN 3 SỐ LẺ ĐƯỢC À? KC XIÊN CŨNG CHÍNH LÀ KC NGANG!!!
THANKS
<<
|
Filename: 403569_xuatgoc.lsp
|
|
Tác giả: Doan Van Ha
Bài viết gốc: 440027
Tên lệnh: ha |
Lisp copy nhiều text được chọn cộng hoặc trừ 1 số bất kỳ
Xài tạm code này, chưa sửa code chođẹp.
(defun C:HA(/ del ss p1 p2 i obj ed)
(setq del (getreal "\Nhap gia tri can tang/giam: "))
(princ "\nChon cac Text/Mtext...")
(setq ss (ssget '((0 . "*text"))))
(setq p1 (getpoint "\nDiem chuan: "))
(setq p2 (getpoint p1 "\nDiem den: "))
(repeat (setq i (sslength ss))
(vla-copy (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
(vla-move (vlax-ename->vla-object (entlast))...
>>
Xài tạm code này, chưa sửa code chođẹp.
(defun C:HA(/ del ss p1 p2 i obj ed)
(setq del (getreal "\Nhap gia tri can tang/giam: "))
(princ "\nChon cac Text/Mtext...")
(setq ss (ssget '((0 . "*text"))))
(setq p1 (getpoint "\nDiem chuan: "))
(setq p2 (getpoint p1 "\nDiem den: "))
(repeat (setq i (sslength ss))
(vla-copy (vlax-ename->vla-object (ssname ss (setq i (1- i)))))
(vla-move (vlax-ename->vla-object (entlast)) (vlax-3d-point p1) (vlax-3d-point p2))
(setq ed (entget (entlast)))
(entmod (subst (cons 1 (rtos (+ (atof (cdr (assoc 1 ed))) del) 2 2)) (assoc 1 ed) ed)))
(princ))
(vl-load-com)
<<
|
Tác giả: duy782006
Bài viết gốc: 440010
Tên lệnh: vcnk |
Xin lisp vẽ hình chữ nhật với lỗ khoét.
Lệnh là VCNK.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:t_rectang (diema diemb dorong tl stl La Co)
(setq toado (list diema (list (car diema) (cadr diemb)) diemb (list (car diemb) (cadr diema)) ))
(cond ((= la "") (setq la (getvar "Clayer")) ))
(cond ((= co "") (setq co 256) ))
(cond ((= tl "") (setq tl "bylayer") ))
(cond ((= stl "") (setq stl 1)...
>>
Lệnh là VCNK.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duy:t_rectang (diema diemb dorong tl stl La Co)
(setq toado (list diema (list (car diema) (cadr diemb)) diemb (list (car diemb) (cadr diema)) ))
(cond ((= la "") (setq la (getvar "Clayer")) ))
(cond ((= co "") (setq co 256) ))
(cond ((= tl "") (setq tl "bylayer") ))
(cond ((= stl "") (setq stl 1) ))
(setq Lst
(list
(cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 8 la)
(cons 6 tl)
(cons 48 stl)
(cons 62 co)
(cons 100 "AcDbPolyline")
(cons 43 dorong)
(cons 90 4)
(cons 70 1)))
(setq x 0)
(repeat 4
(setq Lst (append Lst (list (cons 10 (nth x toado)) )))
(setq x (1+ x)))
(entmakex Lst)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:vcnk ()
(setq gocduoi (getpoint "\nDiem duoi ben trai hinh chu nhat lon"))
(setq rong (getreal "\nDo rong: "))
(setq cao (getreal "\nDo cao: "))
(setq goctren (list (+ (car gocduoi) rong) (+ (cadr gocduoi) cao)))
(duy:t_rectang gocduoi goctren 0 "" "" "" "")
(while (setq xgocmoi (getreal "\nKhoang cach lo khoet tu trai sang <Enter de ket thuc>: "))
(setq ygocmoi (getreal "\nKhoang cach lo khoet tu duoi len: "))
(setq gocduoim (list (+ (car gocduoi) xgocmoi) (+ (cadr gocduoi) ygocmoi)))
(setq rong (getreal "\nDo rong lo khoet: "))
(setq cao (getreal "\nDo cao lo khoet: "))
(setq goctrenm (list (+ (car gocduoim) rong) (+ (cadr gocduoim) cao)))
(duy:t_rectang gocduoim goctrenm 0 "" "" "" "")
)
(princ))
<<
|
Filename: 440010_vcnk.lsp
|
|
Tác giả: tientracdia
Bài viết gốc: 418275
Tên lệnh: kkp |
Đo khoảng cách hai điểm và ghi kết quả ra nơi minh chọn
- hi bạn thông cảm, sáng giờ bị sếp dí chưa kip sữa cho bạn ^^, giờ mới rãnh xem, bạn xem nhoc sữa vậy vừa ý chưa...
>>
- hi bạn thông cảm, sáng giờ bị sếp dí chưa kip sữa cho bạn ^^, giờ mới rãnh xem, bạn xem nhoc sữa vậy vừa ý chưa hì :P
;===============================================================================================================
(defun K:style (MyStyle MyFont)
(entmake (list (cons 0 "STYLE")
(cons 100 "AcDbSymbolTableRecord")
(cons 100 "AcDbTextStyleTableRecord")
(cons 2 MyStyle) (cons 3 MyFont)
(cons 70 0))))
;;;;;
;============================
;;--------------------------------------
(defun K:layer (ten clr)
(if (null (tblsearch "LAYER" ten))
(entmakex (list
'(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
'(70 . 0)
(cons 2 ten)
(cons 62 clr))
)
)
)
;;;;;;;;;;-------------------------------------------
;;;;;;;;;;;============================================================
(defun Makepline (listpoint closed Layer Linetype LTScale xdata / Lst)
(setq Lst (list '(0 . "LWPOLYLINE")'(100 . "AcDbEntity")
(cons 8 (if Layer Layer (getvar "Clayer")))
(cons 6 (if Linetype Linetype "bylayer"))
(cons 48 (if LTScale LTScale 1))
'(100 . "AcDbPolyline")
(cons 90 (length listpoint))
(cons 70 (if closed 1 0))))
(foreach PP listpoint (setq Lst (append Lst (list (cons 10 PP)))))
(if xdata (setq Lst (append lst (list (cons -3 (list xdata))))))
(entmakex Lst))
;end;=================================
;;;
(defun MakeLine (PT1 PT2 Layer Linetype LTScale xdata)
(entmakex (list '(0 . "LINE")
(cons 8 (if Layer Layer (getvar "Clayer")))
(cons 6 (if Linetype Linetype "bylayer"))
(cons 48 (if LTScale LTScale 1))
(cons 10 PT1) (cons 11 PT2)
(cons -3 (if xdata (list xdata) nil)))))
;;;;;;--------------------------------------------------------------------------------------------
;ham tao text 2
(defun taotext (point height string justify layer textstyle mau / lst)
(setq lst (list '(0 . "TEXT")
(cons 10 point)
(cons 40 height)
(cons 1 string)
(cons 8 (if layer layer (getvar "clayer")))
(cons 7 (if textstyle textstyle (getvar 'textstyle)))
(cons 62 (if mau mau 256))
)
justify (strcase justify))
(cond ((= justify "L") (setq Lst (append Lst (list (cons 72 0) (cons 11 point)))))
((= justify "C") (setq Lst (append Lst (list (cons 72 1) (cons 11 point)))))
((= justify "R") (setq Lst (append Lst (list (cons 72 2) (cons 11 point)))))
((= justify "M") (setq Lst (append Lst (list (cons 72 4) (cons 11 point)))))
)
(entmakex Lst)
);end mktext
;--------------------------------------
(alert "LSP xuat bang thong ke goc canh , lenh: KKP")
;;----------------------------------------------------------------------------------------------
(defun c:kkp(/ ss ename lst lstcanh lstgoc dem p1 p2 p3 d ang1 ang2 goc kdo dau i k m f j pt1 pt2 pt3 pt4 pt5 pt6 pt7 pt8 pt9 goc270 pt tt ll gg ptt pll pgg old canh kgoc)
(vl-load-com)
(setq old (getvar 'osmode))
(setvar 'osmode 0)
(if (null (tblsearch "style" "ARIAL-bang")) (K:style "ARIAL-bang" "arial.ttf"))
(K:layer "bang-goccanh" 4)
(prompt "chon PLine:")
(setq ss (ssget "+.:E:S" '((0 . "*POLYLINE"))))
(if ss
(progn
;--------------------------------------------------------------------
(setq ename (ssname ss 0))
(setq lst (acet-geom-vertex-list ename))
(setq lstcanh nil
lstgoc nil)
;================================================
(setq p1 (car lst)
dem 1)
;===============================================================
(while (< dem (length lst))
(setq p2 (nth dem lst))
(setq d (distance p1 p2))
(setq lstcanh (append lstcanh (list d)))
(setq p1 p2
dem (1+ dem))
(princ)
)
(setq bdau 1)
(foreach x lst
(taotext (polar x (/ pi 2) 0.5) 0.8 (itoa bdau) "M" "bang-goccanh" "ARIAL-bang" 1)
(setq bdau (1+ bdau))
)
;==================================================================================
(setq p1 (car lst)
dem 1)
;===============================================================================
(while (< dem (1- (length lst)))
(setq p2 (nth dem lst))
(setq p3 (nth (1+ dem) lst))
(setq ang1 (angle p2 p1)
ang2 (angle p2 p3))
(setq goc (abs (- ang1 ang2)))
(if (> goc PI)
(setq goc (- (* 2 pi) goc))
)
;================================================================================
(setq kdo (* (/ goc pi) 180.0))
(setq lstgoc (append lstgoc (list kdo)))
;====================================================================================
(setq p1 p2
dem (1+ dem))
)
;========================================================================================
(setq pt (getpoint "\nChon diem dat bang:"))
(if (/= pt nil)
(progn
(setq pt1 (mapcar '+ pt (list 45.0 0.0 0.0))
pt2 (mapcar '+ pt (list 0.0 -4.0 0.0))
pt3 (mapcar '+ pt (list 45.0 -4.0 0.0))
pt4 (mapcar '+ pt (list 5.0 0.0 0.0))
pt5 (mapcar '+ pt (list 25.0 0.0 0.0)))
;--------------------------------------------------
(taotext (mapcar '+ pt (list 2.5 -2.0 0.0)) 1.8 "TT" "M" "bang-goccanh" "ARIAL-bang" nil)
(taotext (mapcar '+ pt (list 15.0 -2.0 0.0)) 1.8 "L" "M" "bang-goccanh" "ARIAL-bang" nil)
(taotext (mapcar '+ pt (list 35.0 -2.0 0.0)) 1.8 "GOC" "M" "bang-goccanh" "ARIAL-bang" nil)
(makeline pt2 pt3 nil nil nil nil)
;-----------------------------------------------------
(setq i 1)
(while (<= i (length lst))
(progn
;--------------------------
(setq tt (list 2.5 (- (* -5.0 i) 2.0) 0.0))
(setq ptt (mapcar '+ pt tt))
;--------------------------------
;------------------------------
(taotext ptt 1.8 (itoa i) "M" nil nil 4)
(setq i (1+ i))
)
) ; end while
;===============================================
(setq k 0 m 1)
(repeat (- (length lst) 1)
(setq ll (list 15.0 (- (* -5.0 m) 4.5) 0.0))
(setq pll (mapcar '+ pt ll))
(setq canh (nth k lstcanh))
(taotext pll 1.8 (rtos canh 2 3) "M" "bang-goccanh" "ARIAL-bang" nil)
(setq m (1+ m))
(setq k (1+ k))
)
;==============================================
(setq f 0 j 1)
(repeat (- (length lst) 2)
(setq gg (list 35.0 (- (* -5.0 j) 7.0) 0.0))
(setq pgg (mapcar '+ pt gg))
(setq kgoc (nth f lstgoc))
(taotext pgg 1.8 (chuyendo kgoc) "M" "bang-goccanh" "ARIAL-bang" nil)
(setq f (1+ f))
(setq j (1+ j))
)
;----------------------------------------
(setq goc270 (- 0 (/ PI 2)))
(setq pt6 (polar pt goc270 (+ 4 (+ (* 5.0 (length lst)) 3.0)))
pt7 (polar pt1 goc270 (+ 4 (+ (* 5.0 (length lst)) 3.0)))
pt8 (polar pt5 goc270 (+ 4 (+ (* 5.0 (length lst)) 3.0)))
pt9 (polar pt4 goc270 (+ 4 (+ (* 5.0 (length lst)) 3.0))))
(makeline pt4 pt9 nil nil nil nil)
(makeline pt5 pt8 nil nil nil nil)
(makepline (list pt pt1 pt7 pt6) 1 nil nil nil nil)
;=============================================
) ;end progn if
) ; end if pt
); end progn ss
(alert "ban chua chon Pline nao")
) ;end if ss
;========================================================================================
(alert "Xong ^^")
(setvar 'osmode old)
(princ)
); end Kkp
;===================================================================================
;========================chuyen sang do phut giay
(defun chuyendo(so / done kphgiay kphut kgiay xong)
(setq done (fix so))
(setq kphgiay (* (- so done) 60)) ;14,76
(setq kphut (fix kphgiay)) ; 14
(setq kgiay (rtos (* (- kphgiay kphut) 60) 2 0)) ;46"
(setq xong (strcat (itoa done) "%%d" (itoa kphut) "'" kgiay "''"))
)
BẠN CÓ THỂ BỔ SUNG VẺ GÓC CẠNH TRÊN SƠ ĐỒ LƯỚI THÌ TUYỆT LUÔN
<<
|
Tác giả: Doan Nguyen Van
Bài viết gốc: 440095
Tên lệnh: te |
Nhờ viết LISP gán Contents
6 phút trước, Binhphuong198 đã nói:
6 phút trước, Binhphuong198 đã nói:
Đúng chuẩn luôn bạn ạ! Bạn có thể gửi cho mình xin LISP được ko? Cảm ơn bạn trước nhé
(defun c:te (/ ent1 ent2 oid1 cnt)
(setq ent1 (car (entsel "\npick text nguon"))
ent2 (car (Entsel "\npick text dich")))
(vla-put-textstring (vlax-ename->vla-object ent2) (strcat "%<\\AcObjProp Object(%<\\_ObjId " (itoa (vla-get-ObjectID (vlax-ename->vla-object ent1))) ">%).TextString>%")))
Cái này sử dụng text thì được, chứ Mtext thì thấy hơi lỗi
<<
|
Tác giả: tien2005
Bài viết gốc: 440126
Tên lệnh: test1 |
Nhờ các anh e trong diễn đàn sửa giúp lips
Đây nhé
(defun c:test1 (/ ss)
(vl-load-com)
(if (setq ss (ssget (list (cons 0 "*LINE,ARC,CIRCLE,ELLIPSE"))))
(foreach pt (getSS_Inter ss)
;;; (entmake (list (cons '0 "POINT") (cons '10 pt)))
(entmake (list (cons '0 "CIRCLE")
(cons '10 pt)
(cons '40 10)
(cons '8 "0")
) ;_ end of list
) ;_ end of entmake
) ;_ end of foreach
) ;_ end of if
...
>>
Đây nhé
(defun c:test1 (/ ss)
(vl-load-com)
(if (setq ss (ssget (list (cons 0 "*LINE,ARC,CIRCLE,ELLIPSE"))))
(foreach pt (getSS_Inter ss)
;;; (entmake (list (cons '0 "POINT") (cons '10 pt)))
(entmake (list (cons '0 "CIRCLE")
(cons '10 pt)
(cons '40 10)
(cons '8 "0")
) ;_ end of list
) ;_ end of entmake
) ;_ end of foreach
) ;_ end of if
(princ)
) ;_ end of defun
(defun giao (ob1 ob2 / inter_lst iplist)
(if (not
(vl-catch-all-error-p
(setq
iplist (vl-catch-all-apply
'vlax-safearray->list
(list (vlax-variant-value
(vla-IntersectWith ob1 ob2 acExtendNone)
) ;_ end of vlax-variant-value
) ;_ end of list
) ;_ end of vl-catch-all-apply
) ;_ end of setq
) ;_ end of vl-catch-all-error-p
) ;_ end of not
(progn
(while (setq inter_lst (cons
(list (car iplist) (cadr iplist) (caddr iplist))
inter_lst
) ;_ end of cons
iplist (cdddr iplist)
) ;_ end of setq
) ;_ end of while
(reverse inter_lst)
) ;_ end of progn
) ;_ end of if
) ;_ end of defun
(defun getSS_Inter (ss / e giao_lst i lst obj tmp_lst)
(setq i -1)
(while (setq e (ssname ss (setq i (1+ i))))
(setq lst (cons (vlax-ename->vla-object e) lst))
) ;_ end of while
(repeat (1- (vl-list-length lst))
(setq obj (car lst))
(foreach ob1 (setq lst (vl-remove obj lst))
(if (setq tmp_lst (giao ob1 obj))
(foreach pt tmp_lst
(if (not (vl-position pt giao_lst))
(setq giao_lst (cons pt giao_lst))
) ;_ end of if
) ;_ end of foreach
) ;_ end of if
) ;_ end of foreach
) ;_ end of repeat
giao_lst
) ;_ end of defun
<<
|
Filename: 440126_test1.lsp
|
|
Tác giả: vanmanh192hd
Bài viết gốc: 408582
Tên lệnh: test |
Giúp Đỡ [Lisp] Tự Động Vẽ Đầu Mũi Khoan
Mềnh chả biết mũi khoan là gì nhưng thấy bài toàn giải hay hay nên nghịch chơi. Thử lisp này nhé. ^_^
;;;Found...
>>
Mềnh chả biết mũi khoan là gì nhưng thấy bài toàn giải hay hay nên nghịch chơi. Thử lisp này nhé. ^_^
;;;Found Internet
(defun Point_per (P1 P2 P3 / X1 X2 X3 Y1 Y2 Y3 Z1 Z2 Z3 T4)
(setq X1 (car P1)
X2 (car P2)
X3 (car P3)
Y1 (cadr P1)
Y2 (cadr P2)
Y3 (cadr P3)
Z1 (caddr P1)
Z2 (caddr P2)
Z3 (caddr P3)
T4 (/ (+ (* (- X2 X1) (- X3 X1))
(* (- Y2 Y1) (- Y3 Y1))
(* (- Z2 Z1) (- Z3 Z1))
)
(+ (* (- X2 X1) (- X2 X1))
(* (- Y2 Y1) (- Y2 Y1))
(* (- Z2 Z1) (- Z2 Z1))
)
)
)
(list (+ X1 (* T4 (- X2 X1)))
(+ Y1 (* T4 (- Y2 Y1)))
(+ Z1 (* T4 (- Z2 Z1)))
)
)
;;;My funtions
(defun ve_mui_khoan ( / a p10 p11 pt pt1 pt2 pt_0)
(setq a (car (entsel "\nChon doan thang: ")))
(if a
(progn
(setq p10 (cdr (assoc 10 (entget a))))
(setq p11 (cdr (assoc 11 (entget a))))
(setq pt (polar p10 (angle p10 p11) (/ (distance p10 p11) 2)))
(setq pt1 (getpoint "\nChon diem bat ky: "))
(setq pt2 (Point_per p10 p11 pt1))
(setq pt_0 (polar pt
(angle pt2 pt1)
(/ (* (distance p10 p11) (sqrt 3)) 6)
)
)
(command "_polygon" "3" "_none" pt_0 "I" p10)
)
)
)
(defun ve_lo_khoan (/ p1 p2 d p3 p4 p5 p6 p7 ang)
(setq p1 (getpoint "\nChon diem 1: "))
(setq p2 (getpoint p1 "\nChon diem 2: "))
(setq d (getreal "\nChon duong kinh: "))
(setq p3 (polar p1 (+ (setq ang (angle p1 p2)) (* pi 0.5)) (/ d 2))
p4 (polar p3 (+ ang (* pi 1.5)) d)
p5 (polar p4 ang (distance p1 p2))
p6 (polar p5 (+ ang (* pi 0.5)) d)
p7 (polar p2 (angle p1 p2) (/ (* d (sqrt 3)) 6))
)
(command "line" "_non" p3 "_non" p4 "_non" p5 "_non" p6 "_non" p3 ""
"line" "_non" p6 "_non" p7 "_non" p5 "")
)
(defun c:test ()
(initget 1 "M L ")
(setq ob (getkword "\nChon ve mui khoan hoac ve lo khoan : "))
(cond
((= ob "M")
(ve_mui_khoan)
)
((= ob "L")
(ve_lo_khoan)
)
);#cond
(princ)
)
Lệnh test nhé.
Mình xin lỗi vì đã viết là góc tạo mũi khoan là 60 độ
nó là 120 độ
cảm ơn bạn rất nhiều
<<
|
Filename: 408582_test.lsp
|
|
Tác giả: Bee
Bài viết gốc: 440258
Tên lệnh: test |
Nhờ viết lisp delete dimension có giá trị bằng 0 ( measurement =0)
1 giờ trước, jangboko đã nói:
Mình có 1 vấn đề nhờ a e trên...
>>
1 giờ trước, jangboko đã nói:
Mình có 1 vấn đề nhờ a e trên diễn đàn giúp với. Mình sử dụng lệnh Qdim ( cad minh 2020, chắc lệnh này cad đời cao mới có) nên nó xuất hiện vài dimension có giá trị bằng 0 ( measurement =0). Và click từng cái để delete đi thì lâu, dùng lệnh FI thì không lọc được đối tượng đó.
- Mình muốn delete các dimension có giá trị bằng 0 đó 1 cách nhanh nhất. ( gõ lệnh 1 phát là nó tự chọn các dimension có giá trị bằng 0, chỉ việc delete đi thôi ạ )
- Cảm ơn a e/ ( p/s: nếu lisp này đơn giản thì cho mình xin, còn nếu phức tạp thì mình xin gửi mấy cốc cafe )
Đang cafe rảnh code cho bạn không biết ok không ? Chủ thớt test nhé.
(defun c:test (/)
(vl-load-com)
(vlax-for x (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
(if (and
(member (vla-get-ObjectName x) '("AcDbRotatedDimension"))
(= (vla-get-measurement x) 0.0)
)
(vla-delete x)
)
)
)
<<
|
Filename: 440258_test.lsp
|
|
Tác giả: Danh Cong
Bài viết gốc: 440265
Tên lệnh: dc | |
Tác giả: phamthanhbinh
Bài viết gốc: 235996
Tên lệnh: vht |
Code lisp như thế nào để hạn chế lỗi cho người dùng?
Tạm gác ví dụ vẽ HCN ở trên (trong khi chờ mọi người bổ...
>>
Tạm gác ví dụ vẽ HCN ở trên (trong khi chờ mọi người bổ sung), hãy tìm cách bẫy lỗi lisp vẽ đường tròn dưới đây. Điều kiện: hễ mỗi lần gọi lệnh bắt buộc phải có 1 đường tròn được vẽ.
(defun C:VHT( / p r) (setq p (getpoint "\nSpecify center point for circle: ")) (setq r (getreal "\nSpecify radius of circle: ")) (command ".circle" "non" p r) (princ))
Hề hề hề,
Hoan nghênh bác DoanVanHa đưa ra chủ đề hết sức thiết thực này.
Thực tế bản thân tui, do cái sự mót nên kiền thức còn cọc cạch chắp vá nên hầu như không bao giờ nghĩ tới vấn đề bẫy lỗi này mà chi nhăm nhăm làm sao cho nó chạy được. Trong quá trình viết lisp đã nhiều lần dính đòn do việc bẫy lỗi này không có.. Tuy nhiên do kiến thức mót được còn lỗ mỗ nên chưa thể nào tự mình khắc phục được mà thường là phải nhờ các bác trên diễn đàn chỉ giáo.
Với suy nghĩ cá nhân của tui thì cái lisp vẽ vòng tròn có thể dính lỗi khi diểm tâm p và bán kinh r không được xác định. Tỷ như người dùng không pick điểm p mà nhấn enter hay esc luôn, hoặc không nhập giá trị bán kính mà nhấn enter luôn.
Vậy nên tui liều mạng sửa bẫy lỗi như vầy, trúng hay trật nhờ các bác đèn giời soi tỏ:
(defun C:VHT( / p r) (while (not p) (setq p (getpoint "\nSpecify center point for circle: "))) (while (or (not r) (equal r 0.0 0.00001)) (setq r (getreal "\nSpecify radius of circle: "))) (command ".circle" "non" p r) (princ))
<<
|
Tác giả: gamo86
Bài viết gốc: 161537
Tên lệnh: ttt |
lip tính khối lượng thể tích vật liệu
Bạn thử đoạn code, Tue_NV mới viết :
(defun c:ttt(/ e1 e2 tile s1 s2 Res text)
(defun gb( / ss from to cur)
(setq frome...
>>
Bạn thử đoạn code, Tue_NV mới viết :
(defun c:ttt(/ e1 e2 tile s1 s2 Res text)
(defun gb( / ss from to cur)
(setq frome (entlast)) ;; chon doi tuong cuoi cung truoc khi boundary
(command ".boundary" pause "") ;; boundary
(setq toe (entlast)) ;; chon doi tuong cuoi cung sau khi boundary
(setq cur frome ; khoi tao
ss (ssadd)
)
(while (not (eq cur toe)) ;; chon cac doi tuong tu frome den toe
(setq
cur (entnext cur)
ss (ssadd cur ss)
)
)
(sssetfirst ss ss) ;; highlight ket qua
ss
)
;Main
(princ "chon 1 diem trong hinh thu nhat") (setq e1 (gb))
(princ "chon 1 diem trong hinh thu hai") (setq e2 (gb))
(setq dis (getdist "\n Nhap chieu dai hoac Pick 2 diem tren man hinh lam chieu dai :"))
(or *tile* (setq *tile* 1.0))
(setq tile (getreal (strcat "\n Nhap he so ti le < " (rtos *tile* 2 3) " > ")))
(if tile (setq *tile* tile) (setq tile *tile*))
(Command "area" "o" e1)
(setq s1 (getvar "area"))
(Command "area" "o" e2)
(setq s2 (getvar "area"))
(command "erase" e1 e2 "")
(setq Res (* (/ (+ s1 s2) 2.0) dis tile tile tile))
(setq text (entget(car(entsel "\n pick Text thay the"))))
(entmod (subst (cons 1 (rtos Res 2 2)) (assoc 1 text) text))
)
Chú ý : trước khi chạy Lisp, bạn phải joint các Arc và Pline thành 1 đối tượng kín
bác tuệ ơi em dùng cái của bác nhưng lại bị thế này là sao bác nhỉ
BOUNDARY created 1 polyline
Command: ; error: bad argument type: lselsetp nil
em đã nối lại rồi đấy thành đa tuyến kín rồi
<<
|
Tác giả: hhhhgggg
Bài viết gốc: 49843
Tên lệnh: 0 |
Lisp đổi kiểu nét của Layer bị lỗi trên CAD 2004 với 1 số bản vẽ có định dạng khác !!! Nhờ sửa giúp !
LISP của bạn bị lỗi khi dùng lệnh chprop kết hợp với chọn đối tượng bằng ssget "X". Thực ra lệnh chprop >>
LISP của bạn bị lỗi khi dùng lệnh chprop kết hợp với chọn đối tượng bằng ssget "X". Thực ra lệnh chprop chỉ cho phép chọn đối tượng trên TAB (Model hay Layout) hiện hành.
trong khi đó (ssget "X" (list (cons 8 "Plinetntn"))) sẽ trả về các đối tượng trên toàn bộ TAB(Model, catdoc, catngang,...) thuộc lớp Plinetntn -> lệnh chprop bị lỗi.
Cách khắc phục :
1.Chỉ chọn đối tượng trên TAB (Model hay Layout) hiện hành thuộc lớp Plinetntn
(ssget "X" (list (cons 410 (getvar "ctab"))(cons 8 "Plinetntn")))
Cách này có nhược điểm là phải thực hiện LISP lần lượt trên từng TAB(Model, catdoc, catngang,...) nhưng dễ kiểm soát hơn.
2.Vẫn sử dụng (ssget "X" (list (cons 8 "Plinetntn"))) để chọn các đối tượng trên toàn bộ TAB(Model, catdoc, catngang,...) thuộc lớp Plinetntn, sau đó dùng hàm EntMod để cập nhật Database cho các đối tượng này.
Ưu điểm là chỉ cần chạy LISP một lần (nhanh gọn) nhưng theo ý tui thì khó kiểm soát (không an toàn), bạn thử viết theo hướng này nhé.
Ngoài ra trong LISP của bạn có dòng lệnh :
(Command "layer" "m" "Plinetntn" "L" "Hidden2" "" "")
-> thay đổi Linetype của lớp Plinetntn thành Hidden2.
Điều này chỉ có tác dụng khi các đối tượng trên lớp Plinetntn được Set ở ByLayer.
Một thắc mắc nhỏ : Thông thường User vẽ các đối tượng trên Model sau đó dùng Layout để xuất bản vẽ (ploting) theo tỉ lệ mong muốn. Bản vẽ của bạn lại thực hiện trên Layout.
Hy vọng Lisp này đúng nhu cầu của bạn.
(defun c:0 (/ LayName curLay dt)
(setq LayName (getstring "Nhap ten layer can thay doi kieu net :"))
(if (tblsearch "layer" LayName)
(progn
(setq curLay (getvar "clayer"))
(Command "layer" "m" LayName "L" "Hidden2" "" "")
;(prompt "\nChon doi tuong: ")
(if (setq dt (ssget "X" (list (cons 410 (getvar "ctab"))(cons 8 LayName))))
(command "chprop" dt "" "s" "2" "lt" "ByLayer" "")
(alert (strcat "Khong co doi tuong tren layer "LayName " !"))
)
(setvar "clayer" curLay)
)
(alert (strcat "Chua co Layer : " LayName " !"))
)
(princ)
)
ko được bác à ? Bác xem test lại cho em cái, vẫn báo lỗi như cũ. Vấn đề là cái định dạng của bản vẽ nữa. Với lại em muốn cái tên layer là mặc định có sẵn từ trước rùi chứ ko phải là do người dùng nhập vào. Như vậy mới đẩy nhanh tốc độ được !
<<
|
Tác giả: hhhhgggg
Bài viết gốc: 49871
Tên lệnh: 0 |
Lisp đổi kiểu nét của Layer bị lỗi trên CAD 2004 với 1 số bản vẽ có định dạng khác !!! Nhờ sửa giúp !
Test trên Cad 2004 và Cad2008 file Km339.dwg với layer Thnhien đều OK. Thực sự tui không hiểu bạn bị lỗi gì.
LISP sửa lại theo tên mặc...
>>
Test trên Cad 2004 và Cad2008 file Km339.dwg với layer Thnhien đều OK. Thực sự tui không hiểu bạn bị lỗi gì.
LISP sửa lại theo tên mặc định có sẵn từ trước ("Thnhien").
(defun c:0 (/ LayName curLay dt)
;(setq LayName (getstring "Nhap ten layer can thay doi kieu net : <Thnhien>"))
;(if (= LayName "") (setq LayName "Thnhien" ))
(setq LayName "Plinetntn" )
(if (tblsearch "layer" LayName)
(progn
(setq curLay (getvar "clayer"))
(Command "layer" "m" LayName "L" "Hidden2" "" "")
;(prompt "\nChon doi tuong: ")
(if (setq dt (ssget "X" (list (cons 410 (getvar "ctab"))(cons 8 LayName))))
(command "chprop" dt "" "s" "2" "lt" "ByLayer" "")
(alert (strcat "Khong co doi tuong tren layer "LayName " !"))
)
(setvar "clayer" curLay)
)
(alert (strcat "Chua co Layer : " LayName " !"))
)
(princ)
)
ok ! Lần này thì ok Thật. Cảm ơn bác nhiều nhé !
<<
|
Tác giả: phamthe
Bài viết gốc: 306192
Tên lệnh: o2l |
lisp chuyển các đối tượng về 1 layer
Lisp O2L (Object to layer) dưới đây sẽ giúp bạn. Nếu bạn muốn chuyển các đối tượng khác, bạn hãy copy rồi thêm dòng lệnh (cons...
>>
Lisp O2L (Object to layer) dưới đây sẽ giúp bạn. Nếu bạn muốn chuyển các đối tượng khác, bạn hãy copy rồi thêm dòng lệnh (cons "KIEUDOITUONG" "TENLAYER") vào cụm các lệnh cons phía dưới.
(defun c:o2l ( / ss pp lstoblayer) (setq lstoblayer (list (cons "DIMENSION" "DIM") ; chuyen doi tuong Dimension ve layer DIM (cons "HATCH" "HATCH") (cons "INSERT" "BLOCK") ; BLOCK (la doi tuong insert) ve layer BLOCK (cons "*TEXT" "TEXT") ; TEXT va MTEXT ve layer text ) ) (foreach pp lstoblayer (setq ss (ssget "X" (list (cons 0 (car pp))))) (if (not (tblsearch "layer" (cdr pp))) (command ".layer" "m" (cdr pp) "") ) (command ".chprop" ss "" "la" (cdr pp) "") ) (princ))
các bác cho em hỏi nếu muốn đổi tên Layer A sang tên Layer B trong code này thì làm thế nào nhỉ?
<<
|
Tác giả: Tue_NV
Bài viết gốc: 208969
Tên lệnh: gf |
Lisp tìm và thay thế nhiều text cùng lúc.
:)
(defun c:gf(/ e ass j lst doc f file)
(vl-load-com)
(while (not (setq file (getfiled "Chon file txt :" "" "txt" 0))) )
(cond ((setq ss...
>>
:)
(defun c:gf(/ e ass j lst doc f file)
(vl-load-com)
(while (not (setq file (getfiled "Chon file txt :" "" "txt" 0))) )
(cond ((setq ss (ssget '((0 . "*TEXT"))) f (open file "r") j -1)
(while (setq doc (read-line f))
(setq lst (cons (apply 'cons (mapcar 'vl-princ-to-string (read (strcat "(" doc ")")))) lst))
)
(close f)
(while (setq e (ssname ss (setq j (1+ j))))
(if (setq ass (assoc (cdr (assoc 1 (entget e))) lst))
(entmod (list (cons -1 e)(cons 62 1)(cons 1 (cdr ass))))
)
)
)))
Tue_NV ít khi sử dụng hàm read trong trường hợp này
Nếu chuỗi find có chứa "." thì sai rồi
Ex: (read "134.1/1") -> 134
<<
|
Tác giả: nh0kdkny
Bài viết gốc: 440413
Tên lệnh: chatt |
lisp đánh số liên tiếp block att
em tìm được lisp chatt của bác phamthanhbinh nhưng khi sử dụng có 1 vấn đề là nó đánh số theo 1 chiều chứ không theo ý mình muốn nên em muốn nhờ các cao nhân sửa lại lisp để mình chọn các block att theo thứ tự và lisp sẽ đánh số theo thứ tự block mình chọn
link bài viết trước:
>>
em tìm được lisp chatt của bác phamthanhbinh nhưng khi sử dụng có 1 vấn đề là nó đánh số theo 1 chiều chứ không theo ý mình muốn nên em muốn nhờ các cao nhân sửa lại lisp để mình chọn các block att theo thứ tự và lisp sẽ đánh số theo thứ tự block mình chọn
link bài viết trước:
(defun c:chatt (/ oldos bln ssbl atn n k i a j att atlst atv pre num)
(vl-load-com)
(command "undo" "be")
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq bln (getstring t "\n Nhap ten block: "))
(setq ssbl (acet-ss-to-list (ssget (list (cons 0 "insert") (cons 2 bln) (cons 66 1)))))
(if ssbl
(progn
(setq atn (getstring t "\n Nhap ten thuoc tinh: ")
n (getint "\n Nhap so ky tu can giu cua gia tri thuoc tinh: ")
k (getint "\n Nhap so ky tu bieu dien so: ")
i (getint "\n Nhap so bat dau danh so: ")
a (getreal "\n Nhap gia so: ")
j 0 )
(if (> k 4) (setq k 4))
(if (= atn "") (setq atn bln))
(setq ans (getstring t "\n Ban muon danh so theo chieu thuan <y or n>: "))
(if (= (strcase ans) "Y")
(setq ssbl (vl-sort ssbl '(lambda (x y) (< (cadr (assoc 10 (entget x))) (cadr (assoc 10 (entget y)))))))
(setq ssbl (vl-sort ssbl '(lambda (x y) (> (cadr (assoc 10 (entget x))) (cadr (assoc 10 (entget y)))))))
)
(foreach bl ssbl
(setq att (entnext bl))
(while (/= (cdr (assoc 0 (entget att))) "SEQEND")
(setq atlst (entget att))
(if (= (cdr (assoc 2 atlst)) (strcase atn))
(progn
(setq atv (cdr (assoc 1 atlst))
pre (substr atv 1 n)
num (rtos (+ i (* j a)) 2 0))
(if (and (= (strlen num) 1) (= k 4)) (setq num (strcat "000" num)))
(if (and (= (strlen num) 2) (= k 4)) (setq num (strcat "00" num)))
(if (and (= (strlen num) 3) (= k 4)) (setq num (strcat "0" num)))
(if (and (= (strlen num) 1) (= k 3)) (setq num (strcat "00" num)))
(if (and (= (strlen num) 2) (= k 3)) (setq num (strcat "0" num)))
(if (and (= (strlen num) 1) (= k 2)) (setq num (strcat "0" num)))
(setq atlst (subst (cons 1 (strcat pre num)) (assoc 1 atlst) atlst))
(entmod atlst)
(setq j (1+ j))
)
)
(setq att (entnext att))
)
)
)
)
(command "regenall")
(setvar "osmode" oldos)
(command "undo" "e")
(princ)
)
chatt.lsp <<
|
Filename: 440413_chatt.lsp
|
|
Tác giả: kienccs
Bài viết gốc: 419291
Tên lệnh: test |
Hoán đổi vị trí hai đối tượng cho nhau
Nghịch cái này nhìn 2 text hoàn đổi vui phết ^_^
(defun c:test ()
(while (and (setq a (car (entsel "\nChon text...
>>
Nghịch cái này nhìn 2 text hoàn đổi vui phết ^_^
(defun c:test ()
(while (and (setq a (car (entsel "\nChon text 1: ")))
(setq b (car (entsel "\nChon text 2: ")))
)
(setq b_ins (assoc 10 (entget b)))
(entmod (subst (assoc 10 (entget a)) (assoc 10 (entget b)) (entget b)))
(entmod (subst b_ins (assoc 10 (entget a)) (entget a)))
)
(princ)
)
Thử cái này nhưng không được
<<
|
Filename: 419291_test.lsp
|
|
Tác giả: BTH8320
Bài viết gốc: 307491
Tên lệnh: xtxt1 |
muốn xuất các mtext trong các ô hình tròn và hình elip sang excel
Hề hề hề,
Bạn hãy dùng thử lisp sau đây và cho ý kiến để mình hoàn thiện nó nhé.
Đây là bản mình viết nháp...
>>
Hề hề hề,
Bạn hãy dùng thử lisp sau đây và cho ý kiến để mình hoàn thiện nó nhé.
Đây là bản mình viết nháp xem đã đúng ý bạn chưa nên mình chưa khử biến và cũng chưa test kỹ cho các trường hợp khác nhau.
Nếu bạn thấy phù hợp với ý định của bạn mình sẽ hoàn thiện sau nhé.
(defun c:xtxt1 ()
(setq dlst (list)
tlst (list)
ans "Y" )
(alert "Ban hay chon lan luot cac text can xuat cua tung line")
(while (= (strcase ans) "Y")
(while (setq e (car (entsel)))
(setq elst (entget e)
la (cdr (assoc 8 elst))
txt (cdr (assoc 1 elst)) )
(cond
((= la "PRT Points Red") (setq txt (strcat txt "- H")))
((= la "UTG Points Red") (setq txt (strcat txt "-C")))
((= la "UTS Points Red") (setq txt (strcat txt "-E")))
(T nil)
)
(setq tlst (append tlst (list txt)))
)
(setq dlst (append dlst (list tlst)))
(setq tlst (list))
(setq ans (getstring "/n Ban muon tiep tuc chon line khac <Y or N>: "))
)
(setq ilst (list))
(foreach lst dlst
(setq ilst (append ilst (list (length lst))))
)
(setq i (car (vl-sort ilst '(lambda (x y) (> x y)))))
(setq n 0)
(setq prlst (list))
(while (< n i)
(setq dalst (mapcar '(lambda (x) (strcat (if (nth n x) (nth n x) " ") (chr 44))) dlst))
(setq prlst (append prlst (list dalst)))
(setq n (1+ n))
)
(setq fn (getfiled "Select Data File" "" "csv" 1)
f (open fn "w") )
(foreach dat prlst
(setq tpr "")
(foreach tp dat
(setq tpr (strcat tpr tp))
)
(write-line tpr f)
)
(close f)
(princ)
)
Chúc bạn vui.
Như thế này là rất tuyệt rồi mod ạ.
Xin nhờ mod thêm giúp mình một cái nữa là khi hoàn tất lệnh, ta tiếp tục lệnh thì file csv xuất ra sẽ chèn thêm dữ liệu vào file cũ nếu ta chép đè.
Giống như lisp xtxt mà ta thay dòng lệnh (setq fw (open tmp "w")) bằng (setq fw (open tmp "a")) ấy mod ạ
Ở lisp xtxt1 mình không thấy dòng đó nên không biết làm thế nào.
Nhờ mod hoàn thiện giúp mình với.
Xin cảm ơn các mod đã nhiệt tình giúp đỡ
<<
|
Filename: 307491_xtxt1.lsp
|
|
Tác giả: Bienxanh_19
Bài viết gốc: 204504
Tên lệnh: ddt |
Nhờ giúp Lisp tính diện tích và lập bảng
Hề hề hề,
Mình giúp bạn lần này đưa vấn đề bạn hỏi về cùng topic gốc. Lần sau bạn nên rút kinh nghiệm để diễ...
>>
Hề hề hề,
Mình giúp bạn lần này đưa vấn đề bạn hỏi về cùng topic gốc. Lần sau bạn nên rút kinh nghiệm để diễ đàn đỡ rối rắm.
Bạn dùng thử cái này xem đã ưng ý chưa nhé.
(defun c:ddt(/ lacol ladin laos tl h tl1 cao1 k tdt ss pt p1 p2 p3 p4 p5 p6 p7 p8
pa pt1 pt2 e ep p9 p10 p11 p12 p13 et dtcon )
(setvar "cmdecho" 0)
(setq lacol (getvar "CEColor"))
(setq ladin (getvar "dimzin"))
(setq laos (getvar "osmode"))
(if (not tl) (setq tl 1))
(if (not h) (setq h 1))
(setq tl1 (getreal (strcat "\nty le ban ve < 1/" (rtos tl 2 0) " >: 1/"))
caot1 (getreal (strcat "\nCao text < " (rtos h 2 0) " >: ")))
(if tl1 (setq tl tl1))
(if caot1 (setq h caot1))
(command "undo" "be")
(setq k 0
tdt 0)
(setq ss (ssadd))
(setvar "dimzin" 0)
(setvar "OSMODE" 0)
(setq PT (getpoint "\nChon diem xuat bang thong ke dien tich (mep trai):"))
(setq P1 (list (+ (car PT)(* 6 h)) (cadr PT))
P2 (list (+ (car PT)(* 22 h)) (cadr PT))
P3 (list (car PT) (- (cadr PT)(* 3 h)))
P4 (list (car P1) (cadr P3))
P5 (list (car P2) (cadr P3))
P6 (list (+ (car PT)(* 11 h)) (+ (cadr PT)(* 2 h)))
P7 (list (+ (car PT)(* 3 h)) (- (cadr PT)(* 1.5 h)))
P8 (list (+ (car PT)(* 14 h)) (- (cadr PT)(* 1.5 h)))
);setq
(command "pline" PT P2 P5 P3 "C"
"pline" P1 P4 ""
"text" "m" P6 (* 1.2 h) 0 "Bang thong ke dien tich"
"text" "m" P7 h 0 "STT"
"text" "m" P8 h 0 "Dien tich (mm2)"
);command
(setq PA (getstring "\n Ban chon phuong an chon doi tuong < 1 or 2 > : "))
(if (= pa "1")
(setq pt1 (getpoint "\n Chon mien tinh dien tich : "))
(setq ep (car (setq e (entsel "\n Chon doi tuong la polyline kin")))
pt2 (cadr e) )
)
(while (or (/= pt1 nil) (/= ep nil) )
(setq k (+ 1 k))
(if pt1
(command "TEXT" "m" pt1 (* 1 h) 0 (rtos k 2 0))
)
(if ep
(command "TEXT" "m" pt2 (* 1 h) 0 (rtos k 2 0))
)
(setq PT (list (car P3) (cadr P3))
P1 (list (+ (car PT)(* 6 h)) (cadr PT))
P2 (list (+ (car PT)(* 22 h)) (cadr PT))
P3 (list (car PT) (- (cadr PT)(* 3 h)))
P4 (list (car P1) (cadr P3))
P5 (list (car P2) (cadr P3))
P7 (list (+ (car PT)(* 3 h)) (- (cadr PT)(* 1.5 h)))
P8 (list (+ (car PT)(* 14 h)) (- (cadr PT)(* 1.5 h)))
P9 (list (car PT) (- (cadr P3)(* 3 h)))
P10 (list (car P1) (cadr P9))
P11 (list (car P2) (cadr P9))
P12 (list (car P7) (- (cadr P3)(* 1.5 h)))
P13 (list (car P8) (cadr P12))
);setq
(if pt1
(progn
(command "CECOLOR" 4 "-boundary" pt1 "" )
(setvar "CECOLOR" lacol)
(setq et (entlast))
(ssadd et ss)
(command "area" "e" "last")
)
)
(if ep
(command "area" "o" ep)
)
;;;;;;(setq et (entlast))
;;;;;;(ssadd et ss)
(setq dtcon (* (getvar "AREA") tl tl))
(setq tdt (+ dtcon tdt))
(command "erase" ss "")
(command "pline" PT P2 P5 P3 "C"
"pline" P1 P4 ""
"text" "m" P7 h 0 (rtos k 2 0)
"text" "m" P8 h 0 (rtos dtcon 2 2))
(if pt1
(setq pt1 (getpoint "\n chon mien tinh dien tich tiep theo hoac enter de ket thuc lenh..."))
)
(if ep
(setq ep (car (setq e (entsel "\n Chon polyline tiep theo hoạc enter de ket thuc lenh ..."))) pt2 (cadr e) )
)
);while
(setq ss nil)
(setvar "DIMZIN" ladin)
(command "pline" P3 P9 P11 P5 "C"
"pline" P10 P4 ""
"text" "m" P12 h 0 "Tong"
"text" "m" P13 h 0 (rtos tdt 2 2)
);command
(command "undo" "e")
(setvar "OSMODE" laos)
(setvar "cmdecho" 1)
(princ)
)
Chúc bạn vui......
E nhờ các A chỉnh sưả code sao cho sau dâú phẩy chỉ lấy một chữ số thô i ah!Mong các anh giúp choỡơ
<<
|