| Info | File |
Tác giả: chien_lv
Bài viết gốc: 409312
Tên lệnh: e2x |
Xin lisp xuất bảng tổng hợp khối lượng sang excel
Xin giới thiệu với các bác đoạn lisp mà em mày mò mãi (với VBA thì vấn đề có vẻ đơn giản (các bác cao thủ nói vậy chứ em chưa...
>>
Xin giới thiệu với các bác đoạn lisp mà em mày mò mãi (với VBA thì vấn đề có vẻ đơn giản (các bác cao thủ nói vậy chứ em chưa thực hành VBA nhiều lắm) nhưng để làm "thuần lisp" thì phải ...tốn công fu hơn 
Lệnh e2x: chọn các text sắp xếp theo dạng bảng (ko cần căn thẳng hàng cột)
Kết quả: file xuất ra dưới dạng "giả excel" (Lisp chỉ làm được đến thế này thôi, bạn fải thêm một công ...open & save as --> Thành excel xịn ngay)
(defun myerror (s)
(cond
((= s "quit / exit abort") (princ))
((/= s "Function cancelled") (princ (strcat "\nError: " s)))
)
(setvar "cmdecho" CMD) ; Restore saved modes
(setvar "osmode" OSM)
(setq *error* OLDERR) ; Restore old *error* handler
(princ)
)
;;;=========================================================================
(defun bocchu (ss1 c)
(setq ob (entget (ssname ss1 c)))
(setq ts (assoc 1 ob))
(setq a (cdr ts))
)
(defun boc1chu (ob)
(if (/= ob nil)
(progn
(setq ts (assoc 1 ob))
(setq a (cdr ts))
)
)
)
(defun Txtnum (num)
(if (> num 0)
(strcat "+" (rtos num 2 0))
(rtos num 2 0)
)
)
;;;=================================
(defun Txtint (num)
(rtos num 2 0)
)
(defun Txtreal (num) (rtos num 2 2))
(defun Txtreal1 (num) (rtos num 2 0))
(defun thaychu (Ob newstr / obtmp)
(setq txtstr (assoc 1 Ob))
(setq newstr (cons 1 newstr)
obtmp (entmod (subst newstr txtstr Ob))
)
(entupd (cdr (assoc -1 obtmp)))
)
(defun chonchu (dongnhac)
(prompt dongnhac)
(ssget
'((-4 . "<OR") (0 . "text") (0 . "mtext") (0 . "ATTRIB") (-4 . "OR>"))
)
)
(defun chon1chu (dongnhac / obj objtype)
(if (setq obj (nentsel dongnhac))
(setq obj (entget (car obj))
objtype (cdr (assoc 0 obj))
)
)
(if (member objtype '("ATTRIB" "MTEXT" "TEXT"))
(setq obj obj)
)
)
(defun chon (str) (ssget '((cons (0 str)))))
(defun bamchon (st) (entget (car (entsel st))))
(defun bocdt (ss1 c) (entget (ssname ss1 c)))
;;;====================================================================
;;; Ham kiem tra xem mot so co nam trong day so ko voi sai so cho san
(defun memberp (num listn tsaiso / cter ni ntest test)
(setq cter 0
test nil
)
(while (< cter (length listn))
(setq ntest (nth cter listn)
sstest (abs (- num ntest))
)
(if (<= sstest tsaiso)
(setq cter (length listn)
test T
)
(setq cter (1+ cter))
)
)
(if test
(setq ntest ntest)
(setq ntest nil)
)
(setq ntest ntest)
)
;;;=======================================================================
;;;;=============================================================
;;; Chep du lieu bang ra file xls (du lieu lon xon khong thang hang cot)
(defun C:e2x (/ Txtline txtfile nrow ncol Filedir count count1 Cpright)
(setvar "cmdecho" 0)
(setq OldLay (getvar "Clayer"))
(Setq Cpright
"Copyright by NguyÔn Gia §¹t <Datnggia@gmail.com - 0915169886>"
)
(setq sstab (chonchu "\nChon bang du lieu ...")
sstmp sstab
cter 0
nn (sslength sstmp)
tabdata '()
htext 0
)
;;; loc ra bang du lieu
(while (< cter nn)
(setq objtxt (entget (ssname sstmp cter))
content (cdr (assoc 1 objtxt))
htext (+ htext (cdr (assoc 40 objtxt)))
objtype (cdr (assoc 0 objtxt))
)
(if (= objtype "TEXT")
(progn
(setq just (cdr (assoc 72 objtxt))
)
(if (= just 0)
(setq idtxt (cdr (assoc 10 objtxt)))
(setq idtxt (cdr (assoc 11 objtxt)))
)
)
(setq idtxt (cdr (assoc 10 objtxt)))
)
(setq
objdata (list content idtxt)
tabdata (append tabdata (list objdata))
cter (1+ cter)
)
)
;;; Tim so hang , so cot cua bang du lieu
(setq cter 0
saiso (* 5 (/ htext nn))
xlist '()
ylist '()
)
(repeat nn
(setq objdata (nth cter tabdata)
Pobj (car (cdr objdata))
xobj (car Pobj)
yobj (cadr Pobj)
cter (1+ cter)
)
(if (not (memberp yobj ylist (* saiso 0.1)))
(setq ylist (append ylist (list yobj)))
)
(if (not (memberp xobj xlist saiso))
(setq xlist (append xlist (list xobj)))
)
)
(setq
ncol (length xlist)
nrow (length ylist)
)
;;; Sap xep toa do x, y theo thu tu
(setq xlist (vl-sort xlist '<)
ylist (vl-sort ylist '>)
)
;;; Sap xep du lieu bang thanh hang, cot
(setq tabdata
(vl-sort tabdata
(function (lambda (objdata1 objdata2)
(< (cadr (car (cdr objdata1)))
(cadr (car (cdr objdata2)))
)
)
)
)
)
;;; Chia bang du lieu thanh hang, cot
(setq txtfile '()
ctrow 0
)
(repeat nrow
(setq txtline '()
yrow (nth ctrow ylist)
ctrow (1+ ctrow)
)
(setq txtrow '()
xlistrow '()
cter 0
)
(repeat nn
(setq txtobj (nth cter tabdata)
xobj (car (cadr txtobj))
yobj (cadr (cadr txtobj))
cter (1+ cter)
)
(if (<= (abs (- yrow yobj)) (* 0.1 saiso))
(setq txtrow (append txtrow (list txtobj))
xlistrow (append xlistrow (list xobj))
)
)
)
(setq txtrow
(vl-sort txtrow
(function (lambda (objdata1 objdata2)
(< (car (car (cdr objdata1)))
(car (car (cdr objdata2)))
)
)
)
)
)
(setq ctcol 0
cter1 0)
(repeat ncol
(setq
xcol (nth ctcol xlist)
txtobj (nth cter1 txtrow)
ctcol (1+ ctcol)
cter1 (1+ cter1)
)
(if (memberp xcol xlistrow saiso)
(setq content (strcat (car txtobj) "\t")
)
(setq content (strcat " " "\t")
cter1 (1- cter1))
)
(setq txtline (append txtline (list content))
)
)
(setq txtfile (append txtfile (list txtline)))
)
;;; Chon file luu so lieu
(Setq FileDir (getfiled "File luu so lieu:" "" "xls" 1)
)
(setq cter 0
count (length txtfile)
FileID (open FileDir "w")
)
(write-line "B¶ng d÷ liÖu trÝch xuÊt tõ AutoCAD" FileID)
;(write-line "Stt\tTªn nót\tTo¹ ®é X\tTo¹ ®é Y" FileID)
(while (< cter count)
(setq Txtline (nth cter txtfile)
cter (1+ cter)
cter1 0
content ""
)
(repeat ncol
(setq Content (strcat content (nth cter1 txtline))
cter1 (1+ cter1)
)
)
(setq txtline content)
(write-line Txtline FileID)
)
(write-line Cpright FileID)
(close FileID)
(princ)
)
Mình hỏi một chút là nếu tất cả các text cùng chiều (cùng nghiêng, hoặc cùng đứng thì ok) nhưng nếu không đồng nhất thì nó sẽ không xuất ra được file cho dù nó báo chọn được đối tượng
<<
|
Tác giả: tuanthunder
Bài viết gốc: 67269
Tên lệnh: coa |
Xin lisp copy align
Code đây : rất ngắn gọn
(defun c:COA()
(prompt "\n Chon doi tuong : ")
(setq ss (ssget))
(command "copy" ss "" '(0 0 0) "@")
(command "align" ss ""...
>>
Code đây : rất ngắn gọn
(defun c:COA()
(prompt "\n Chon doi tuong : ")
(setq ss (ssget))
(command "copy" ss "" '(0 0 0) "@")
(command "align" ss "" pause)
(princ)
)
Cảm ơn bác TUE_NV và các bác rất nhiều. Lisp đã đúng theo ý muốn của em.
<<
|
Tác giả: namnhim
Bài viết gốc: 334659
Tên lệnh: ha |
Nhờ viết lisp chọn nhanh text cùng nội dung
Đây bạn ơi! Lisp chọn text cùng nội dung.
(defun C:HA( / txt)
(setq txt (cdr (assoc 1 (entget (car...
>>
Đây bạn ơi! Lisp chọn text cùng nội dung.
(defun C:HA( / txt)
(setq txt (cdr (assoc 1 (entget (car (entsel "\nChon Text mau: "))))))
(princ "\nChon nhom Text...")
(setq ss (ssget (list '(0 . "*TEXT") (cons 1 txt))))
(sssetfirst nil ss))
nhờ các bác giựa vào code loc text này giúp em chọn các Text có cùng nội dung trong các thửa đất liền kề và sau đó BOUNDARY các thửa đó thành 1 đường bao các thửa ngoài xung quanh các thửa đó với ạ! có bệnh vái tứ phương nhưng chưa có thuốc trị, nhờ các bác giúp em với!
http://www.cadviet.com/upfiles/4/62465_khoanh_ve.dwg
<<
|
Tác giả: quangleho
Bài viết gốc: 215509
Tên lệnh: bkl |
lệnh mở khoá tất cả các lớp
Lao gia trần này lười quá, bó tay...
Lão thử cái lisp này xem có hợp ý ko nha, lệnh là BKL (bỏ khoá lớp)...
>>
Lao gia trần này lười quá, bó tay...
Lão thử cái lisp này xem có hợp ý ko nha, lệnh là BKL (bỏ khoá lớp) :
(defun C:BKL () (command "-Layer" "Unlock" "*" "") (prompt "\n>>> Tat ca cac lop da duoc bo khoa - Unlock all layer - he he..."))
Lão "ap" để load cái lisp này vào để chạy nhé, hoặc cho nó vào startup suite của Cad...
Rất chuẩn...Thanks nhé!
<<
|
Tác giả: trieubb
Bài viết gốc: 252791
Tên lệnh: ha |
Lisp thống kê đoạn thẳng
Sửa cho bạn đây. Lisp có thể dùng cho Line, Polyline, Lwpolyline, Spline.
;Doan Van Ha -...
>>
Sửa cho bạn đây. Lisp có thể dùng cho Line, Polyline, Lwpolyline, Spline.
;Doan Van Ha - CADViet.com - Ngay 16/5/2012. Edit 11/7/2013
;Muc dich: nhom cac doi tuong *Line cung Length va cung Layer, sau do xuat ra file.
(defun C:HA( / entlst lst fn pw)
(princ "\nChon cac doi tuong de lay chieu dai can xuat ra file...")
(setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget (list (cons 0 "*LINE")))))))
(foreach ent entlst
(setq lst (cons (list (cdr (assoc 8 (entget ent))) (atof (rtos (vlax-curve-getDistAtParam ent (vlax-curve-getEndParam ent)) 2 4))) lst)))
(setq lst (LM:ListOccurrences lst))
(setq fn (getfiled "Chon file de xuat ket qua" "" "xls" 1))
(setq pw (open fn "w"))
(write-line (strcat "Chieu dai" "\t" "So luong" "\t" "Layer") pw)
(foreach n lst
(write-line (strcat (vl-prin1-to-string (cadr (car n))) "\t" (itoa (cdr n)) "\t" (car (car n))) pw))
(close pw) )
(defun LM:ListOccurrences (lst) ;Thank Lee Mac
(if lst
(cons
(cons (car lst) (- (length lst) (length (vl-remove (car lst) (cdr lst)))))
(LM:ListOccurrences (vl-remove (car lst) (cdr lst))))))
Lệnh rất hay bác ạ nhưng bác có thể viết them 1 cái là chỉ cần thống kê chiều dài và tên layer ra luôn bản vẽ và đặt cạnh từng đoạn luôn không bác, thanks bác nhiều.Chờ tin bác
<<
|
Tác giả: phamthanhbinh
Bài viết gốc: 57256
Tên lệnh: cdm |
Lisp gán text vào polyline
Bạn dùng cái này xem:
(defun C:CDM (/ cdo next dem)
(START_PG)
(setq phuongan (I_KEY "\nChon kieu nhap (theo Buoc lien tuc/theo Text co san)" "B T" phuongan))
(cond ( (=...
>>
Bạn dùng cái này xem:
(defun C:CDM (/ cdo next dem)
(START_PG)
(setq phuongan (I_KEY "\nChon kieu nhap (theo Buoc lien tuc/theo Text co san)" "B T" phuongan))
(cond ( (= phuongan "B")
(setq cdo (I_REAL "\n Nhap cao do ban dau" cdo)
ccao (I_REAL "\n Nhap chenh cao giua cac duong dong muc" ccao)
next (strcat "dau tien (cao do la: " (rtos cdo 2 2) ")")
dem 0
)
(while (setq pline (entsel (strcat "\n Chon duong dong muc " next)))
(if (and (or (= (cdr (assoc 0 (entget (car pline)))) "POLYLINE")
(= (cdr (assoc 0 (entget (car pline)))) "LWPOLYLINE")
)
(/= (cdr (assoc 8 (entget (car pline)))) "DM so hoa")
)
(progn
(cond ( (= (length (assoc 10 (entget (car pline)))) 4)
(setq tdN (R_POS (assoc 10 (entget (car pline))) (list 0.0 0.0 0.0 cdo) "z"))
(entmod (subst tdN (assoc 10 (entget (car pline))) (entget (car pline))))
)
( (= (length (assoc 10 (entget (car pline)))) 3)
(entmod (subst (cons 38 cdo) (assoc 38 (entget (car pline))) (entget (car pline))))
)
)
(entmod (subst (cons 8 "DM so hoa") (assoc 8 (entget (car pline))) (entget (car pline))))
(setq dem (1+ dem)
cdo (+ cdo ccao)
next (strcat "thu " (itoa dem) " (cao do la: " (rtos cdo 2 2) ") /An enter de ket thuc chon")
)
)
(alert "Chon lai!!! . Doi tuong ban vua chon khong phai la Polyline hoac da duoc so hoa")
)
)
)
( (= phuongan "T")
(while (and (not (prompt "\n Chon duong dong muc /Enter de ket thuc... " ))
(setq pline (if (setq ss (ssget '((-4 . ""))))
(ssname ss 0)
nil)
)
)
(setq cdo (V_T (ssname (ES_TM "\nChon Text chua cao do") 0)))
(if (and (or (= (cdr (assoc 0 (entget pline))) "POLYLINE")
(= (cdr (assoc 0 (entget pline))) "LWPOLYLINE")
)
(/= (cdr (assoc 8 (entget pline))) "DM so hoa")
)
(progn
(cond ( (= (length (assoc 10 (entget pline))) 4)
(setq tdN (R_POS (assoc 10 (entget (car pline))) (list 0.0 0.0 0.0 cdo) "z"))
(entmod (subst tdN (assoc 10 (entget (car pline))) (entget (car pline))))
)
( (= (length (assoc 10 (entget pline))) 3)
(entmod (subst (cons 38 cdo) (assoc 38 (entget pline)) (entget pline)))
)
)
(entmod (subst (cons 8 "DM so hoa") (assoc 8 (entget pline)) (entget pline)))
)
(alert "Chon lai!!! . Doi tuong ban vua chon khong phai la Polyline hoac da duoc so hoa")
)
)
)
)
(END_PG)
)
Các hàm con của chương trình này bạn download tại đây
Bác Nacata ơi,
Hình như lisp của bác bị lỗi thiếu ký tự ">" hay sao ấy bác ạ.
<<
|
Tác giả: hoquangvinh
Bài viết gốc: 253450
Tên lệnh: 3d-%3E2d |
Giúp đỡ về lệnh Convert 3D polyline to Polyline
thiep, on 15 Oct 2009 - 14:21, said:
Vẫn còn 1 cách nữa, xin tiếp cận tạo lisp để Convert 3D polyline to Polyline với các các hàm acet-... mà...
>>
thiep, on 15 Oct 2009 - 14:21, said:
Vẫn còn 1 cách nữa, xin tiếp cận tạo lisp để Convert 3D polyline to Polyline với các các hàm acet-... mà không cần nổ đối tượng:
;| Convert 3D polyline to Polyline Lispyeu cau: express tools day du|; (defun c:3d->2d (/ ssg ss lstptmp e L) (prompt "\nSelect polyline: ") (setq ssg (ssget '((0 . "POLYLINE"))) lstptmp nil i 0) (while (< i (sslength ssg)) (setq e (ssname ssg i)) (setq L (ACET-GEOM-VERTEX-LIST e)) (foreach ptemp L (setq lstptmp (append lstptmp (list(list (car ptemp) (cadr ptemp))))) ) (ACET-LWPLINE-MAKE (List lstptmp)) (setq i (1+ i) lstptmp nil ) (entdel e) ) (princ))
Trong mấy cái trên mình thử và ko dùng đc cái nào cả mỗi cái này là chuyển về polyline đc
<<
|
|
Filename: 253450_3d-%3E2d.lsp
|
|
Tác giả: sck84
Bài viết gốc: 163557
Tên lệnh: bh |
lisp bo hatch
Bạn dùng thử cái này xem sao:
(defun c:bh( / sl n)
(setq sl (acet-ss-to-list(ssget '((0 . "HATCH")))))
(foreach n...
>>
Bạn dùng thử cái này xem sao:
(defun c:bh( / sl n)
(setq sl (acet-ss-to-list(ssget '((0 . "HATCH")))))
(foreach n sl
(command "hatchedit" n "b" "p" "y" "")
)
)
cám ơn bác nhiều nhé! lisp này dùng phê quá
<<
|
Tác giả: 790312
Bài viết gốc: 239186
Tên lệnh: ha |
Lisp chọn nhanh block cùng nội dung ATT
Lisp chọn các Block theo: NameBlock + TagAtt + ValueAtt
;Doan Van Ha - CADViet.com - Ngay...
>>
Lisp chọn các Block theo: NameBlock + TagAtt + ValueAtt
;Doan Van Ha - CADViet.com - Ngay 04/7/2012
;Muc dich: Chon cac Blocks theo NameBlock, TagAtt, ValueAtt.
(defun C:HA( / ent ass blk entlst)
(vl-load-com)
(if
(and
(setq ent (car (nentsel "\nPick chon Att trong Block mau: ")))
(= "ATTRIB" (cdr (assoc 0 (entget ent)))))
(progn
(setq ass (cons (cdr (assoc 2 (entget ent))) (cdr (assoc 1 (entget ent)))))
(setq blk (cdr (assoc 2 (entget (cdr (assoc 330 (entget ent)))))))
(setq ss (ssadd))
(princ "\nChon cac Block_Att...")
(setq entlst (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget (list '(0 . "INSERT") '(66 . 1) (cons 2 blk)))))))
(foreach ent entlst
(if (member ass (GetAtt (vlax-ename->vla-object ent)))
(setq ss (ssadd ent ss))))
(sssetfirst nil ss))))
(defun GetAtt (obj)
(mapcar '(lambda (att) (cons (vla-get-TagString att) (vla-get-TextString att))) (vlax-invoke obj 'GetAttributes)))
P/S: đã hiệu chỉnh để tránh chọn nhầm đối tượng
Bác Hà thêm giùm sau khi chọn các block có valua cần chọn thì nó ẩn các đối tượng khác đi,chỉ hiện các block này thôi!Cảm ơn bác nhiều.
<<
|
Tác giả: thanhduan2407
Bài viết gốc: 98584
Tên lệnh: mh |
làm thế nào để nối hatch???
Lệnh MH (Merge Hatch) dưới đây sẽ thực hiện điều bạn muốn. Chương trình yêu cầu người sử select các hatch, sau đó nối chúng lại với nhau thành 1 hatch đơn...
>>
Lệnh MH (Merge Hatch) dưới đây sẽ thực hiện điều bạn muốn. Chương trình yêu cầu người sử select các hatch, sau đó nối chúng lại với nhau thành 1 hatch đơn nhất.
Thuộc tính (layer, màu, kiểu hatch, ...) của hatch kết quả được lấy theo đối tượng hactch đầu tiên. Mẹo: Khi các hatch không giống nhau, muốn đối tượng sau khi merge giống hatch nào thì nên pick hatch đó đầu tiên, sau đó mới select các hatch khác.
(defun c:mh (/ ss entht sl i dt dtht)
(princ "\nMerge Hatch - free lisp from CADViet.com")
(setq
ss (ssget '((0 . "HATCH")))
sl (if ss
(sslength ss)
0
)
i 0
l 0
)
(repeat sl
(setq
entht (ssname ss i)
dtht (getbdata entht)
dt (append dt dtht)
l (+ l (cdr (assoc 91 (entget entht))))
i (1+ i)
)
)
(setq ent (ssname ss 0)
ss (ssdel ent ss)
tt (entget ent)
duoi (member (assoc 75 tt) tt)
dau (reverse (member (assoc 91 tt) (reverse tt)))
tt (append dau dt duoi)
tt (subst (cons 91 l) (assoc 91 tt) tt)
)
(entmod tt)
(command ".erase" ss "")
(princ)
)
(defun getbdata (ent)
(setq tt (entget ent)
tt (cdr (member (assoc 75 tt) (reverse tt)))
tt (cdr (member (assoc 91 tt) (reverse tt)))
)
)
(princ "\nMerge Hatch is loaded, please type MH to start!")
(princ)
Cám ơn bác hoành rất nhiều
Em đã đọc rất nhiều bài post của bác trên mạng và rất phục bác
Em cũng đang giai đoạn tìm hiểu về lisp và ứng dụng cho chuyên ngành của mình
Em là dân Trắc Địa bác ạ nên cần phải năng động cho lĩnh vực xử lý tính toán số liệu của mình
Em rất mong bác giúp đỡ em một số bài toán mà em đang vướng mắc
Bác có thể nêu cấu trúc đọc từng dòng của 1 file dữ liệu với một vài kiểu khuôn dạng trong từng dòng
VD đọc dữ liệu với 3 dòng được lặp đi lặp lại:
dòng 1: kiểu a
dòng 2 Kiể b
dòng 3 Kiểu c
dòng 4: kiểu a
dòng 5 Kiể b
dòng 6 Kiểu c
.....
Tiện thể bác có thế giúp em lập trình một hàm tách xâu ký tự trên một dòng mà các số liệu được phân biệt bởi dấu cách,hoặc dấu tab, hoặc dấu phẩy
VD dấu tab
1 1035846.246 597526.601 -1.23
2 1035853.471 597526.324 -2.09
3 1035862.06 597523.732 -2.93
VD dấu cách
1 1035846.246 597526.601 -1.23
2 1035853.471 597526.324 -2.09
3 1035862.06 597523.732 -2.93
VD dấu phẩy
1,1035846.246,597526.601,-1.23
2,1035853.471,597526.324,-2.09
3,1035862.06,597523.732,-2.93
Em cảm ơn bác rất nhiều
Có gì bác có thể gửi cho em tài liệu hoặc câu trả lời qua Email : thanhduan_mda@yahoo.com
Em chân thành cảm ơn bác
<<
|
Tác giả: quochuyksxd
Bài viết gốc: 328145
Tên lệnh: ktd |
Cần lisp kiểm tra dim bị edit
Thử xem :)
(defun C:KTD( / ss ena txt n kq)
(setq ss (ssget "X" '((0 . "DIMENSION"))))
(setq n 0)
(if (not (tblsearch...
>>
Thử xem :)
(defun C:KTD( / ss ena txt n kq)
(setq ss (ssget "X" '((0 . "DIMENSION"))))
(setq n 0)
(if (not (tblsearch "layer" "Dimed"))
(vl-cmdf "Layer" "N" "Dimed" "C" "1" "Dimed" "")
)
(while (setq ena (ssname ss 0))
(setq txt (cdr (assoc 1 (entget ena))))
(if (not (or (= txt "") (vl-string-search "<>" txt))) (progn
(vl-cmdf "change" ena "" "p" "LA" "Dimed" "")
(vl-cmdf "._DIMOVERRIDE" "dimclrt" 1 "" ena "" )
(setq n (1+ n))
))
(ssdel ena ss)
)
(if (= n 0) (setq kq "Ket qua check: OK")
(setq kq (strcat "Co " (itoa n) " Dimensions bi sua Text"
"\nda duoc chuyen sang layer Dimed co mau 1!")
)
)
(alert kq)
(princ))
Test bản vẽ bạn đâu thấy dim nào thay đổi text override <_<
Chuẩn rồi bác Nhoclangbat. Cảm ơn bác nhiều nhé. Nể mấy bác "cao thủ" làm thủ công vẫn tìm hết dim bị ed quá :)
<<
|
Tác giả: cuthanhvuong
Bài viết gốc: 235178
Tên lệnh: od oc oca |
Cần Lisp đánh số thứ tự theo dạng Block ATT
Bạn đã search chưa ??
Bạn dùng thử lisp của bác ssg viết cách đây...3 năm
;;...
>>
Bạn đã search chưa ??
Bạn dùng thử lisp của bác ssg viết cách đây...3 năm
;; free lisp from cadviet.com
;;;**********************************************
;;;CHUONG TRINH DANH SO THU TU VA COPY TANG DAN
;;;1. Lenh OD: danh so thu tu, tuy chon so bat dau (begin) va so gia (increment) tuy y
;;;2. Lenh OC: copy tang dan tu mot so thu tu co san
;;;3. Lenh oCA: copy tang dan voi doi tuong Attribute Block
;;;Chuong trinh chap nhan cac dinh dang bang so, chu, so va chu ket hop:
;;;1, 2... A, B..., A1, A2..., AB-01, AB-02..., AB-01-C1, AB-01-C2...
;;;Cac chu gioi han trong khoang tu A den Z. Cac so khong han che
;;;Copyright by ssg - www.cadviet.com - December 2008
;;;**********************************************
;;;-------------------------------------------------
(defun etype (e) ;;;Entity Type
(cdr (assoc 0 (entget e)))
)
;;;-------------------------------------------------
(defun wtxt (txt p / sty d h) ;;;Write txt on graphic screen, defaul setting
(setq
sty (getvar "textstyle")
d (tblsearch "style" sty)
h (cdr (assoc 40 d))
)
(if (= h 0) (setq h (cdr (assoc 42 d))))
(entmake
(list (cons 0 "TEXT") (cons 7 sty) (cons 1 txt) (cons 10 p) (cons 40 h) (assoc 41 d))
)
)
;;;-------------------------------------------------
(defun incN (n dn / n2 i n1) ;;;Increase number n
(setq
n2 (itoa (+ dn (atoi n)))
i (- (strlen n) (strlen n2))
)
(if (> i 0) (setq n1 (substr n 1 i)) (setq n1 ""))
(strcat n1 n2)
)
;;;-------------------------------------------------
(defun incC (c / i c1 c2) ;;;Increase character c
(setq
i (strlen c)
c1 (substr c 1 (- i 1))
c2 (chr (1+ (ascii (substr c i 1))))
)
(if (or (= c2 "{") (= c2 "["))
(progn (command "erase" (entlast) "") (alert "Over character!") (exit))
(strcat c1 c2)
)
)
;;;============================
(defun C:OD( / cn dn c n p) ;;;Make OrDinal number with any format
(setq
cn (getstring "\nBegin at <1>: " T)
dn (getint "\nIncrement <1>: ")
)
(if (not dn) (setq dn 1))
(if (= cn "") (setq cn "1"))
(setq c (vl-string-right-trim "0 1 2 3 4 5 6 7 8 9" cn))
(setq n (vl-string-subst "" c cn))
(if (/= n "") (setq mode 1) (setq mode 0))
(while (setq p (getpoint "\nBase point <exit>: "))
(wtxt cn p)
(if (= n "")
(setq cn (incC cn))
(setq cn (strcat c (incN (vl-string-subst "" c cn) dn)))
)
)
(princ)
)
;;;============================
(defun C:OC( / e dn p1 cn c n p2 dat) ;;;Make Ordinal number. Copy from template
(setq
e (car (entsel "\nSelect template text:"))
dn (getint "\nIncrement <1>: ")
p1 (getpoint "\nBase point:")
cn (cdr (assoc 1 (entget e)))
)
(if (not dn) (setq dn 1))
(if (= cn "") (setq cn "1"))
(setq
c (vl-string-right-trim "0 1 2 3 4 5 6 7 8 9" cn)
n (vl-string-subst "" c cn)
)
(while (setq p2 (getpoint p1 "\nNew point <exit>: "))
(command "copy" e "" p1 p2)
(if (= n "")
(setq cn (incC cn))
(setq cn (strcat c (incN (vl-string-subst "" c cn) dn)))
)
(setq
dat (entget (entlast))
dat (subst (cons 1 cn) (assoc 1 dat) dat)
)
(entmod dat)
)
(princ)
)
;;;============================
(defun C:oCA( / e e0 dn p1 cn c n p2 dat) ;;;Make Ordinal number. Copy from Atttribute block
(setq
e0 (car (entsel "\nSelect attribute block:"))
e (entnext e0)
)
(if (/= (etype e) "ATTRIB") (progn (alert "Object is not a Attribute Block!") (exit)))
(setq
dn (getint "\nIncrement <1>: ")
p1 (getpoint "\nBase point:")
cn (cdr (assoc 1 (entget e)))
)
(if (not dn) (setq dn 1))
(if (= cn "") (setq cn "1"))
(setq
c (vl-string-right-trim "0 1 2 3 4 5 6 7 8 9" cn)
n (vl-string-subst "" c cn)
)
(while (setq p2 (getpoint p1 "\nNew point <exit>: "))
(command "copy" e0 "" p1 p2)
(if (= n "")
(setq cn (incC cn))
(setq cn (strcat c (incN (vl-string-subst "" c cn) dn)))
)
(setq
dat (entget (entnext (entlast)))
dat (subst (cons 1 cn) (assoc 1 dat) dat)
)
(entmod dat)
(command "regen")
)
(princ)
)
;;;============================
À MÌNH ĐÃ BIẾT CÁCH SỬ DỤNG LỆNH OC VÀ OD NHƯNG CÁI OCA THÌ LẠI KHÔNG BIẾT ỨNG DỤNG ĐỂ LÀM GÌ BẠN CÓ THỂ CHO MÌNH BIẾT ĐƯỢC KHÔNG? CÁM ƠN BẠN VÌ BÀI VIẾT
<<
|
|
Filename: 235178_od_oc_oca.lsp
|
|
Tác giả: hungptbk
Bài viết gốc: 146460
Tên lệnh: cad2geo |
Cần lisp chuyển dwg/dxf sang Plaxis
Lisp dưới đây sẽ giúp bạn chuyển dữ liệu từ AutoCAD sang file . Tên lệnh là cad2geo
The lisp routine...
>>
Lisp dưới đây sẽ giúp bạn chuyển dữ liệu từ AutoCAD sang file . Tên lệnh là cad2geo
The lisp routine below will help you to transfer data from AutoCAD to file format. Command's name is cad2geo
(defun dxf(ent code)
(cdr (assoc code (entget ent)))
)
(defun p2s(p)
(apply 'strcat (mapcar '(lambda (x) (fullstr (rtos x 2 Accuracydigit) 14)) p))
)
(defun line2param(ent)
(list (p2s (dxf ent 10)) (p2s (dxf ent 11)))
)
(defun lwpolyline2param(ent / tt z)
(setq
z (dxf ent 38)
tt (vl-remove-if '(lambda (x) (/= (car x) 10) ) (entget ent))
tt (mapcar '(lambda (x) (p2s (append (cdr x) (list z)))) tt)
)
tt
)
(defun polyline2param(ent / kq)
(setq ent (entnext ent)
kq nil)
(while (and ent (= (dxf ent 0) "VERTEX"))
(setq kq (append kq (list (p2s (dxf ent 10))))
ent (entnext ent)
)
)
kq
)
(defun getpointindex(pp / tmp)
(if (setq tmp (member pp points))
(1+ (- (length points) (length tmp)))
(length (setq points (append points (list pp))))
)
)
(defun fullstr(str num / sl)
(setq sl (- num (strlen str)))
(repeat sl
(setq str (strcat " " str))
)
)
(defun converttogeometry()
(setq
index 0
sl (if ss (sslength ss) 0)
)
(repeat sl
(setq ent (ssname ss index)
)
(cond
((= (dxf ent 0) "LINE") (setq tmp (line2param ent)))
((= (dxf ent 0) "LWPOLYLINE") (setq tmp (lwpolyline2param ent)))
(T (setq tmp (polyline2param ent)))
)
(setq pline (strcat (fullstr (itoa (length tmp)) 5) " - points on layerboundary" (fullstr (itoa index) 6) "\n ")
currentnumberinrow 0)
(foreach point tmp
(setq pline (strcat pline (fullstr (itoa (getpointindex point)) 5))
currentnumberinrow (1+ currentnumberinrow))
(if (>= currentnumberinrow 10)
(progn
(setq currentnumberinrow 0
pline (strcat pline "\n "))
)
)
)
(setq plines (append plines (list pline))
index (1+ index))
)
(princ)
)
(defun getinput()
(princ "\nPlease select LINE, POLYLINE: ")
(setq ss (ssget '((0 . "*LINE")))
Accuracydigit (getint "\nEnter a integer value to choose Accuracy level (1=0.1, 2=0.01, 3=0.001,...)<2>: ")
Accuracydigit (if Accuracydigit Accuracydigit 2)
fname (getfiled "Please specify file" (getvar "dwgprefix") "geo" 1)
)
)
(defun expten(count / kq)
(setq kq 1.0)
(repeat count
(setq kq (* 10.0 kq))
)
)
(defun writeoutput()
(setq fhnd (open fname "w"))
(if (not fhnd)
(alert (strcat "error when write to " fname))
(progn
(write-line (strcat
"GEOMETRY FILE FOR THE M-SERIES\n"
"==============================================================================\n"
"========================== BEGINNING OF DATA ==========================\n"
"POINTS Accuracy = " (fullstr (rtos (/ 1.0 (expten Accuracydigit)) 2 4) 12) "\n"
(fullstr (itoa (length points)) 5) " - Number of geometry-points -"
)
fhnd
)
(setq index 1)
(foreach point points
(write-line (strcat (fullstr (itoa index) 8) point) fhnd)
(setq index (1+ index))
)
(write-line "LAYERS" fhnd)
(write-line (strcat (fullstr (itoa (1- (length plines))) 5) " - Number of layers -") fhnd)
(setq index 0)
(foreach pline plines
(write-line pline fhnd)
(setq index (1+ index))
)
(write-line "" fhnd)
(write-line "END OF DATA FILE" fhnd)
(close fhnd)
)
)
)
(defun c:cad2geo( / ss)
(setq points nil)
(setq plines nil)
(getinput)
(converttogeometry)
(writeoutput)
(alert "Export to file successfully!")
(princ)
)
Bác cho em hỏi là lisp này của Bác sao chỉ có thể export Line nhưng Circle thì không được. Em đang cần lisp này nhưng không biết phải edit đoạn code nào để có thể export thêm được Circle. Mong Bác chỉ giáo. Thanks Bác Nguyen Hoanh
<<
|
|
Filename: 146460_cad2geo.lsp
|
|
Tác giả: pawuta
Bài viết gốc: 344374
Tên lệnh: atc | |
Tác giả: tuvanthietke.hcm
Bài viết gốc: 139525
Tên lệnh: matext |
Giúp mình change width factor của Text
Của bạn đây. Hi vọng bạn hài lòng
(defun c:matext()
(vl-load-com)
(setq ent (entget(car(entsel " chon text mau:...
>>
Của bạn đây. Hi vọng bạn hài lòng
(defun c:matext()
(vl-load-com)
(setq ent (entget(car(entsel " chon text mau: ")))
sslist (acet-ss-to-list(ssget '((0 . "*TEXT"))))
)
(foreach n sslist
(entmod(subst (assoc 41 ent) (assoc 41 (entget n)) (entget n)))
(entmod(subst (assoc 7 ent) (assoc 7 (entget n)) (entget n)))
)
)
Cảm ơn bạn, nhưng mình vẫn không change được width factor? bạn có thể giúp mình
<<
|
|
Filename: 139525_matext.lsp
|
|
Tác giả: nhocbabi
Bài viết gốc: 64796
Tên lệnh: dopl |
đo đường polyline
Bạn chạy thử Lisp này xem : Lisp đo cả 1 đoạn của Line, Pline, Arc, Circle, Spline, elipse
(defun c:dopl()
(vl-load-com)
(setq curve (car(entsel"\n Chon Polyline...
>>
Bạn chạy thử Lisp này xem : Lisp đo cả 1 đoạn của Line, Pline, Arc, Circle, Spline, elipse
(defun c:dopl()
(vl-load-com)
(setq curve (car(entsel"\n Chon Polyline :")))
(setq ddau (getpoint"\n Pick diem dau can do :"))
(setq dcuoi (getpoint"\n Pick diem dau can do :"))
(setq d1 (vlax-curve-getDistAtPoint curve ddau))
(setq d2 (vlax-curve-getDistAtPoint curve dcuoi))
(alert (strcat " L = " (rtos (abs (- d1 d2)) 2 0)))
(princ)
)
:D
Em vừa load về dùng thử, đã có kết quả rồi ạ anh ạ :lol2: . Nhưng anh cho em hỏi thêm một chút là có thể có lisp đo chiều dài của đoạn polyline ấy bằng một dimstyle hiện hành không ạ! :lol2:
<<
|
Tác giả: huyenbn
Bài viết gốc: 64788
Tên lệnh: dopl |
đo đường polyline
Bạn chạy thử Lisp này xem : Lisp đo cả 1 đoạn của Line, Pline, Arc, Circle, Spline, elipse
(defun c:dopl()
(vl-load-com)
(setq curve (car(entsel"\n Chon Polyline...
>>
Bạn chạy thử Lisp này xem : Lisp đo cả 1 đoạn của Line, Pline, Arc, Circle, Spline, elipse
(defun c:dopl()
(vl-load-com)
(setq curve (car(entsel"\n Chon Polyline :")))
(setq ddau (getpoint"\n Pick diem dau can do :"))
(setq dcuoi (getpoint"\n Pick diem dau can do :"))
(setq d1 (vlax-curve-getDistAtPoint curve ddau))
(setq d2 (vlax-curve-getDistAtPoint curve dcuoi))
(alert (strcat " L = " (rtos (abs (- d1 d2)) 2 0)))
(princ)
)
:lol2:
Tiện đây em xin hoi bác, bác có llisp nao có thể đo chiều dài của cả một mặt bằng không, ví như đo chiều dài dây dẫn của một mặt bằng cấp điện vậy.
<<
|
Tác giả: dung12789
Bài viết gốc: 199442
Tên lệnh: elale |
Lisp lấy cao độ và khoảng cách lẻ giữa các đỉnh của pline
Hề hề hề,
Redsea_tq đi vắng, bạn dùng thử cái này coi đã ưng ý chưa nhé.
Mình test thử trên file bản vẽ bạn...
>>
Hề hề hề,
Redsea_tq đi vắng, bạn dùng thử cái này coi đã ưng ý chưa nhé.
Mình test thử trên file bản vẽ bạn gửi thì cao độ ra đúng nhưng chiều dài từng khúc trên pline có sai lệch nhất định. Có lẽ là do bạn đã tính toán bằng tay nên sinh ra sai số. Còn mình tin là lisp chạy không sai.
Do bạn không nói rõ các yêu cầu nên mình tạm thời để bạn tự chọn chiều cao text, vị trí đặt text sao cgo vừa mắt bạn. Nếu bạn có thể xác định vị trí của các text theo một quy luật nào đó thì mình có thể chỉnh sửa điều này.
Đây chỉ là lisp sơ bộ bước đầu theo ý phỏng đoán của mình về yêu cầu của bạn nên có thể chưa thực sự đạt yêu cầu. muốn hoàn thiện nó bạn cần phải nói rõ hơn các yêu cầu của bạn mới được.
Rất mong bạn test thử và cho ý kiến.
(defun c:elale ()
(vl-load-com)
(command "undo" "be")
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(setq en (car (entsel "\n Chon pline la duong nghiem thu "))
plst (acet-geom-vertex-list en)
pg (getpoint "\n Chon diem goc tinh toan")
hg (getreal "\n Nhap gia tri cao do goc")
i 0
n (length plst)
h (getreal "\n Nhap chieu cao text")
)
(foreach p plst
(setq elev (+ hg (- (cadr p) (cadr pg))))
(command "text" (getpoint "\n Chon diem nhap cao do ") h 90 (rtos elev 2 2))
(if (and (> i 0) (< i n))
(progn
(setq len (distance (nth (1- i) plst) (nth i plst)))
(command "text" (getpoint "\n Chon diem nhap chieu dai duong nghiem thu ") h 0 (rtos len 2 2) )
)
)
(setq i (1+ i))
)
(command "undo" "e")
(princ)
)
Chúc bạn vui.
rất cảm ơn bác về cái lisp của bác, nhưng mà nếu nó tự động xuất ra hết kết quả thì hay biết máy, được như vậy thì cảm ơn bác lắm lắm!
<<
|
|
Filename: 199442_elale.lsp
|
|
Tác giả: proconeng86
Bài viết gốc: 295537
Tên lệnh: tida |
lisp tính tổng số đai trong dim
Hề hề hề,
Bạn nên rút kinh nghiệm khi đặt yêu cầu viết lisp. nên suy nghĩ thấu đáo về cái mình cần và đưa...
>>
Hề hề hề,
Bạn nên rút kinh nghiệm khi đặt yêu cầu viết lisp. nên suy nghĩ thấu đáo về cái mình cần và đưa ra đầy đủ các bản vẽ thể hiện đúng cái mình cần. Đừng làm theo kiểu mỗi lúc lại són ra một yêu cầu thêm mới. Bản vẽ lần trước bạn gửi chỉ có duy nhất một loai đường kinh đai thôi, hoàn toàn không có loại đai thứ hai nào. Bởi vậy mình mới để mặc định trong thông báo là đai phi 6. (bằng chứng vẫn còn đó)
Đây là lisp đã sửa theo yêu cầu mới và hy vọng bạn không đẻ thêm yêu cầu mới cho cái lisp này. Nếu vẫn còn thì bạn sẽ phải đợi lâu đấy, bởi mình hết hứng bổ sung rồi.
(defun c:tida (/ ssd sd ed kt ts n b m sdl dkl ld)
(vl-load-com)
(setq ssd (acet-ss-to-list (ssget (list (cons 0 "dimension") (cons 3 "*00)"))))
dkl (list)
sd 0 )
(foreach d ssd
(setq ed (entget d)
kt (cdr (assoc 42 ed))
ts (cdr (assoc 3 ed))
n (vl-string-search "d" ts)
m (vl-string-search "a" ts)
b (atoi (substr ts (+ 2 m) 3))
dk (substr ts (+ 2 n) (- m n 1))
sdl (if (>= (- (/ kt b) (fix (/ kt b))) 0.5) (1+ (fix (/ kt b))) (fix (/ kt b)))
dkl (append dkl (list (list dk sdl)))
)
)
(setq dkl (vl-sort dkl '(lambda (x y) (<= (atoi (car x)) (atoi (car y))))))
(while dkl
(setq sd 0
ld (caar dkl))
(foreach lis dkl
(if (= (car lis) ld)
(progn
(setq sd (+ sd (cadr lis))
dkl (vl-remove lis dkl) )
)
)
)
(alert (strcat "\n Tong so dai " (chr 216) ld " can dung la: " (rtos sd 2 0) " dai " ))
)
(princ)
)
Xin lỗi bạn nhé vì lúc đầu mình cũng chưa nghĩ đc hết, khi làm rồi mới biết dc và nảy sinh ra, lần sau mình sẽ rút kinh nghiệm. Lisp này là ngon rồi, mình cám ơn nhiều nha
<<
|
|
Filename: 295537_tida.lsp
|
|
Tác giả: proconeng86
Bài viết gốc: 295448
Tên lệnh: tida |
lisp tính tổng số đai trong dim
Hề hề hề,
Dùng thử cái này xem có ngứa ngáy hay nổi mụn chỗ nào không nhé.
>>
Hề hề hề,
Dùng thử cái này xem có ngứa ngáy hay nổi mụn chỗ nào không nhé.
(defun c:tida (/ ssd sd ed kt ts n b )
(setq ssd (acet-ss-to-list (ssget (list (cons 0 "dimension") (cons 3 "*00)"))))
sd 0 )
(foreach d ssd
(setq ed (entget d)
kt (cdr (assoc 42 ed))
ts (cdr (assoc 3 ed))
n (strlen ts)
b (atoi (substr ts (- n 3) 3))
sd (+ sd (fix (/ kt b)) 1)
)
)
(alert (strcat "\n Tong so dai can dung la: " (rtos sd 2 0) " dai " (chr 216) " 6"))
(princ)
)
Lisp của bạn Phamthanhbinh không bị lỗi khi chọn cả dim không ghi đai tuy nhiên lại mặc định là đai phi6
Một dầm có nhiều nhịp có khi có nhiều loại đai đường kính khác nhau mà như file đính kèm của mình có 2 loại đai phi6 và phi10, bạn giúp mình chỉnh lại là đưa ra tổng số lượng đai của từng loại nhé
Cám ơn bạn nhiều
http://www.cadviet.com/upfiles/3/9928_yeu_cau_lisp_tinh_so_dai_trong_nhieu_khoang_dim_1.dwg
<<
|
|
Filename: 295448_tida.lsp
|
|