Info | File |
Tác giả: Hung_tthanh
Bài viết gốc: 207410
Tên lệnh: udt |
Tính tổng diện tích các hình trên bản vẽ, "Ed" vào text sẵn có
Nguyên văn lisp "udt" ở bên trên, cũng không biết có phải lisp bạn đề cập không, cũng không rõ việc không nhận...
>>
Nguyên văn lisp "udt" ở bên trên, cũng không biết có phải lisp bạn đề cập không, cũng không rõ việc không nhận lệnh là như thế nào. Hy vọng bạn hiểu ý mình
(defun c:udt(/ ss tong ham tmp tt hstl oldim toe frome cur dt)
(prompt "\n Kich thuoc cua chuong trinh tinh theo don vi mm ")
(if (not hstlo) (setq hstlo 0.001))
(setq hstl (getreal (strcat "\n Nhap ti le chuyen doi don vi <" (rtos hstlo 2 3) "> :")))
(if (not hstl) (setq hstl hstlo) (setq hstlo hstl))
(if (not tpo) (setq tpo 2))
(setq tp (getint (strcat "\n Nhap So chu so thap phan <" (itoa tpo) "> :")))
(if (not tp) (setq tp tpo) (setq tpo tp))
(setq oldim (getvar "Dimzin"))
(setvar "Dimzin" 0)
(prompt "\n Chon doi tuong de tinh dien tich hay Enter de tinh dien tich theo Pick diem ")
(setq
ss (ssget '((-4 . "<OR")(0 . "LWPOLYLINE")(0 . "REGION")(0 . "CIRCLE")(0 . "ARC")(-4 . "OR>")))
tong 0.0
ham (lambda (x) (command ".area" "o" x) (setq tong (+ tong (getvar "area"))))
tmp (mapcar 'ham (ss2ent ss))
)
(if (not ss) (progn
(setq tong 0.0 ss (ssadd))
(while (setq p (getpoint "\n Pick vao vung tinh dien tich :"))
(setq frome (entlast))
(command ".boundary" p "")
(setq toe (entlast))
(setq cur frome)
(while (not (eq cur toe))
(setq
cur (entnext cur)
ss (ssadd cur ss))
(command "area" "S" "O" ss "" "")
(setq dt (getvar "area"))
(setq tong (+ tong dt))
)
(command "area" "A" "O" "L" "" "")
(setq dt (getvar "area"))
(setq tong (+ tong (* dt 2)))
(sssetfirst ss ss)
)
(command "erase" ss "")
))
(setq tt (entget (car (entsel "\nChon text ket qua: ")))
tong (vl-string-right-trim "." (vl-string-right-trim "0" (rtos tong)))
)
(entmod (subst (cons 1 (rtos (* (atof tong) hstl hstl) 2 tp)) (assoc 1 tt) tt))
(setvar "Dimzin" oldim)
(princ)
)
;
(defun ss2ent(ss / sodt index lstent)
(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)
)
(princ "\nUpdate Area - free lisp from cadviet.com")
(princ "\nUse UDT command to start!")
(vl-load-com)
Bạn kiểm tra thử lại xem hình như hệ số chuyển đổi đơn vị bị lôi.
Ví dụ mình vẽ hình chữ nhật 1000x1000
1. ban đầu mình thay đôi hệ sô là 0.0005 thì diện tích ra 0.25 => Ok
2. làm lại lần nữa lúc nhập hệ số thì tại dòng nhắc đã hiện sẵn mặc định là "<0.001>: 0.001", mình ấn Enter để rồi tính thì diện tích vẫn là 0.25. Muốn diện tính ra đúng thì phải đánh vào số 0.001
- Rất dễ xãy ra sai xót vì tại dòng nhắc vẫn hiện là <0.001> nhưng thực chất tỉ lệ lại là 0.0005 bạn có thể sửa đổi là khi nhập 0.0005 thì làm lại lần tiếp theo thì dòng nhắc hiện là <0.0005> để biết mình đang làm với hệ số nào....^!^
<<
|
Tác giả: 24h.com.vn
Bài viết gốc: 206833
Tên lệnh: sfd |
lisp sửa text dim và gán màu sau khi sửa
Mình gửi bạn code này, không quá giống ý "tự động" của bạn
Nhưng khi bạn làm xong, đánh lệnh SFD xong, nó sẽ tự động vạch mặt...
>>
Mình gửi bạn code này, không quá giống ý "tự động" của bạn
Nhưng khi bạn làm xong, đánh lệnh SFD xong, nó sẽ tự động vạch mặt những dim bạn đã edit :D
Màu bạn có thể thay đổi giá trị vào lisp trong ô (setq mau 5); số màu do bạn chọn nhé
;; Free lisp code from CADViet.com - edit by mathan
(defun c:sfd ( / ss)
(setq ss (ssget '((0 . "DIMENSION")
(-4 . "<NOT")
(-4 . "<OR")
(1 . "")
(1 . "*<>*")
(-4 . "OR>")
(-4 . "NOT>")
)
)
)
;(sssetfirst ss ss)
(setq mau 5);; Ban nhap mau vao day
(command "_CHANGE" ss "" "Properties" "Color" mau "")
(princ)
)
Hope U be fun with this code
nhưng khi đi in thì sao hả bác k có cách gán màu à.hoặc là 1 lisp nhận biết dim đã bị sửa
<<
|
Tác giả: hatieu
Bài viết gốc: 117728
Tên lệnh: blkqty |
Viết lisp theo yêu cầu [phần 2]
Update : Thống kê Block trong bản vẽ. Fix : tên Block tiếng Việt .
>>
Update : Thống kê Block trong bản vẽ. Fix : tên Block tiếng Việt .
(defun c:BlkQty (/ blk_id blk_len blk_name blks ent h header_lsp height i j
len0 lst_blk msp pt row ss str tblobj width width1 width2 x y)
;; By : Gia Bach, gia_bach @ www.CadViet.com ;;
(defun TxtWidth (val h msp / txt minp maxp)
(setq txt (vla-AddText msp val (vlax-3d-point '(0 0 0)) h))
(vla-getBoundingBox txt 'minp 'maxp )
(vla-Erase txt)
(-(car(vlax-safearray->list maxp))(car(vlax-safearray->list minp))) )
(defun GetOrCreateTableStyle (tbl_name / name namelst objtblsty objtblstydic tablst txtsty)
(setq objTblStyDic (vla-item (vla-get-dictionaries *adoc) "ACAD_TABLESTYLE") )
(foreach itm (vlax-for itm objTblStyDic
(setq tabLst (append tabLst (list itm))))
(if (not
(vl-catch-all-error-p
(setq name (vl-catch-all-apply 'vla-get-Name (list itm)))))
(setq nameLst (append nameLst (list name))) ) )
(if (not (vl-position tbl_name nameLst))
(vla-addobject objTblStyDic tbl_name "AcDbTableStyle"))
(setq objTblSty (vla-item objTblStyDic tbl_name)
TxtSty (variant-value (vla-getvariable *adoc "TextStyle")))
(mapcar '(lambda (x)(vla-settextstyle objTblSty x TxtSty))
(list acTitleRow acHeaderRow acDataRow) )
(vla-setvariable *adoc "CTableStyle" tbl_name) )
(defun GetObjectID (obj)
(if (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
(vlax-invoke-method *util 'GetObjectIdString obj :vlax-false )
(vla-get-Objectid obj)))
;main
(if (setq ss (ssget (list (cons 0 "INSERT"))))
(progn
(vl-load-com)
(setq i -1 len0 8)
(while (setq ent (ssname ss (setq i (1+ i))))
(setq blk_name (cdr (assoc 2 (entget ent))))
(if (> (setq blk_len (strlen blk_name)) len0)
(setq str blk_name len0 blk_len) )
(if (not (assoc blk_name lst_blk))
(setq lst_blk (cons (cons blk_name 1) lst_blk))
(setq lst_blk (subst (cons blk_name (1+ (cdr (assoc blk_name lst_blk))))
(assoc blk_name lst_blk) lst_blk))) )
(setq lst_blk (vl-sort lst_blk '(lambda (x y) (< (car x) (car y)) ) ))
(or *h* (setq *h* (* (getvar "dimtxt")(getvar "dimscale"))))
(initget 6)
(setq h (getreal (strcat "\nChieu cao chu <" (rtos *h*) "> :")))
(if h (setq *h* h) (setq h *h*) )
(or *adoc (setq *adoc (vla-get-ActiveDocument (vlax-get-acad-object))))
(setq msp (vla-get-modelspace *adoc)
*util (vla-get-Utility *adoc)
blks (vla-get-blocks *adoc))
(setq width1 (* 2 (TxtWidth "STT" h msp))
width (* 2 (TxtWidth "So luong" h msp))
height (* 2 h))
(if str
(setq width2 (* 1.5 (TxtWidth (strcase str) h msp)))
(setq width2 width))
(if (> h 3)
(setq width (* (fix (/ width 10))10)
width1 (* (fix (/ width1 10))10)
width2 (* (fix (/ width2 10))10)
height (* (fix (/ height 5))5)))
(GetOrCreateTableStyle "CadViet")
(setq pt (getpoint "\nDiem dat Bang :")
TblObj (vla-addtable msp (vlax-3d-point pt) (+ (length lst_blk) 2) 5 height width))
(vla-put-regeneratetablesuppressed TblObj :vlax-true)
(vla-SetColumnWidth TblObj 0 width1)
(vla-SetColumnWidth TblObj 1 width2)
(vla-put-vertcellmargin TblObj (* 0.75 h))
(vla-put-horzcellmargin TblObj (* 0.75 h))
(mapcar '(lambda (x)(vla-setTextHeight TblObj x h))
(list acTitleRow acHeaderRow acDataRow) )
(mapcar '(lambda (x)(vla-setAlignment TblObj x 8))
(list acTitleRow acHeaderRow acDataRow))
(vla-MergeCells TblObj 0 0 0 4)
(vla-setText TblObj 0 0 "Bang thong ke")
(setq j -1 header_lsp (list "STT" "Ten" "Don vi" "So luong" "Ky hieu"))
(repeat (length header_lsp)
(vla-setText TblObj 1 (setq j (1+ j)) (nth j header_lsp)))
(setq row 2 i 1)
(foreach pt lst_blk
(setq blk_name (car pt) j -1)
(mapcar '(lambda (x)(vla-setText TblObj row (setq j (1+ j)) x))
(list i blk_name "cai" (cdr pt)))
(vla-SetBlockTableRecordId TblObj row 4 (GetObjectID (vla-item blks blk_name)) :vlax-true)
(vla-SetCellAlignment TblObj row 1 7)
(vla-SetCellAlignment TblObj row 3 9)
(setq row (1+ row) i (1+ i)) )
(vla-put-regeneratetablesuppressed TblObj :vlax-false)
(vlax-release-object TblObj) ) )
(princ))
Mò mãi mà không ra. Bác Gia Bạnh giúp em tạo cái bảng này bằng lisp của bác được không?
Còn đây là file cad của em.
File cad
Các chỗ khác vẫn bình thường duy chỉ có cột W và H là khác. Block của em có tên là W x H.
<<
|
Filename: 117728_blkqty.lsp
|
|
Tác giả: duy782006
Bài viết gốc: 438893
Tên lệnh: ld |
Nhờ các bác giúp đỡ viết lisp xuất cao độ Z của 1 điểm
(defun c:ld ()
(setq dd (getpoint "Chon diem !"))
(entmake (list (cons 0 "TEXT")(cons 10 dd)(cons 11 dd)(cons 40 2)(cons 50 0)(cons 72 0)(cons 1 (rtos (caddr dd) 2 3))(cons 7 (getvar "TEXTSTYLE"))(cons 8 (getvar "CLAYER"))(cons 62 256)))
(entmake (list (cons 0 "POINT")(cons 10 dd)(cons 8 (getvar "CLAYER"))(cons 62 256)))
(princ)
)
|
Tác giả: Tue_NV
Bài viết gốc: 188563
Tên lệnh: test1 test |
Chuyển từ text số thành text chữ tiếng Việt.
Ứng dụng của AutoCAD .NET API thực hiện việc >>
Ứng dụng của AutoCAD .NET API thực hiện việc Chuyển từ text số thành text chữ tiếng Việt.
Sử dụng thư viện Chuyển số thành chữ bên caulacbovb.net : LInk
Cách sử dụng :
1. giải nén và copy file "Number2String.dll" vào hệ thống(đĩa cứng, USB, ...).
2. Khởi động AutoCAD, open file Cad cần chuyển .
3. Tại dấu nhắc (Command ) của CAD gõ lệnh NETLOAD và chỉ đến vị trí file "Number2String.dll" vừa copy ở buớc 1, chọn OPEN để hoàn thành lệnh NETLOAD .
4. gõ lệnh n2s để bắt đầu ...
(Nếu bạn đã quen với AutoLisp, các buớc 1-2-4 tuơng tự như cách load 1 ứng dụng AutoLisp, chỉ thay lệnh APPLOAD bằng lệnh NETLOAD ở buớc 3.)
Ngoài ra "Number2String.dll" còn cùng cấp hàm LISP Number2String để ứng dụng trong Lập trình LISP.
Cách sử dụng :
1. Cú pháp : (Number2String str)
- trong đó str là kiểu chuỗi (string)
Chú ý : kí hiệu thập phân chỉ chấp nhận hoăc là dấu phấy "," hoặc dấu chấm "." (không chấp nhận vừa dấu phẩy vừa dấu chấm, VD: 123.456,8 )
- giá trị trả về là lisp chứa kết quả tiếng Việt (bảng mã Unicode) hoặc NIL
2.VD :
- (car(Number2String "13964.8")) -> Mười ba nghìn chín trăm sáu mươi bốn phảy tám
- (car(Number2String "237,5")) -> Hai trăm ba mươi bảy phảy năm
- (Number2String "4.237,5") -> nil
Hàm Lisp tham khảo :
Nhớ chép file "Number2String.dll" vào đuờng dẫn Autocad Support file search Path.
(defun C:test1(/ ds e fil i res ss str);
(if (and (setq fil (findfile "Number2String.dll"))
(vl-cmdf "_.netLoad" fil)
(setq ss (ssget "_:L" (list (cons 0 "Text")))) )
(progn
(setq i -1)
(while (setq e (ssname ss (setq i (1+ i))))
(setq ds (entget e)
str (cdr (assoc 1 ds)))
(if (setq res (Number2String str) )
(entmod (subst (cons 1 (strcat str " (" (car res ) ")") )(assoc 1 ds) ds)) ) ))
(princ "\nError found."))
(princ))
(defun C:test(/ ss res fil)
(if (and (setq fil (findfile "Number2String.dll"))
(vl-cmdf "_.netLoad" fil) )
(while (setq ss (ssget "_+.:S:E" (list (cons 0 "Text"))))
(if (setq res (Number2String (cdr (assoc 1 (entget (ssname ss 0))))) )
(princ (car res ))
(princ "\nKhong phai so!")))
(princ "\nFile not found.") )
(princ))
Link bao gồm SourceCode : click here
Code chạy tốt lắm. Tuy nhiên, có 1 số trường hợp anh ạ:
2002 : Chương trình đọc là : Hai nghìn hai
-> Đúng phải là : Hai nghìn không trăm lẻ hai
2002,002 Chương trình đọc là : Hai nghìn hai phảy không không hai
-> Đúng phải là : Hai nghìn không trăm lẻ hai phẩy không trăm lẻ hai
Cảm ơn anh gia_bach rất nhiều. Chúc anh luôn khoẻ
<<
|
Filename: 188563_test1_test.lsp
|
|
Tác giả: legiang610
Bài viết gốc: 326302
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...
>>
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......
lisp này của bác thuận tiện quá, nhưng do đặc thù công việc của e hay dùng tỷ lệ 1/1000 ( tính diện tích ra m2) và chiều cao text 200, vậy hỏi bác muốn thiết lâp tỷ lệ và chiều cao text như trên làm giá trị mặc định thì sửa ở đâu ạ. cảm ơn bác
<<
|
Tác giả: duy782006
Bài viết gốc: 439020
Tên lệnh: capnhattkt |
Lisp Thống Kế Thép Bằng Block.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:capnhattkt ()
(setq daithanhtong 0.0)
(setq dskichthuoc (duy:block_d_att>ds_loctentag dtc "KT"))
(foreach tentag dskichthuoc
(setq daithanhtong (+ daithanhtong (atoi (duy:block_d_att>ten dtc tentag))))
)
(setq pilon (atoi (duy:block_d_att>ten dtc "PI")))
(cond
((> pilon 8)
(cond
((> (/ daithanhtong 11700) 1)...
>>
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:capnhattkt ()
(setq daithanhtong 0.0)
(setq dskichthuoc (duy:block_d_att>ds_loctentag dtc "KT"))
(foreach tentag dskichthuoc
(setq daithanhtong (+ daithanhtong (atoi (duy:block_d_att>ten dtc tentag))))
)
(setq pilon (atoi (duy:block_d_att>ten dtc "PI")))
(cond
((> pilon 8)
(cond
((> (/ daithanhtong 11700) 1)
(setq daithanhtong (+ daithanhtong (* (fix (/ daithanhtong 11700)) 30 pilon)))
)
)
)
)
(setq soluongthanh (atoi (duy:block_d_att>ten dtc "SL")))
(setq daithanhtongnhan (* soluongthanh daithanhtong))
(setq soluongcaukien (atoi (duy:block_d_att>ten dtc "SCK")))
(setq trongluong (/ (* (/ pilon 2) (/ pilon 2) 3.1416 daithanhtongnhan 7.86) 1000000) )
(duy:block_s_att dtc "CD" (rtos daithanhtong 2 0))
(duy:block_s_att dtc "TCDCK" (rtos (/ (* daithanhtongnhan soluongcaukien) 1000.0) 2 2))
(duy:block_s_att dtc "TLCK" (rtos (* trongluong soluongcaukien) 2 2))
(duy:rungmh)
(princ)
)
Cũng nhiều bạn yêu cầu dụ này nên mình đã viết rồi. Bạn chép đè lại hàm capnhattkt này vào lisp là ok.
<<
|
Filename: 439020_capnhattkt.lsp
|
|
Tác giả: Doan Van Ha
Bài viết gốc: 164821
Tên lệnh: cen |
Lsp lấy dữ liệu lệnh Massprop
Đúng là bác ĐVH, đã đau đáu là cứ làm mãi ^^
Em cũng xin góp vui 1 code
;======= Insert Point in Centroid of each...
>>
Đúng là bác ĐVH, đã đau đáu là cứ làm mãi ^^
Em cũng xin góp vui 1 code
;======= Insert Point in Centroid of each Closed Entity and All
;======= Ketxu 15-8 ============================================
(defun c:cen(/ cSet cLst oldSnp cCen cAre cmLst gCen)
(vl-load-com)
(grtext -1 "Free lisp from CADVIET @Ketxu")
(command "undo" "be")
;============== Local Functions ================================
(defun ST:SS-Filter (ss typeObj / ssRT) ; Filter ss type from another ss
(setq ssRT (ssadd))
(foreach en (ST:Ss->ListEnt ss)(if (wcmatch (cdadr (entget en)) typeObj)(setq ssRT (ssadd en ssRt)))) ssRT)
(defun ST:Ss->ListEnt (ss / n e l) ;Get list Ename of a ss
(setq n (sslength ss)) (while (setq e (ssname ss (setq n (1- n))))(setq l (cons e l)))
)
(defun ST:Entmake-Line (p1 p2 Color) ;Draw a Line from p1 to p2, with Color
(entmake (list (cons 0 "Line")(cons 10 (trans p1 1 0))(cons 11 (trans p2 1 0))(cons 62 Color)))
)
(defun ST:Entmake-Point (p Color) ;Put a point in P with color
(entmake (list (cons 0 "Point")(cons 10 (trans p 1 0))(cons 62 Color)))
)
(defun ST:Entmake-Circle (p D Color)
(entmake (list (cons 0 "Circle")(cons 10 (trans p 1 0))(cons 40 D)(cons 62 Color)))
)
(defun ST:Entmake-SimpleText(txt p h tAng jt color / sty d h1 h2 wf h) ;;;Write txt on graphic screen at p
(setq sty (getvar "textstyle") )
(entmake (list (cons 0 "TEXT") (cons 7 sty) (cons 40 h)(cons 1 txt) (cons 10 (trans p 1 0))(cons 62 color)(cons 73 2)(cons 11 (trans p 1 0))(cons 50 tAng)
(cons 72 (cond ((= jt "R")2) (T 0)))))
)
;================ Start Here =====================================
(princ "\n<<<Select Closed Region, 3Dsolid, PLine, SPline, Circle, Ellipse >>> ")
(if(setq cSet (ssget '((0 . "REGION,3DSOLID,*POLYLINE,SPLINE,CIRCLE,ELLIPSE"))))
(progn
(or (setq ssReg (ST:SS-Filter cSet "REGION,3DSOLID")) (setq ssReg (ssadd)))
(setq ssOthers (ST:SS-Filter cset "*POLYLINE,SPLINE,CIRCLE,ELLIPSE") elast (entlast) ssRegCreate (ssadd)
*model* (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
ssOthers (mapcar 'vlax-ename->vla-object (ST:Ss->ListEnt ssOthers)))
(foreach other ssOthers
(if (= :vlax-true(vla-get-Closed other))
(setq ssRegCreate (ssadd (vlax-vla-object->ename (car (vlax-invoke *model* 'addregion (list other)))) ssRegCreate))
)
)
(foreach en (ST:Ss->ListEnt ssRegCreate)
(setq ssreg (ssadd en ssreg))
)
(setq cLst (mapcar 'vlax-ename->vla-object (ST:Ss->ListEnt ssreg))
oldSnp(getvar "OSMODE")
)
(mapcar 'setvar (list "OSMODE" "CMDECHO" "Delobj")(list 0 0 0))
(foreach ent cLst
(if(vlax-property-available-p ent 'Centroid)
(progn
(setq cCen(vlax-get ent 'Centroid)
cAre(vlax-get ent 'Area)
cmLst(cons(list cCen cAre)cmLst)
); end setq
(ST:Entmake-Point cCen 1)
(ST:Entmake-SimpleText (strcat "X = " (rtos (car ccen) 2 2)) (mapcar '+ cCen (list 0 (* 3 (getvar "textsize")) 0)) (getvar "textsize") 0 "L" 6)
(ST:Entmake-SimpleText (strcat "Y = " (rtos (cadr ccen) 2 2)) (mapcar '- cCen (list 0 (* 3 (getvar "textsize")) 0)) (getvar "textsize") 0 "L" 6)
); end progn
); end if
); end foreach
(if
(and
cmLst
(/= 1(length cmLst))
); enad and
(progn
(setq gCen
(list
(/
(apply '+
(mapcar '*
(mapcar 'caar cmLst)(mapcar 'cadr cmLst)))
(apply '+ (mapcar 'cadr cmLst))
); end /
(/
(apply '+
(mapcar '*
(mapcar 'cadar cmLst)(mapcar 'cadr cmLst)))
(apply '+ (mapcar 'cadr cmLst))
); end /
); end list
); end setq
(ST:Entmake-Circle gCen (getvar "textsize") 3)
(ST:Entmake-Point gCen 4)
(ST:Entmake-SimpleText (strcat "X = " (rtos (car gCen) 2 2)) (mapcar '+ gCen (list 0 (* 3.5 (getvar "textsize")) 0)) (* 6 (getvar "textsize")) 0 "L" 7)
(ST:Entmake-SimpleText (strcat "Y = " (rtos (cadr gCen) 2 2)) (mapcar '- gCen (list 0 (* 3.5 (getvar "textsize")) 0)) (* 6 (getvar "textsize")) 0 "L" 7)
(foreach pt (mapcar 'car cmLst)
(ST:Entmake-Line pt gCen 5)
); end foreach
); end progn
); end if
(mapcar 'setvar (list "OSMODE" "CMDECHO")(list oldSnp 1 1))
); end progn
); end if
(command ".erase" ssRegCreate "")
(command "undo" "en")
(princ)
); end of c:gecen
check thử bị lỗi như vầy Ketxu ơi:
Command: cen
undo Current settings: Auto = On, Control = All, Combine = Yes
Enter the number of operations to undo or
<1>: be
Command:
<<<Select Closed Region, 3Dsolid, PLine, SPline, Circle, Ellipse >>>
Select objects: Specify opposite corner: 5 found
Select objects:
; error: ActiveX Server returned the error: unknown name: Closed
<<
|
Tác giả: hugo007
Bài viết gốc: 164100
Tên lệnh: brd |
Lisp cắt đối tượng
Bạn dùng tạm.
- Lệnh : brd
-Chức năng : Break các đường *Line (bị cắt) tại các giao điểm với các đường *Line (cắt) chỉ...
>>
Bạn dùng tạm.
- Lệnh : brd
-Chức năng : Break các đường *Line (bị cắt) tại các giao điểm với các đường *Line (cắt) chỉ định.
- Lisp làm việc với Line, Pline, SPline... (nói chung là các đối tượng mà lệnh Break xử lý)
Mình viết vội nên không có phần bắt lỗi, chỉ có Undo, bạn nhớ cẩn trọng khi chọn đối tượng :)
(defun c:brd (/ EL lst_ss_bicat lst_ss_cat lst ST:Ent-Length ST:Ss->ListEnt ST:Ent-IntersObj ST:Ent-BrkLPSLine)
;;;;;;;; Local Functions
(defun ST:Ent-Length(e) (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e)))
(defun ST:Ss->ListEnt (ss / n e l)
(setq n (sslength ss))
(while (setq e (ssname ss (setq n (1- n))))
(setq l (cons e l))
)
)
(defun ST:Ent-IntersObj (e1 e2 / ob1 ob2 g L i kq) ;objExtend : doi tuong keo dai
(vl-load-com)
(setq
ob1 (vlax-ename->vla-object e1)
ob2 (vlax-ename->vla-object e2))
(setq 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 ST:Ent-BrkLPSLine (obj LineDo / lstInters);ename
(if (setq lstInters (ST:Ent-IntersObj obj LineDo))
(progn
(foreach x lstInters
(command "_break" obj x "@")
)
)
)
)
(grtext -1 "Free Break and Del *Line @Ketxu Cadviet.com")
(command "undo" "begin")
(setq EL (entlast))
(prompt "\nCh\U+1ECDn c\U+00E1c Line, Pline, SLine.. b\U+1ECB c\U+1EAFt :")
(setq lst_ss_bicat (ST:Ss->ListEnt (ssget)))
(prompt "\nCh\U+1ECDn c\U+00E1c Line, Pline, SLine...c\U+1EAFt :")
(setq lst_ss_cat (ST:Ss->ListEnt (ssget)))
(foreach Linedo lst_ss_cat
(foreach obj lst_ss_bicat
(ST:Ent-BrkLPSLine obj Linedo)
)
(while (setq EL (entnext EL)) (setq lst_ss_bicat (cons EL lst_ss_bicat)))
(setq EL (entlast))
)
(command "erase" (nth (vl-position (apply 'min (setq lst (mapcar 'ST:Ent-Length lst_ss_bicat))) lst) lst_ss_bicat) "")
(command "undo" "end")
)
P/S : lần sau, nếu bạn post bài yêu cầu thì cố gắng thể hiện rõ ràng nhất yêu cầu của mình, tốt nhất nên có hình minh họa, để vừa nhanh có hàng mà ai cũng vui, chứ để số bài viết tăng nhanh mà vấn đề thì không được giải quyết thì mệt cái đầu lắm. Hy vọng đây cũng là lần cuối cùng Ket ngỏ lời cùng bạn về việc này :wub:
Chúc bạn thành công!
Cám ơn bạn hình như bạn có hiểu sai ý mình các đoạn thẳng sau khi chia tại các đường cắt đoạn ngắn nhất trong 1 đoạn thẳng sau khi bị chia sẽ bị xoá chứ không phải ngắn nhất trong tất cả đoạn thẳng sau khi bị chia.Thí dụ mình có 2 đoạn thẳng A và B bị chia bởi 2 đoạn thẳng bất kỳ.đoạn A bị chia làm 3,đoạn B cũng bị chia làm 3.Trong 3 đoạn thằng bị chia bởi đoạn A đoạn nào ngắn nhất sẽ bị xoá tương tự đoạn ngắn nhất trong đoạn B cũng bị xoá.Tóm lại có bao nhiêu đoạn thằng bị cắt bởi đường cắt thì có bấy nhiêu đoạn ngắn nhất bị xoá.Bạn thêm giùm mình phần bẫy lỗi còn thiếu như bạn nói luôn nhe,mình đợi được.Thanks.
<<
|
Tác giả: huunhantvxdts
Bài viết gốc: 439033
Tên lệnh: dempoint |
(YÊU CẦU) XIN LISP ĐẾM POINT VÀ PICK KẾT QUẢ VÀO TEXT
14 phút trước, hatrongquan88 đã nói:
Đầu tiên mình cảm ơn...
>>
14 phút trước, hatrongquan88 đã nói:
Đầu tiên mình cảm ơn bạn đã góp ý cho mình, mình đang phải làm việc trên nhiều mặt cắt như hình vẽ, mỗi mặt cắt có nhiều khu riêng, việc của mình là phải tách riêng điểm cho từng khu một. Vấn đề của mình gặp phải là tách riêng số điểm rồi viết ra text và tổng hợp từng khu 1. Nếu chọn phương pháp thủ công thì mình chỉ cần ấn lệnh C rồi quét vùng mình cần đếm trong bảng command tự xuất hiện số điểm và mình viết thủ công vào text. Mình k muốn phải viết tay từng số 1 nên rất mong bạn giúp đỡ. Cảm ơn bạn!
Rãnh rỗi viết tí cho vui
bạn test thế nào nhé
(defun c:dempoint (/ sspoint sopoint text)
(prompt "\nChon point can dem")
(While (setq sspoint (acet-ss-to-list (ssget '((0 . "POINT")))))
(setq sopoint (length sspoint))
(setq text (car (entsel "\nChon text thay the:")))
(vla-put-textstring (vlax-ename->vla-object text) (rtos sopoint 2 0))
)
(princ)
)
<<
|
Filename: 439033_dempoint.lsp
|
|
Tác giả: Danh Cong
Bài viết gốc: 436165
Tên lệnh: vbk |
Lisp đo bán kính sau khi Fillet
57 phút trước, huunhantvxdts đã nói:
57 phút trước, huunhantvxdts đã nói:
Ý là muốn đo bán kính của cung tròn đó chứ ko phải text.
Sau khi filett xong không phải chọn lại đối tượng mà nó đo luôn.
Chứ bạn tạo text rồi pick điểm đến thì dùng lệnh đo bán kính rồi pick chọn cung nó đẹp hơn
Ở đây ý mình là filett xong không chọn chi hết nó đo luôn bán kính
Cám ơn bạn nhiều
+ Bạn có thể tham khảo code của nợ này : ))))
https://www.cadtutor.net/forum/topic/30482-dim-radius/
Riêng code tự động đo góc thì không được hoàn thiện ( do chưa hiểu thông số tọa độ của nó ).
+ Code sai vòng lặp while.
(defun C:VBK( / DTUONG1 DTUONG2 )
(command "undo" "be")
(or (and bkinh (or (= (type bkinh) 'int) (= (type bkinh) 'real))) (setq bkinh 5.00))
(setq bkinh (cond ((getreal (strcat "\nNhap ban kinh cong (m) <" (rtos bkinh 2 2) ">: "))) (bkinh)))
(while
(and
(setq dtuong1 (car (entsel "\nChon doi tuong 1")))
(setq dtuong2 (car (entsel "\nChon doi tuong 2")))
); end and
(command "FILLET" dtuong1 dtuong2)
(command "DIMRADIUS" (list (entlast) (cdr (assoc 10 (entget (entlast)))) ) "_non" "")
)
(command "undo" "end")
(princ)
)
<<
|
Tác giả: ketxu
Bài viết gốc: 133876
Tên lệnh: dc |
Cách thống kê số lượng circle
Ồ có thể do máy bạn chưa cài Express ^^.Thôi bạn cứ dùng cách của bác TUệ đi ha :")
Nhưng mà vẫn phải sửa mới được ^^
(defun C:DC(/ e Ln Bn old X Res)
(vl-load-com)
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "CIRCLE"))))))
(setq Ln (append Ln (list (* 2 (cdr (assoc 40 (entget e)))))))
)
(foreach Bn Ln
(if (setq old (assoc Bn Res))
(setq Res (subst (cons bn...
>>
Ồ có thể do máy bạn chưa cài Express ^^.Thôi bạn cứ dùng cách của bác TUệ đi ha :")
Nhưng mà vẫn phải sửa mới được ^^
(defun C:DC(/ e Ln Bn old X Res)
(vl-load-com)
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "CIRCLE"))))))
(setq Ln (append Ln (list (* 2 (cdr (assoc 40 (entget e)))))))
)
(foreach Bn Ln
(if (setq old (assoc Bn Res))
(setq Res (subst (cons bn (1+ (cdr old))) old Res))
(setq Res (append Res (list (cons Bn 1))))
)
)
(foreach X Res (princ (strcat "\n" "So luong duong tron Duong kinh " (rtos (car X) 2 4) " = " (itoa (cdr X)))))
(princ)
)
<<
|
Tác giả: mr.thanh2610
Bài viết gốc: 438336
Tên lệnh: ha |
Về vấn đề lisp chọn đối tượng theo màu
Tình hình mình đang gặp một vấn đề về chọn đối tượng theo màu, em có sưu tầm một Lisp của bác Doan Van Ha nhưng gặp một số vấn đề:
1.Lisp chỉ chọn một số màu cơ bản còn một số màu khác chọn thì báo lỗi (hình đính kèm)
2.Em muốn quét chọn xong thì có thể chọn luôn đối tượng có thế copy, move... (chứ lisp này muốn copy thì phải dùng thêm lệnh copy và tham số...
>>
Tình hình mình đang gặp một vấn đề về chọn đối tượng theo màu, em có sưu tầm một Lisp của bác Doan Van Ha nhưng gặp một số vấn đề:
1.Lisp chỉ chọn một số màu cơ bản còn một số màu khác chọn thì báo lỗi (hình đính kèm)
2.Em muốn quét chọn xong thì có thể chọn luôn đối tượng có thế copy, move... (chứ lisp này muốn copy thì phải dùng thêm lệnh copy và tham số P) hơi lâu 1 tí ^_^
Nhờ anh, chị em nào sửa giúp mình với nhé, xin cảm ơn nhiều
P/S: mình dỡ mấy cái món này nên nhờ vả anh em hoài ngại quá :)
(defun c:ha () (setq ss (ssget (list (assoc 62 (entget (car (entsel "\nDoi tuong mau :"))))))))
<<
|
Tác giả: phamthanhbinh
Bài viết gốc: 361224
Tên lệnh: dopl |
Lisp dim khoảng cách liên tiếp trên Polyline - Pline
Trường hợp này không dùng hàm command được.
Bạn test thử code nhé :
>>
Trường hợp này không dùng hàm command được.
Bạn test thử code nhé :
(defun c:dopl()
(setq acadObj (vlax-get-acad-object))
(setq doc (vla-get-ActiveDocument acadObj))
(setq modelSpace (vla-get-ModelSpace doc))
(setq i 0)
(if (and (setq e (car(entsel "\n Chon Pline : "))) (setq ddat (getpoint (vlax-curve-getstartpoint e) "\nDist (Pick diem) :")))
(progn
(setq obj (vlax-ename->vla-object e))
(setq dis (distance ddat (vlax-curve-getclosestpointto e ddat)))
(Repeat (fix (vlax-curve-getEndParam e))
(if (= 0 (vla-GetBulge obj i))
(vla-AddDimAligned modelSpace
(vlax-3d-point (vlax-curve-getpointatparam e i)) (vlax-3d-point (vlax-curve-getpointatparam e (1+ i)) )
(vlax-3d-point (polar (vlax-curve-getpointatparam e (+ i 0.5))
(- (angle '(0 0 0) (vlax-curve-getFirstDeriv e (+ i 0.5))) (/ pi 2.0)) dis)
)
)
(vla-AddDimArc modelSpace (vlax-3d-point (mapcar '+ (vlax-curve-getpointatparam e (+ i 0.5)) (vlax-curve-getSecondDeriv e (+ i 0.5))))
(vlax-3d-point (vlax-curve-getpointatparam e i)) (vlax-3d-point (vlax-curve-getpointatparam e (1+ i)) )
(vlax-3d-point (polar (vlax-curve-getpointatparam e (+ i 0.5))
(- (angle '(0 0 0) (vlax-curve-getFirstDeriv e (+ i 0.5))) (/ pi 2.0)) dis)
)
)
);if
(setq i (1+ i))
);Repeat
);progn
);if
)
Hề hề hề,
Bác Tue_NV xem xét giùm vì sao khi tải lisp trên về thì không thể load lisp được. Nhưng khi mình copy code và đổi tên file cho nó thì lại load bình thường.
Khi load được lisp và xài thử thì lại bị thông báo rằng không có lệnh (vla-adddimarc ......... ) bác ạ.
<<
|
Filename: 361224_dopl.lsp
|
|
Tác giả: hoa tam that
Bài viết gốc: 77438
Tên lệnh: cd |
khi Cắt Dim để lại phần chân Dim dài bằng nhau !!!
Lời đầu tiên, Tue_NV xin góp ý chân thành với bạn hhhhgggg : Khi viết bài bạn nên nhìn nhận vấn đề một cách...
>>
Lời đầu tiên, Tue_NV xin góp ý chân thành với bạn hhhhgggg : Khi viết bài bạn nên nhìn nhận vấn đề một cách tổng quát và nói rõ vấn đề vì có thể mọi người không hiểu theo ý bạn và từ đó làm mất thời gian của chính mình và làm mất thời gian của người khác là điều không nên và phải tránh
Cứ như bài viết này, Tue_NV muốn giúp bạn mà chẳng biết làm thế nào nữa
http://www.cadviet.com/forum/index.php?showtopic=11138
Tue_NV đã chỉnh sửa lại Code trên. Hy vọng nó có ích cho mọi người.
Tên lệnh Cd
1. Lisp yêu cầu chọn DIM
2. Lisp yêu cầu : nhập khoảng cách đường dóng.
3. Lisp thực hiện công việc : cắt chân dim đã chọn với khoảng cách đường dóng do user nhập vào.
Lisp này có 1 điểm hay mà Tue_NV rất thích là ở bước thứ 2 : Nhập khoảng cách đường dóng
Khoảng cách đường dóng này mang ý nghĩa tương đối.
Khoảng cách đường dóng có thể là số dương (>0), có thể là số âm (<0) và có thể bằng 0
Và khoảng cách có thể pick 2 điểm trên màn hình. Lisp sẽ lấy khoảng cách 2 điểm pick trên màn hình làm khoảng cách đường dóng. Và khoảng cách khi ta pick 2 điểm này sẽ mang giá trị dương ( + )
Bạn hãy chạy thử và nghiệm ra điều mà Tue_NV nói.
Các bạn hãy cho ý kiến, nếu có gì chưa được thì Tue_NV sẽ sửa lại. Hy vọng nó có ích cho mọi người
(DEFUN C:CD (/ KC KCo CMD SS LTH DEM PT DS KDL N70 GOCX GOCY PT13 PT14 PTI PT13I PT14I
PT13N PT14N O13 O14 N13 N14 OSM OLDERR PT10 PT11)
(prompt "\n KS VO QUANG TUE")
(print)
(SETQ CMD (GETVAR "CMDECHO"))
(SETQ OSM (GETVAR "OSMODE"))
(SETQ OLDERR *error*
*error* myerror)
(PRINC " Moi Chon duong kich thuoc :")
(SETQ SS (SSGET'((0 . "DIMENSION"))))
(SETVAR "CMDECHO" 0)
(If (not KCo) (setq KCo 100))
(SETQ KC (GETDIST (strcat "\n Khoang cach cut dim : <" (rtos KCo 2 0) ">")))
(if (null KC) (setq KC KCo) (setq KCo KC))
(COMMAND "UCS" "W")
(SETQ LTH (SSLENGTH SS))
(SETQ DEM 0)
(WHILE (< DEM LTH)
(PROGN
(SETQ DS (ENTGET (SSNAME SS DEM)))
(SETQ KDL (CDR (ASSOC 0 DS)))
(IF (= "DIMENSION" KDL)
(PROGN
(SETQ PT10 (CDR (ASSOC 10 DS)))
(SETQ PT11 (CDR (ASSOC 11 DS)))
(SETQ PT13 (CDR (ASSOC 13 DS)))
(SETQ PT14 (CDR (ASSOC 14 DS)))
(SETQ N70 (CDR (ASSOC 70 DS)))
(IF (OR (= N70 32) (= N70 33) (= N70 160) (= N70 161))
(PROGN
(SETQ GOCY (ANGLE PT10 PT14))
(SETQ GOCX (+ GOCY (/ PI 2)))
)
)
(SETVAR "OSMODE" 0)
(setq PT (POLAR PT10 GOCY KC))
(SETQ PTI (POLAR PT GOCX 2))
(SETQ PT13I (POLAR PT13 GOCY 2))
(SETQ PT14I (POLAR PT14 GOCY 2))
(SETQ PT13N (INTERS PT PTI PT13 PT13I NIL))
(SETQ PT14N (INTERS PT PTI PT14 PT14I NIL))
(SETQ O13 (ASSOC 13 DS))
(SETQ O14 (ASSOC 14 DS))
(SETQ N13 (CONS 13 PT13N))
(SETQ N14 (CONS 14 PT14N))
(SETQ DS (SUBST N13 O13 DS))
(SETQ DS (SUBST N14 O14 DS))
(ENTMOD DS)
)
)
(SETQ DEM (+ DEM 1))
)
)
(COMMAND "UCS" "P")
(SETVAR "CMDECHO" CMD)
(SETVAR "OSMODE" OSM)
(setq *error* OLDERR) ; Restore old *error* handler
(PRINC)
)
bạn ơi
sau khi ap load kh
a kh ông sử dụng bằng lệnh cd được tại sao???
<<
|
Tác giả: danhyks
Bài viết gốc: 420176
Tên lệnh: cln |
Code Lấy Danh Sách Layout Theo Thứ Tự Có Sẵn
Thank bạn gia_bach nhé. Mình đã sử dụng và kết quả được như mong muốn, có điều bạn có thể giải thích giúp mình từ chỗ (setq vlayouts được không?
Đặc biệt mình sử dụng nhiều nhưng mình vẫn không hiểu được cấu trúc của lambda và mapcar trong Autolisp nữa.
Nhân tiện đây gởi mọi người code thay đổi tên layout theo cách như sau:
1. Chọn số thứ tự layout...
>>
Thank bạn gia_bach nhé. Mình đã sử dụng và kết quả được như mong muốn, có điều bạn có thể giải thích giúp mình từ chỗ (setq vlayouts được không?
Đặc biệt mình sử dụng nhiều nhưng mình vẫn không hiểu được cấu trúc của lambda và mapcar trong Autolisp nữa.
Nhân tiện đây gởi mọi người code thay đổi tên layout theo cách như sau:
1. Chọn số thứ tự layout cần đổi tên.
2. Thêm tiền tố cho layout
3. Thêm số sau layout.
Ví dụ: bạn có 10 layout tên từ 1->10 bạn muốn đổi tên layout thành A-11, A-12 ---> A-20 thì bạn nhập lệnh "cln" "1", "A", "11".
Mình thấy trên diễn đàn cũng có 1 số lisp tương tự nên không biết có bị trùng không.
;------------Change layout name-------------------
(defun c:cln (/ lst)
;^^^^^^^sorten theo danh sach------------
(vlax-map-collection
(vla-get-layouts (vla-get-activedocument (vlax-get-acad-object)))
'(lambda (x) (setq lst (cons x lst))))
;; sort in tab order
(setq lst (vl-sort lst '(lambda (x y)
(< (vla-get-taborder x) (vla-get-taborder y)))))
;; make list of names into strings remove Model space
(setq lst (vl-remove "Model" (mapcar '(lambda (x)(vla-get-name x))lst)))
(setq lt lst)
(setq n (length lt)
i (getint "\nSo thu tu layout can doi ten: ")
tt (getstring "\nTien to: ")
i (- i 1)
num (getint "\nHau to:")
)
(repeat n
(setq layname (nth i lt)
i (1+ i)
numstr (itoa num)
fin (strcase (strcat tt "-" numstr))
num (1+ num)
) ;;;;end setq
(command "-layout" "re" layname fin)
)
;;;;;;end of repeat
(princ)
)
<<
|
Tác giả: tien2005
Bài viết gốc: 439150
Tên lệnh: nht |
(GÓC NHỜ VẢ) XIN LISP TÍNH ĐỘ DỐC ĐOẠN THẲNG VÀ XÓA NHỮNG ĐOẠN THẲNG CÓ ĐỘ DỐC THEO ĐIỀU KIỆN
Bạn dùng cái này. Lệnh là NHT
(defun c:nht (/ EN L LAY LSP P X Y)
(while (setq en (entsel "\nChon duong pline"))
(setq en (car en))
(setq lay (cdr (assoc 8 (entget en))))
(setq lsp
(mapcar
'cdr
(vl-remove-if-not '(lambda (x) (= 10 (car x))) (entget en))
) ;_ end of mapcar
) ;_ end of setq
(mapcar
'(lambda (x y)
(setq l (mapcar '- x y))
(if (>=...
>>
Bạn dùng cái này. Lệnh là NHT
(defun c:nht (/ EN L LAY LSP P X Y)
(while (setq en (entsel "\nChon duong pline"))
(setq en (car en))
(setq lay (cdr (assoc 8 (entget en))))
(setq lsp
(mapcar
'cdr
(vl-remove-if-not '(lambda (x) (= 10 (car x))) (entget en))
) ;_ end of mapcar
) ;_ end of setq
(mapcar
'(lambda (x y)
(setq l (mapcar '- x y))
(if (>= (abs (/ (cadr l) (car l))) 0.3);DO DOC LON HON 30%
(entmakex
(append
(list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 2)
(cons 8 LAY)
) ;_ end of list
(mapcar (function (lambda (p) (cons 10 p))) (LIST X Y))
) ;_ end of append
) ;_ end of entmakex
) ;_ end of if
) ;_ end of lambda
lsp
(cdr lsp)
) ;_ end of mapcar
(entdel en)
) ;_ end of while
(princ)
) ;_ end of defun
<<
|
Tác giả: tien2005
Bài viết gốc: 439158
Tên lệnh: nht |
(GÓC NHỜ VẢ) XIN LISP TÍNH ĐỘ DỐC ĐOẠN THẲNG VÀ XÓA NHỮNG ĐOẠN THẲNG CÓ ĐỘ DỐC THEO ĐIỀU KIỆN
@hatrongquan88của bạn đây
(defun c:nht (/ EN L LAY LSP P X Y)
(princ "\nChon duong pline")
(while (setq en (ssget '((0 . "*POLYLINE"))))
(foreach en (vl-remove-if 'listp (mapcar...
>>
@hatrongquan88của bạn đây
(defun c:nht (/ EN L LAY LSP P X Y)
(princ "\nChon duong pline")
(while (setq en (ssget '((0 . "*POLYLINE"))))
(foreach en (vl-remove-if 'listp (mapcar 'cadr (ssnamex en)))
(setq lay (cdr (assoc 8 (entget en))))
(setq lsp
(mapcar
'cdr
(vl-remove-if-not '(lambda (x) (= 10 (car x))) (entget en))
) ;_ end of mapcar
) ;_ end of setq
(mapcar
'(lambda (x y)
(setq l (mapcar '- x y))
(if (>= (abs (/ (cadr l) (car l))) 0.3) ;DO DOC LON HON 30%
(entmakex
(append
(list (cons 0 "LWPOLYLINE")
(cons 100 "AcDbEntity")
(cons 100 "AcDbPolyline")
(cons 90 2)
(cons 8 LAY)
) ;_ end of list
(mapcar (function (lambda (p) (cons 10 p))) (LIST X Y))
) ;_ end of append
) ;_ end of entmakex
) ;_ end of if
) ;_ end of lambda
lsp
(cdr lsp)
) ;_ end of mapcar
(entdel en)
) ;_ end of foreach
) ;_ end of while
(princ)
) ;_ end of defun
<<
|
Tác giả: Doan Nguyen Van
Bài viết gốc: 439353
Tên lệnh: te |
Xin LISP tìm chữ gạch chân
14 phút trước, Nguyễn Thành CBG đã nói:
14 phút trước, Nguyễn Thành CBG đã nói:
Em lại gặp vẫn đề nữa là sau khi explode ra text, có nhiều dòng bị kiểu không liền thành 1 text mà nó lại tách hẳn ra thành nhiều text trong 1 dòng. Khiến cho lúc export ra excel để thống kê bị sai lệch khá nhiều :( Các bác có phương pháp nào cho cái mtext sau khi explode nó không bị thành nhiều text mỗi dòng không ạ
(defun c:te (/ ss lstl ent ss1 lst lst2 en en2 en3 str)
(vl-load-com)
(setq ss (acet-ss-to-list (ssget (list (cons 0 "MTEXT")))))
(setvar 'cmdecho 0)
(foreach ent ss
(setq ss1 (acet-ss-to-list (acet-explode ent)))
(setq ss1 (vl-sort ss1 '(lambda (x y) (cond ( (= (cadr (cdr (assoc 10 (entget x)))) (cadr (cdr (assoc 10 (entget y)))) )
(< (car (cdr (assoc 10 (entget x)))) (car (cdr (assoc 10 (entget y))))))
((> (cadr (cdr (assoc 10 (entget x)))) (cadr (cdr (assoc 10 (entget y)))))) ))))
(while (setq en (car ss1))
(setq ss1 (cdr ss1))
(setq lst2 (list en))
(while (and (setq en2 (car ss1))
(= (cadr (cdr (assoc 10 (entget en)))) (cadr (cdr (assoc 10 (entget en2)))) ) )
(setq ss1 (cdr ss1))
(setq lst2 (append lst2 (list en2)))
)
(if (> (length lst2) 1) (progn
(setq str "")
(mapcar '(lambda (x) (setq str (strcat str (cdr (assoc 1 (entget x)))))) lst2)
(setq en3 (car lst2))
(mapcar '(lambda (x) (entdel x) ) (cdr lst2))
(entmod (subst (cons 1 str) (assoc 1 (entget en3)) (entget en3)))
) )
)
)
(setvar 'cmdecho 1)
(princ)
)
Thử dùng lệnh này xem
<<
|
Tác giả: duy782006
Bài viết gốc: 439371
Tên lệnh: rdpl |
nhờ viết lisp đánh số thứ tự đỉnh Pline và đo kích thước tự động
Lệnh là RDPL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun pline>listdinh (curve / listd)
(if (wcmatch (cdr(assoc 0 (entget curve))) "*POLYLINE")
(foreach x (entget curve) (if (= (car x) 10) (setq listd (append listd (list(cdr x))))))
)
listd)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:rdpl ()
(setq...
>>
Lệnh là RDPL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun pline>listdinh (curve / listd)
(if (wcmatch (cdr(assoc 0 (entget curve))) "*POLYLINE")
(foreach x (entget curve) (if (= (car x) 10) (setq listd (append listd (list(cdr x))))))
)
listd)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:rdpl ()
(setq ddd (car (entsel "\nChon Pline:")))
(setq tapdinh (pline>listdinh ddd))
(setq tendinh 0)
(foreach tddinh tapdinh
(setq tendinh (+ 1 tendinh))
(setq tendinhnoi (strcat "D" (rtos tendinh 2 0)))
(entmake (list (cons 0 "TEXT")(cons 10 tddinh)(cons 11 tddinh)(cons 40 1)(cons 50 0)(cons 72 0)(cons 1 tendinhnoi)(cons 7 (getvar "TEXTSTYLE"))(cons 8 "layerkhac_text")(cons 62 256)))
(cond
((/= tendinh 1) (command ".DIMALIGNED" "_non" dinhcu "_non" tddinh "_non" tddinh))
)
(setq dinhcu tddinh)
)
)
<<
|
Filename: 439371_rdpl.lsp
|
|