| Info | File |
Tác giả: taipham
Bài viết gốc: 383853
Tên lệnh: rpl |
Nhờ Sửa Lisp Replace Text Nhanh
(defun c:rpl()
(setq olsosmode (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq p (ssget))
(if p
(progn
(setq osl (strlen (setq os (getstring "\nOld string: " t))))
(setq nsl (strlen (setq ns (getstring "\nNew string: " t))))
(setq l 0 chm 0 n (sslength p))
(setq adj
(cond
((/= osl nsl) (- nsl osl))
(T nsl)
)
)
(while (< l n)
(setq d (entget (setq e (ssname p...
>>
(defun c:rpl()
(setq olsosmode (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq p (ssget))
(if p
(progn
(setq osl (strlen (setq os (getstring "\nOld string: " t))))
(setq nsl (strlen (setq ns (getstring "\nNew string: " t))))
(setq l 0 chm 0 n (sslength p))
(setq adj
(cond
((/= osl nsl) (- nsl osl))
(T nsl)
)
)
(while (< l n)
(setq d (entget (setq e (ssname p l))))
(if (and (= (atext 0) "INSERT")(= (atext 66) 1))
(progn
(setq e (entnext e))
(while e
(setq d (entget e))
(cond
((= (atext 0) "ATTRIB")
(setq chf nil si 1)
(setq s (cdr (setq as (assoc 1 d))))
(while (= osl (setq sl (strlen
(setq st (substr s si osl)))))
(cond
((= st os)
(setq s (strcat (substr s 1 (1- si)) ns
(substr s (+ si osl))))
(setq chf t)
(setq si (+ si adj))
)
)
(setq si (1+ si))
)
(if chf
(progn
(setq d (subst (cons 1 s) as d))
(entmod d)
(entupd e)
(setq chm (1+ chm))
)
)
(setq e (entnext e))
)
((= (atext 0) "SEQEND")
(setq e nil))
(T (setq e (entnext e)))
)
)
)
)
(if (= "MTEXT" ; Look for MTEXT entity type (group 0)
(cdr (assoc 0 (setq e (entget (ssname p l))))))
(progn
(setq chf nil si 1)
(setq s (cdr (setq as (assoc 1 e))))
(while (= osl (setq sl (strlen
(setq st (substr s si osl)))))
(if (= st os)
(progn
(setq s (strcat (substr s 1 (1- si)) ns
(substr s (+ si osl))))
(setq chf t) ; Found old string
(setq si (+ si nsl))
)
(setq si (1+ si))
)
)
(if chf (progn ; Substitute new string for old
(setq e (subst (cons 1 s) as e))
(entmod e) ; Modify the TEXT entity
(setq chm (1+ chm))
))
)
)
(if (= "DIMENSION" ; Look for DIMENSION entity type (group 0)
(cdr (assoc 0 (setq e (entget (ssname p l))))))
(progn
(setq chf nil si 1)
(setq s (cdr (setq as (assoc 1 e))))
(while (= osl (setq sl (strlen
(setq st (substr s si osl)))))
(if (= st os)
(progn
(setq s (strcat (substr s 1 (1- si)) ns
(substr s (+ si osl))))
(setq chf t) ; Found old string
(setq si (+ si nsl))
)
(setq si (1+ si))
)
)
(if chf (progn ; Substitute new string for old
(setq e (subst (cons 1 s) as e))
(entmod e) ; Modify the TEXT entity
(setq chm (1+ chm))
))
)
)
(if (= "TEXT" ; Look for TEXT entity type (group 0)
(cdr (assoc 0 (setq e (entget (ssname p l))))))
(progn
(setq chf nil si 1)
(setq s (cdr (setq as (assoc 1 e))))
(while (= osl (setq sl (strlen
(setq st (substr s si osl)))))
(if (= st os)
(progn
(setq s (strcat (substr s 1 (1- si)) ns
(substr s (+ si osl))))
(setq chf t) ; Found old string
(setq si (+ si nsl))
)
(setq si (1+ si))
)
)
(if chf (progn ; Substitute new string for old
(setq e (subst (cons 1 s) as e))
(entmod e) ; Modify the TEXT entity
(setq chm (1+ chm))
))
)
)
(setq l (1+ l))
)
)
)
(if (> chm 1)
(princ (strcat "\nUpdated " (itoa chm) " text strings"))
(princ (strcat "\nUpdated " (itoa chm) " text string"))
)
(setvar "OSMODE" oldosmode)
(terpri)
)
;
(defun atext (num)
(cdr (assoc num d))
)
Nhờ các anh chị sửa giúp đoạn lisp trên, thay vì khi điền Old text và New text thì có thêm phần pick chọn text có sẵn trong bản vẽ và lấy nội dung đó để replace luôn. Mong được các anh chị giúp đỡ. Xin cảm ơn!
<< |
Tác giả: nhoclangbac
Bài viết gốc: 381989
Tên lệnh: test |
Lisp Ghép Text Cần Giúp Đỡ
Ah ah, Nhoc thix nhanh gọn quơ 1 phát ... Vậy có lẻ chơi Sort theo y là Ok Ps : sao mạng gởi bài khổ quá !!!
(defun c:test (/ ss ent hei lst ls1 ls2 i lse)
(vl-load-com)
(if (setq ss (ssget '((0 . "*TEXT"))))
(progn
(repeat (setq i (sslength ss))
(setq ent (ssname ss (setq i (1- i)))
...
>> Ah ah, Nhoc thix nhanh gọn quơ 1 phát ... Vậy có lẻ chơi Sort theo y là Ok Ps : sao mạng gởi bài khổ quá !!!
(defun c:test (/ ss ent hei lst ls1 ls2 i lse)
(vl-load-com)
(if (setq ss (ssget '((0 . "*TEXT"))))
(progn
(repeat (setq i (sslength ss))
(setq ent (ssname ss (setq i (1- i)))
hei (cdr (assoc 40 (entget ent)))
lst (cons (cons (cdr (assoc 10 (entget ent))) (cdr (assoc 1 (entget ent)))) lst)
lst (vl-sort lst '(lambda (x y) (< (cadr (car x)) (cadr (car y)))))
)
)
(foreach x lst
(if (equal (caar x) (caar (last lst)) (* 0.1 hei))
(setq ls1 (cons (cdr x) ls1))
(setq ls2 (cons (cdr x) ls2))
)
)
(setq lst (mapcar '(lambda (x y) (strcat x "-" y)) ls1 ls2))
(setq i -1)
(while (setq ent (ssname ss (setq i (1+ i))))
(if (member (cdr (assoc 1 (entget ent))) ls2)
(entdel ent)
(setq lse (cons ent lse))
)
)
(mapcar '(lambda (x y) (vla-put-textstring (vlax-ename->vla-object x) y)) lse lst)
)
)
(princ)
)
<<
|
|
Filename: 381989_test.lsp
|
|
Tác giả: hiepttr
Bài viết gốc: 384199
Tên lệnh: rpl2 |
Nhờ Sửa Lisp Replace Text Nhanh
Có thể lỗi do code cũ hay ... mình không muốn "đột nhập" :D
Chỉ có thể sửa cho bạn thế này thôi :
(defun c:rpl2()
(setq olsosmode (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq p (ssget))
(if p
(progn
(setq osl (strlen (setq os (H:get-string "Old string "))))
(setq nsl (strlen (setq ns (H:get-string "New string "))))
(setq l 0 chm 0 n (sslength p))
(setq adj
(cond
...
>> Có thể lỗi do code cũ hay ... mình không muốn "đột nhập" :D
Chỉ có thể sửa cho bạn thế này thôi :
(defun c:rpl2()
(setq olsosmode (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setq p (ssget))
(if p
(progn
(setq osl (strlen (setq os (H:get-string "Old string "))))
(setq nsl (strlen (setq ns (H:get-string "New string "))))
(setq l 0 chm 0 n (sslength p))
(setq adj
(cond
((/= osl nsl) (- nsl osl))
(T nsl)
)
)
(while (< l n)
(setq d (entget (setq e (ssname p l))))
(if (and (= (atext 0) "INSERT")(= (atext 66) 1))
(progn
(setq e (entnext e))
(while e
(setq d (entget e))
(cond
((= (atext 0) "ATTRIB")
(setq chf nil si 1)
(setq s (cdr (setq as (assoc 1 d))))
(while (= osl (setq sl (strlen
(setq st (substr s si osl)))))
(cond
((= st os)
(setq s (strcat (substr s 1 (1- si)) ns
(substr s (+ si osl))))
(setq chf t)
(setq si (+ si adj))
)
)
(setq si (1+ si))
)
(if chf
(progn
(setq d (subst (cons 1 s) as d))
(entmod d)
(entupd e)
(setq chm (1+ chm))
)
)
(setq e (entnext e))
)
((= (atext 0) "SEQEND")
(setq e nil))
(T (setq e (entnext e)))
)
)
)
)
(if (= "MTEXT" ; Look for MTEXT entity type (group 0)
(cdr (assoc 0 (setq e (entget (ssname p l))))))
(progn
(setq chf nil si 1)
(setq s (cdr (setq as (assoc 1 e))))
(while (= osl (setq sl (strlen
(setq st (substr s si osl)))))
(if (= st os)
(progn
(setq s (strcat (substr s 1 (1- si)) ns
(substr s (+ si osl))))
(setq chf t) ; Found old string
(setq si (+ si nsl))
)
(setq si (1+ si))
)
)
(if chf (progn ; Substitute new string for old
(setq e (subst (cons 1 s) as e))
(entmod e) ; Modify the TEXT entity
(setq chm (1+ chm))
))
)
)
(if (= "DIMENSION" ; Look for DIMENSION entity type (group 0)
(cdr (assoc 0 (setq e (entget (ssname p l))))))
(progn
(setq chf nil si 1)
(setq s (cdr (setq as (assoc 1 e))))
(while (= osl (setq sl (strlen
(setq st (substr s si osl)))))
(if (= st os)
(progn
(setq s (strcat (substr s 1 (1- si)) ns
(substr s (+ si osl))))
(setq chf t) ; Found old string
(setq si (+ si nsl))
)
(setq si (1+ si))
)
)
(if chf (progn ; Substitute new string for old
(setq e (subst (cons 1 s) as e))
(entmod e) ; Modify the TEXT entity
(setq chm (1+ chm))
))
)
)
(if (= "TEXT" ; Look for TEXT entity type (group 0)
(cdr (assoc 0 (setq e (entget (ssname p l))))))
(progn
(setq chf nil si 1)
(setq s (cdr (setq as (assoc 1 e))))
(while (= osl (setq sl (strlen
(setq st (substr s si osl)))))
(if (= st os)
(progn
(setq s (strcat (substr s 1 (1- si)) ns
(substr s (+ si osl))))
(setq chf t) ; Found old string
(setq si (+ si nsl))
)
(setq si (1+ si))
)
)
(if chf (progn ; Substitute new string for old
(setq e (subst (cons 1 s) as e))
(entmod e) ; Modify the TEXT entity
(setq chm (1+ chm))
))
)
)
(setq l (1+ l))
)
)
)
(if (> chm 1)
(princ (strcat "\nUpdated " (itoa chm) " text strings"))
(princ (strcat "\nUpdated " (itoa chm) " text string"))
)
(setvar "OSMODE" oldosmode)
(terpri)
)
;
(defun atext (num)
(cdr (assoc num d))
)
;;==================
(defun H:get-string(show / str text)
(cond ((> (strlen (setq str (getstring (strcat "\n" show " <Pick>: ") T))) 0) str)
((while (not text)
(prompt "\nPick: ")
(setq text (ssget "+.:E:S" '((0 . "*TEXT"))))
)
(setq str (cdr (assoc 1 (entget (ssname text 0))))))
)
)
<<
|
|
Filename: 384199_rpl2.lsp
|
|
Tác giả: 18011985
Bài viết gốc: 93870
Tên lệnh: a1 |
Viết lisp theo yêu cầu [phần 2]
Cảm ơn bạn đã quan tâm, mình có ý tưởng như sau: "Nội suy địa chất từ mặt cắt dọc cho mặt cắt ngang không cùng tỷ lệ"
Mình đã viết những lisp bị lỗi, mình đã thử kiểm tra từng phần, đến phần đổi tỷ lệ thì bị lỗi về giá trị giữa số và chữ. Chưa tìm ra cách giải quyết nên đưa lên mong các bạn góp ý. Sau đây là lisp của mình.
PS: Check hộ mình nhé!
|
Tác giả: hiepttr
Bài viết gốc: 384418
Tên lệnh: xoay |
Xoay Đoạn Thẳng
Thể dục buổi sáng giúp bạn đây :D
(defun c:xoay ( / cmd ss ename info dxf10 dxf11)
(setq cmd (getvar 'cmdecho))
(setvar 'cmdecho 0)
(prompt "\nChon (cac) LINE muon xoay 180 do !")
(setq ss (ssget '((0 . "LINE"))))
(if ss
(repeat (sslength ss)
(setq info (entget (setq ename (ssname ss 0)))
dxf10 (cdr (assoc 10 info))
dxf11 (cdr (assoc 11 info))
info (subst (cons 10 dxf11) (assoc 10 info) info)
info (subst (cons 11...
>> Thể dục buổi sáng giúp bạn đây :D
(defun c:xoay ( / cmd ss ename info dxf10 dxf11)
(setq cmd (getvar 'cmdecho))
(setvar 'cmdecho 0)
(prompt "\nChon (cac) LINE muon xoay 180 do !")
(setq ss (ssget '((0 . "LINE"))))
(if ss
(repeat (sslength ss)
(setq info (entget (setq ename (ssname ss 0)))
dxf10 (cdr (assoc 10 info))
dxf11 (cdr (assoc 11 info))
info (subst (cons 10 dxf11) (assoc 10 info) info)
info (subst (cons 11 dxf10) (assoc 11 info) info)
)
(entmod info)
(ssdel ename ss)
)
(alert "\n*** Khong chon duoc thang nao ca ^|^ ***")
)
(setvar 'cmdecho cmd)
(princ)
)
<<
|
|
Filename: 384418_xoay.lsp
|
|
Tác giả: phamthanhbinh
Bài viết gốc: 384484
Tên lệnh: sedote |
Thống Kê Text Theo Cặp
Mình có vài chục bản vẽ như thế đó bạn mình làm 1 công trình phần mềm xuất ra vài trăm bản vẽ xong công trình này thì làm thêm công trình khác nên mình mới nhớ làm lisp chứ không copy cho rồi
Hề hề hề,
1/- Dùng thử cái lisp dưới đây nhé. Lưu ý rằng lisp chỉ đúng khi...
>>
Mình có vài chục bản vẽ như thế đó bạn mình làm 1 công trình phần mềm xuất ra vài trăm bản vẽ xong công trình này thì làm thêm công trình khác nên mình mới nhớ làm lisp chứ không copy cho rồi
Hề hề hề,
1/- Dùng thử cái lisp dưới đây nhé. Lưu ý rằng lisp chỉ đúng khi các bảng có cùng cấu trúc với các bảng trên bản vẽ bạn đã post. Nghĩa là tỷ lệ giữa kích thước của bảng với chiều cao text tiêu đề (SiZE) là tương đương., Tỷ lệ giữa các cột, các hàng là tương đương.
2/- Bạn đã có kha khá kiến thức về lisp nên hãy đọc kỹ cái lisp này để hiểu được cách làm của mình và từ đó có thể suy ra cách làm cho các bảng có cấu trúc khác mà bạn cần phải làm.
http://www.cadviet.com/upfiles/5/5194_choncaptext.lsp
(defun c:sedote ( / oldos sstc p0 h p sst p1 ssc )
(vl-load-com)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(setq sstc (acet-ss-to-list (ssget (list (cons 0 "text") (cons 1 "SIZE")))))
(setq p0 (getpoint "\n Chon diem dat ket qua"))
(command "undo" "be")
(foreach txt sstc
(setq h (cdr (assoc 40 (entget txt)))
p (cdr (assoc 11 (entget txt))) )
(if (= (sslength (setq sst (ssget "c" p (list (+ (car p) (* 15 h)) (+ (cadr p) h))
(list (cons 0 "text") (cons 1 "\\M+3B0E8"))))) 1)
(setq p1 (cdr (assoc 11 (entget (ssname sst 0)))))
)
;;;;; (command "line" p p1 "")
(setq p (list (- (car p) (* 9.5 h)) (- (cadr p) (* 3.75 h)))
p1 (list (+ (car p1) h) (- (cadr p1) (* 3.75 h))) )
(while (setq ssc (ssget "f" (list p p1) (list (cons 0 "text"))))
(command "copy" ssc "" p p0)
(setq p0 (polar p0 (* 1.5 pi) (* 2.5 h))
p (polar p (* 1.5 pi) (* 2.5 h))
p1 (polar p1 (* 1.5 pi) (* 2.5 h)) )
)
)
(command "undo" "e")
(setvar "osmode" oldos)
(princ)
)
<<
|
|
Filename: 384484_sedote.lsp
|
|
Tác giả: hiepttr
Bài viết gốc: 384578
Tên lệnh: trl |
Xin Lisp Về Layer
-Nét liền = "Continuous"
-Nét tâm = "CENTER,CENTER2,CENTERX2"
-Còn lại là nét đứt
(defun c:TRL ( / cmd ss lst info dxf6 dxf62)
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq ss (ssget))
(if ss
(progn
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(foreach elem lst
(cond ((or (and (null (assoc 6 (setq info (entget elem))))
(wcmatch (cdr (assoc 6 (entget (tblobjname "layer" (cdr (assoc 8...
>> -Nét liền = "Continuous"
-Nét tâm = "CENTER,CENTER2,CENTERX2"
-Còn lại là nét đứt
(defun c:TRL ( / cmd ss lst info dxf6 dxf62)
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq ss (ssget))
(if ss
(progn
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(foreach elem lst
(cond ((or (and (null (assoc 6 (setq info (entget elem))))
(wcmatch (cdr (assoc 6 (entget (tblobjname "layer" (cdr (assoc 8 info)))))) "Continuous")
)
(and (assoc 6 info) (wcmatch (cdr (assoc 6 info)) "Continuous"))
)
(if (setq dxf6 (assoc 6 info)) (setq info (subst (cons 6 "ByLayer") dxf6 info)))
(if (setq dxf62 (assoc 62 info)) (setq info (subst (cons 62 256) dxf62 info)))
(setq info (subst (cons 8 "STEEL") (assoc 8 info) info))
(entmod info)
)
((or (and (null (assoc 6 info))
(wcmatch (cdr (assoc 6 (entget (tblobjname "layer" (cdr (assoc 8 info)))))) "CENTER,CENTER2,CENTERX2")
)
(and (assoc 6 info) (wcmatch (cdr (assoc 6 info)) "CENTER,CENTER2,CENTERX2"))
)
(if (setq dxf6 (assoc 6 info)) (setq info (subst (cons 6 "ByLayer") dxf6 info)))
(if (setq dxf62 (assoc 62 info)) (setq info (subst (cons 62 256) dxf62 info)))
(setq info (subst (cons 8 "GRID LINE") (assoc 8 info) info))
(entmod info)
)
(T
(if (setq dxf6 (assoc 6 info)) (setq info (subst (cons 6 "ByLayer") dxf6 info)))
(if (setq dxf62 (assoc 62 info)) (setq info (subst (cons 62 256) dxf62 info)))
(setq info (subst (cons 8 "HIDDEN LINE") (assoc 8 info) info))
(entmod info)
)
)
)
)
(princ "\n*** Khong chon duoc thang nao ca ^|^ ***")
)
(setvar "cmdecho" cmd)
(princ)
)
<<
|
Tác giả: Nguyen Hoanh
Bài viết gốc: 384746
Tên lệnh: test |
[Hỏi] Thuật Toán Tìm Mặt 3Dface Chứa Tọa Độ Một Điểm Trong Tập Hợp Các 3Dface
Sau đây là phần hàm các 3DFace tiềm năng. Hàm này có ưu điểm:
- Mình đã test thì thấy chạy khá nhanh.
- Không phải sử dụng đến các hàm command nên sẽ tương thích hơn với các lisp cũng như không liên quan đến góc nhìn (nếu ở 3D thì hàm ssget tham số fence sẽ cho ra kết quả không đúng)
Cú pháp dùng hàm
(find_potential ss point)
Trong đó:
ss: selection set chứa các...
>> Sau đây là phần hàm các 3DFace tiềm năng. Hàm này có ưu điểm:
- Mình đã test thì thấy chạy khá nhanh.
- Không phải sử dụng đến các hàm command nên sẽ tương thích hơn với các lisp cũng như không liên quan đến góc nhìn (nếu ở 3D thì hàm ssget tham số fence sẽ cho ra kết quả không đúng)
Cú pháp dùng hàm
(find_potential ss point)
Trong đó:
ss: selection set chứa các 3dface.
point: đối tượng dạng list chứa tọa độ điểm cần xét
Kết quả:
Trả về selection set chứa các 3dface tiềm năng (chỉ 1 hoặc 2 3dface).
Gọi lệnh test để thử hàm này.
(defun not_potential_x(p1 p2 p3 p4 p / d1 d2 d3)
(setq d1 (- (car p1) (car p))
d2 (- (car p2) (car p))
d3 (- (car p3) (car p))
d4 (- (car p4) (car p))
)
(or (and (< 0.0 d1) (< 0.0 d2) (< 0.0 d3) (< 0.0 d4))
(and (> 0.0 d1) (> 0.0 d2) (> 0.0 d3) (> 0.0 d4)))
)
(defun not_potential_y(p1 p2 p3 p4 p / d1 d2 d3)
(setq d1 (- (cadr p1) (cadr p))
d2 (- (cadr p2) (cadr p))
d3 (- (cadr p3) (cadr p))
d4 (- (cadr p4) (cadr p))
)
(or (and (< 0.0 d1) (< 0.0 d2) (< 0.0 d3) (< 0.0 d4))
(and (> 0.0 d1) (> 0.0 d2) (> 0.0 d3) (> 0.0 d4)))
)
(defun not_potential(p1 p2 p3 p4 p)
(or (not_potential_x p1 p2 p3 p4 p)
(not_potential_y p1 p2 p3 p4 p))
)
(defun 3dfacetopoints (x)
(if (not (listp x))
(cons x (mapcar 'cdr (vl-remove-if '(lambda(a) (not (member (car a) '(10 11 12 13)))) (entget x))))
nil
)
)
(defun find_potential(ss diemgoc)
(setq lst (ssnamex ss)
lst (mapcar 'cadr lst)
lst (mapcar '3dfacetopoints lst)
lst (vl-remove-if 'null lst)
lst (vl-remove-if '(lambda(a) (not_potential (nth 1 a) (nth 2 a) (nth 3 a) (nth 4 a) diemgoc)) lst)
lst (mapcar 'car lst)
sskq (ssadd)
)
lst
(foreach ent lst
(setq sskq (ssadd ent sskq))
)
sskq
)
(defun c:test( / sskq)
(setq sskq (find_potential (ssget "x" '((0 . "3DFACE"))) (getpoint "\nDiem p: ")))
(sssetfirst sskq sskq)
(princ)
)
Mình định lồng luôn hàm tìm chính xác là 3dface nào, nhưng phát hiện ra hàm PointInTamgiac của bạn thanhduan bị sai, chạy không đúng trong mọi trường hợp.
Vì thế bạn thanhduan sẽ tự sửa hàm PointInTamgiac và lồng vào nhé.
<<
|
|
Filename: 384746_test.lsp
|
|
Tác giả: hiepttr
Bài viết gốc: 384932
Tên lệnh: dong3 |
[Yêu Cầu] Cắm Cọc Gpmb Trên 2 Mép Ngoài Taluy Trên Bình Đồ
- Mình chỉ code lúc rảnh và ngoài việc giúp bạn ra nó còn giúp mình ôn bài :D nên nếu hài lòng bạn chỉ cần kích like là đủ :D :D :D
- File xuất ra, bạn mở bằng excel, và nhớ cài đặt dấu ngắt phần thập phân là dấu chấm. Biểu mẫu file mình không theo ý bạn 100%, mình để chừa cột STT lại để bạn làm bằng excel thì linh động hơn, cột Y mình để trước, X để sau, thuận lợi...
>> - Mình chỉ code lúc rảnh và ngoài việc giúp bạn ra nó còn giúp mình ôn bài :D nên nếu hài lòng bạn chỉ cần kích like là đủ :D :D :D
- File xuất ra, bạn mở bằng excel, và nhớ cài đặt dấu ngắt phần thập phân là dấu chấm. Biểu mẫu file mình không theo ý bạn 100%, mình để chừa cột STT lại để bạn làm bằng excel thì linh động hơn, cột Y mình để trước, X để sau, thuận lợi trong việc nhập máy toàn đạc ...
p/s:
- Chú ý, Tên cọc được lấy từ XData của line ENTCOC nên trong quá trình biên tập bình đồ bạn không nên copy line của cọc này sang cọc kia, Hoặc thay đổi tên cọc trên Text thì lisp cũng không nhận được !
- Mình có sửa chút ít để lisp dim đúng form của bạn và không bị lỗi khi line ENTCOC cắt mỗi đường biên > 1 điểm.
(defun c:DONG3 ( / lst_va old ss lst_name coc tlt tlp ob trai phai mid mid_pt fn pw ten_coc)
(vl-load-com)
(defun mid(p1 p2)(mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5)))
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon BD muon dong coc GPMB !")
(setq ss (ssget '((8 . "MEPTLT,MEPTLP,ENTCOC"))))
(setq lst_name (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq coc (vl-remove-if-not '(lambda(x) (= "ENTCOC" (cdr (assoc 8 (entget x))))) lst_name)
tlt (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLT" (cdr (assoc 8 (entget x))))) lst_name)))
tlp (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLP" (cdr (assoc 8 (entget x))))) lst_name))))
(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
(setq pw (open fn "w"))
(write-line "STT,Tencoc,Y,X" pw)
(foreach c coc
(setq ten_coc (cdr
(car
(vl-remove-if-not '(lambda (x) (= 1000 (car x))) (cdr (last (assoc -3 (entget c '("*"))))))
)
)
)
(setq trai (if (= 3 (length (setq trai (vlax-invoke (setq ob (vlax-ename->vla-object c)) 'intersectwith tlt acExtendThisEntity))))
trai
(list (car trai) (cadr trai) (caddr trai))
)
phai (if (= 3 (length (setq phai (vlax-invoke ob 'intersectwith tlp acExtendThisEntity))))
phai
(list (car phai) (cadr phai) (caddr phai))
)
mid_pt (mid (vlax-curve-getStartpoint c) (vlax-curve-getEndpoint c)))
(command "_.insert" "cocmoc" trai 1 "" "")
(command "_.insert" "cocmoc" phai 1 "" "")
(command ".DIMALIGNED" mid_pt trai (mid trai mid_pt))
(command ".DIMALIGNED" mid_pt phai (mid phai mid_pt))
(write-line (strcat "" "," "P-" ten_coc "," (rtos (cadr phai) 2 3) "," (rtos (car phai) 2 3)) pw)
(write-line (strcat "" "," "T-" ten_coc "," (rtos (cadr trai) 2 3) "," (rtos (car trai) 2 3)) pw)
)
(close pw)
(mapcar 'setvar lst_va old)
(princ)
)
<<
|
|
Filename: 384932_dong3.lsp
|
|
Tác giả: hiepttr
Bài viết gốc: 385022
Tên lệnh: dong3 |
C?m C?c Gpmb Trên 2 Mép Ngoài Taluy Trên Bình ??
- B?n có th? dùng lisp này, 2 trong 1 :D
(defun c:DONG3 ( / lst_va old ss lst_name coc tlt tlp ob trai phai mid mid_pt fn pw ten_coc)
(vl-load-com)
(defun mid(p1 p2)(mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5)))
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon BD muon dong coc GPMB !")
(setq ss (ssget '((8 . "MEPTLT,MEPTLP,ENTCOC"))))
(setq lst_name (vl-remove-if 'listp (mapcar...
>> - B?n có th? dùng lisp này, 2 trong 1 :D
(defun c:DONG3 ( / lst_va old ss lst_name coc tlt tlp ob trai phai mid mid_pt fn pw ten_coc)
(vl-load-com)
(defun mid(p1 p2)(mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5)))
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon BD muon dong coc GPMB !")
(setq ss (ssget '((8 . "MEPTLT,MEPTLP,ENTCOC"))))
(setq lst_name (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq coc (vl-remove-if-not '(lambda(x) (= "ENTCOC" (cdr (assoc 8 (entget x))))) lst_name)
tlt (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLT" (cdr (assoc 8 (entget x))))) lst_name)))
tlp (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLP" (cdr (assoc 8 (entget x))))) lst_name))))
(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
(setq pw (open fn "w"))
(write-line "STT,Ten coc,Trai,,,Phai" pw)
(write-line ",,K/cach den tim,Y,X,K/cach den tim,Y,X" pw)
(foreach c coc
(setq ten_coc (cdr
(car
(vl-remove-if-not '(lambda (x) (= 1000 (car x))) (cdr (last (assoc -3 (entget c '("*"))))))
)
)
)
(setq trai (if (= 3 (length (setq trai (vlax-invoke (setq ob (vlax-ename->vla-object c)) 'intersectwith tlt acExtendThisEntity))))
trai
(list (car trai) (cadr trai) (caddr trai))
)
phai (if (= 3 (length (setq phai (vlax-invoke ob 'intersectwith tlp acExtendThisEntity))))
phai
(list (car phai) (cadr phai) (caddr phai))
)
mid_pt (mid (vlax-curve-getStartpoint c) (vlax-curve-getEndpoint c)))
(command "_.insert" "cocmoc" trai 1 "" "")
(command "_.insert" "cocmoc" phai 1 "" "")
(command ".DIMALIGNED" mid_pt trai (mid trai mid_pt))
(command ".DIMALIGNED" mid_pt phai (mid phai mid_pt))
(write-line (strcat "," ten_coc "," (rtos (distance mid_pt trai) 2 3) "," (rtos (cadr trai) 2 3) "," (rtos (car trai) 2 3)
"," (rtos (distance mid_pt phai) 2 3) "," (rtos (cadr phai) 2 3) "," (rtos (car phai) 2 3)) pw)
)
(close pw)
(mapcar 'setvar lst_va old)
(princ)
)
<<
|
|
Filename: 385022_dong3.lsp
|
|
Tác giả: hiepttr
Bài viết gốc: 385379
Tên lệnh: dong4 |
C?m C?c Gpmb Trên 2 Mép Ngoài Taluy Trên Bình ??
1; 2. Không bàn n?a :D
3. ?ã fix :
(defun c:DONG4 ( / lst_va old ss lst_name coc tlt tlp ob trai phai mid mid_pt fn pw ten_coc)
(vl-load-com)
(defun mid(p1 p2)(mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5)))
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon BD muon dong coc GPMB !")
(setq ss (ssget '((8 . "MEPTLT,MEPTLP,ENTCOC"))))
(setq lst_name (vl-remove-if 'listp (mapcar 'cadr...
>> 1; 2. Không bàn n?a :D
3. ?ã fix :
(defun c:DONG4 ( / lst_va old ss lst_name coc tlt tlp ob trai phai mid mid_pt fn pw ten_coc)
(vl-load-com)
(defun mid(p1 p2)(mapcar '* (mapcar '+ p1 p2) '(0.5 0.5 0.5)))
(setq lst_va '("osmode" "cmdecho"))
(setq old (mapcar 'getvar lst_va))
(mapcar 'setvar lst_va '(0 0))
(prompt "\nChon BD muon dong coc GPMB !")
(setq ss (ssget '((8 . "MEPTLT,MEPTLP,ENTCOC"))))
(setq lst_name (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq coc (vl-remove-if-not '(lambda(x) (= "ENTCOC" (cdr (assoc 8 (entget x))))) lst_name)
tlt (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLT" (cdr (assoc 8 (entget x))))) lst_name)))
tlp (vlax-ename->vla-object (car (vl-remove-if-not '(lambda(x) (= "MEPTLP" (cdr (assoc 8 (entget x))))) lst_name))))
(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
(setq pw (open fn "w"))
(write-line "STT,Ten coc,Trai,,,Phai" pw)
(write-line ",,K/cach den tim,Y,X,K/cach den tim,Y,X" pw)
(foreach c coc
(setq ten_coc (cdr
(car
(vl-remove-if-not '(lambda (x) (= 1000 (car x))) (cdr (last (assoc -3 (entget c '("*"))))))
)
)
)
(setq mid_pt (mid (vlax-curve-getStartpoint c) (vlax-curve-getEndpoint c))
trai (car (vl-sort (H:inter-group3 (setq ob (vlax-ename->vla-object c)) tlt) '(lambda (x y) (< (distance x mid_pt) (distance y mid_pt)))))
phai (car (vl-sort (H:inter-group3 ob tlp) '(lambda (x y) (< (distance x mid_pt) (distance y mid_pt)))))
)
(command "_.insert" "cocmoc" trai 1 "" "")
(command "_.insert" "cocmoc" phai 1 "" "")
(command ".DIMALIGNED" mid_pt trai (mid trai mid_pt))
(command ".DIMALIGNED" mid_pt phai (mid phai mid_pt))
(write-line (strcat "," ten_coc "," (rtos (distance mid_pt trai) 2 3) "," (rtos (cadr trai) 2 3) "," (rtos (car trai) 2 3)
"," (rtos (distance mid_pt phai) 2 3) "," (rtos (cadr phai) 2 3) "," (rtos (car phai) 2 3)) pw)
)
(close pw)
(mapcar 'setvar lst_va old)
(princ)
)
;;;;
(defun H:inter-group3(ob1 ob2 / modul res)
(cond
((null (setq modul (vlax-invoke ob1 'intersectwith ob2 acExtendThisEntity))) nil)
((= (length modul) 3) (list modul))
(t
(while (> (length modul) 0)
(setq res (cons (list (car modul) (cadr modul) (caddr modul)) res)
modul (cdddr modul)
)
)
(reverse res)
)
)
)
<<
|
|
Filename: 385379_dong4.lsp
|
|
Tác giả: pphung183
Bài viết gốc: 367452
Tên lệnh: indy |
Xin H?i V? Block Thu?c Tính
Cách 2 cùng Lisp :
1/ WBLOCK 1th?ng DN Block thành 1 b?n v? th? vi?n
2/ Lisp :
(defun c:indy (/ fn path tf pt1)
(setq fn (getfiled "SELECT FILES" "" "dwg" 8))
(setq path (vl-filename-directory fn))
(setq tf (cond ( (wcmatch path "") (strcat (getvar 'dwgprefix) fn) ) (t fn) ))
(setq pt1 (getpoint "\nPick Insert point : "))
(command "_insert" tf "non" pt1 "1" "1" "")
(Command "_.Explode" "l") (princ))
|
|
Filename: 367452_indy.lsp
|
|
Tác giả: hiepttr
Bài viết gốc: 385532
Tên lệnh: xuat |
Xuất Tọa Độ Và Khoảng Cách Cộng Dồn Pline Ra File Excel
Bạn dùng thử cái này:
p/s: Bạn nên sửa tiêu đề trước khi bịi mod xóa bài :D
;Xuat X tuong doi va Y tuyet doi cua polyline
(defun c:XUAT( / ss lst_name fn pw i ename TT)
(vl-load-com)
(prompt "\nChon PL !")
(setq ss (ssget '((0 . "LWPOLYLINE"))))
(cond
(ss
(setq lst_name (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
(setq pw (open fn "w"))
(write-line "STT...
>> Bạn dùng thử cái này:
p/s: Bạn nên sửa tiêu đề trước khi bịi mod xóa bài :D
;Xuat X tuong doi va Y tuyet doi cua polyline
(defun c:XUAT( / ss lst_name fn pw i ename TT)
(vl-load-com)
(prompt "\nChon PL !")
(setq ss (ssget '((0 . "LWPOLYLINE"))))
(cond
(ss
(setq lst_name (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
(setq pw (open fn "w"))
(write-line "STT PL,Ten dinh,Y _tuyet doi,X _tuong doi" pw)
(setq i 0)
(while (< i (length lst_name))
(setq ename (nth i lst_name)
i (1+ i)
lst_ver (acet-geom-vertex-list ename)
)
(write-line (setq TT (itoa i)) pw)
(MakeText (car lst_ver) TT 1 0 "C" nil "Lay_Lsp_XUAT" 2 nil)
(foreach pnt lst_ver
(write-line (strcat "," (rtos (1+ (vl-position pnt lst_ver))) "," (rtos (cadr pnt) 2 2) "," (rtos (- (car pnt) (car (car lst_ver))) 2 2)) pw)
)
)
)
)
(close pw)
(alert (strcat "Da them " (itoa (length lst_name)) " Text STT PL vao ban ve !"))
(princ)
)
;===================================|;
(defun MakeText (point string Height Ang justify Style Layer Color xdata / Lst)
; Ang: Radial
(setq Lst (list '(0 . "TEXT")
(cons 8 (if Layer Layer (getvar "Clayer")))
(cons 62 (if Color Color 256))
(cons 10 point)
(cons 40 Height)
(cons 1 string)
(if Ang (cons 50 Ang))
(cons 7 (if Style Style (getvar "Textstyle")))
(cons -3 (if xdata (list xdata) nil)))
justify (strcase justify))
(cond ((= 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)))))
((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))
((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))
((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))
((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))
((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))
((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))
((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))
((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))
((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1)))))
)
(entmakex Lst)
);end
<<
|
|
Filename: 385532_xuat.lsp
|
|
Tác giả: pphung183
Bài viết gốc: 385556
Tên lệnh: q |
Đổi Màu Text
Mục đích của mình là: trong bv có nhiều text cần sửa, mình ứng dụng lsp này để biết text nào đã sửa và chưa sửa(khi mình chạm vào nó thì nó đổi màu, nếu ta sửa nội dung text hay không text vẫn...
>>
Mục đích của mình là: trong bv có nhiều text cần sửa, mình ứng dụng lsp này để biết text nào đã sửa và chưa sửa(khi mình chạm vào nó thì nó đổi màu, nếu ta sửa nội dung text hay không text vẫn đổi màu).
Thanks bạn!
Thấy bạn hỏi buồn cười thật :) , Thử xem trúng ý theo Code của bạn không nhé :)
(defun c:Q (/ ent color)
(while (setq ent (car (entsel "\nChon Text de Edit :")))
(command "change" ent "" "p" "c" 3 "")
(command ".ddedit" ent "")
(setq color 2)
(command "change" ent "" "p" "c" color "") )
(princ))
<<
|
Tác giả: pphung183
Bài viết gốc: 385602
Tên lệnh: q |
Đổi Màu Text
Thanks bạn Tue_NV, mình cũng có tham khảo qua, nhưng lsp đó chỉ đổi màu khi ta đã sửa chúng. Ở đây mình muốn là khi chạm vào thì text hay dim đều đổi màu(cho dù mình có sửa chúng hay không sửa chúng vẫn đổi...
>>
Thanks bạn Tue_NV, mình cũng có tham khảo qua, nhưng lsp đó chỉ đổi màu khi ta đã sửa chúng. Ở đây mình muốn là khi chạm vào thì text hay dim đều đổi màu(cho dù mình có sửa chúng hay không sửa chúng vẫn đổi màu)
Thôi thì thử cái này xem :) :
(defun c:q (/ ent subent tn) (vl-load-com)
(while (setq ent (entsel "\nPick chon Text : "))
(setq subent (car (nentselp (cadr ent))))
(vla-put-Color (vlax-ename->vla-object subent) 2)
(setq tn (lisped (cdr (assoc 1 (entget subent)))))
(entmod (subst (cons 1 tn) (assoc 1 (entget subent)) (entget subent)))
(entupd (car ent)) )
(princ))
<<
|
Tác giả: pphung183
Bài viết gốc: 385625
Tên lệnh: q |
??i Màu Text
Có l? theo cách c? chu?i này trúng ý b?n h?n :D :
(defun c:q (/ ent obj tn) (vl-load-com)
(while (setq ent (car (entsel "\nPick chon Text : ")))
(setq obj (vlax-ename->vla-object ent))
(if (wcmatch (cdr (assoc 0 (entget ent))) "DIMENSION")
(progn (vla-put-TextColor obj 3) (vl-cmdf ".ddedit" ent "") (vla-put-TextColor obj 2))
(progn (vla-put-Color obj 3) (vl-cmdf ".ddedit" ent "") (vla-put-Color obj 2)) ))
(princ))
|
Tác giả: huykhanh_xd
Bài viết gốc: 385769
Tên lệnh: dff |
Nhờ Chỉnh Để Lisp Ghi Kích Thước Kiểu Dimlinear Thay Vì Dimaligned
http://www.upsieutoc.com/image/Wmx2
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/69127-giup-minh-lisp-dim-chia-doan-thang/
;Chia Dim doan thang (03/03/2013).
(defun C:DFF (/ i pts act end line pt1 pt2 ss sta n cd x)
(defun Get_pts_ss_inter_obj (ss obj / e i lst_pt obj pts)
(defun list->3pair (old / new)
(while (setq new (cons (list (car old) (cadr old) (caddr old)) new) old (cdddr...
>>
http://www.upsieutoc.com/image/Wmx2
;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/69127-giup-minh-lisp-dim-chia-doan-thang/
;Chia Dim doan thang (03/03/2013).
(defun C:DFF (/ i pts act end line pt1 pt2 ss sta n cd x)
(defun Get_pts_ss_inter_obj (ss obj / e i lst_pt obj pts)
(defun list->3pair (old / new)
(while (setq new (cons (list (car old) (cadr old) (caddr old)) new) old (cdddr old))) new)
(setq i -1)
(while (setq e (ssname ss (setq i (1+ i))))
(if (setq pts (vlax-invoke obj 'IntersectWith (vlax-ename->vla-object e) acExtendNone))
(setq lst_pt (append (list->3pair pts) lst_pt))))
(vl-sort lst_pt '(lambda (x y) (> (vlax-curve-getParamAtPoint obj x) (vlax-curve-getParamAtPoint obj y)))))
(vl-load-com)
(setq cd (getreal "\nPanel Module (900 or 1000): "))
(if
(and
(setq pt1 (getpoint "\nStart point: "))
(setq pt2 (getpoint pt1 "\nEnd point: "))
(setq pt3 (getpoint "\nDim line location: ")))
(progn
(setq ssc (ssget "f" (list pt1 pt2) (list (cons 0 "*LINE,ARC,CIRCLE,ELLIPSE"))))<span></span>
(setq n (fix (/ (distance pt1 pt2) cd)) x 0 ss1 (ssadd))
(repeat (1+ n)
(setq px (polar pt1 (angle pt1 pt2) (* cd x)) pxt (polar px (+ (angle pt1 pt2) (* 0.5 pi)) 100) pxd (polar px (- (angle pt1 pt2) (* 0.5 pi)) 100))
(entmakex (list (cons 0 "LINE") (cons 10 pxt) (cons 11 pxd)))
<span></span>(setq ss1 (ssadd (entlast) ss1))
<span></span>(setq x (1+ x)))
(if (not (equal n (/ (distance pt1 pt2) cd) 1E-8))
(progn
(setq pxt (polar pt2 (+ (angle pt1 pt2) (* 0.5 pi)) 100) pxd (polar pt2 (- (angle pt1 pt2) (* 0.5 pi)) 100))
(entmakex (list (cons 0 "LINE") (cons 10 pxt) (cons 11 pxd)))
<span></span> (setq ss1 (ssadd (entlast) ss1))))
(setq ssm (ssget "f" (list pt1 pt2) (list (cons 0 "*LINE,ARC,CIRCLE,ELLIPSE"))))<span></span>
(defun TRUSS (ssm ssc / i) (repeat (setq i (sslength ssc)) (ssdel (ssname ssc (setq i (1- i))) ssm)))
(setq ss (TRUSS ssm ssc))
(setq act (vla-get-block (vla-get-activelayout (vla-get-activedocument (vlax-get-acad-object))))
line (vla-addline act (vlax-3d-point pt1) (vlax-3d-point pt2)))
(setq pts (Get_pts_ss_inter_obj ss line))
(if (> (vl-list-length pts) 1)
(progn
(setq sta (car pts) i 1)
(repeat (- (vl-list-length pts)1)
(setq end (nth i pts) i (1+ i))
(vla-AddDimAligned act (vlax-3d-point sta) (vlax-3d-point end) (vlax-3d-point pt3))
(setq sta end))))
(vla-delete line)))
(command "erase" ss1 "")
(princ))
Em có một đoạn lisp do anh "Dao Van Ha" gửi trên diễn đàn như sau. Nó chia đoạn thẳng thành các đoạn với kích thước cho trước nhập vào, phần dư còn lại được ghi đúng kích thước của nó. Mỗi tội kích thước mà lisp ghi ra là dạng DIMALIGNED nên khi chỉnh sửa phải kéo đúng 90 độ thì kích thước mới chạy được còn không là nó xoay theo đường kéo. Các anh chỉnh giùm em sao cho lisp nó ghi kích thước theo kiểu DIMLINEAR được không ạ?
<< |
Tác giả: hiepttr
Bài viết gốc: 386332
Tên lệnh: cco |
Nh? Vi?t Lisp Copy C?ng D?n Kho?ng Cách
B?n th? cái này :D
(defun c:CCO( / cmd ss base_pt dis huong)
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(prompt "\nChon doi tuong copy !")
(setq ss (ssget))
(setq base_pt (getpoint "\nChon diem chuan: "))
(setq dis 0)
(while
(setq huong (getpoint base_pt "\Chon diem thu hai: "))
(command ".copy" ss "" base_pt (polar base_pt (angle base_pt huong) (setq dis (+ dis (distance base_pt huong)))))
)
(setvar "cmdecho"...
>> B?n th? cái này :D
(defun c:CCO( / cmd ss base_pt dis huong)
(setq cmd (getvar "cmdecho"))
(setvar "cmdecho" 0)
(prompt "\nChon doi tuong copy !")
(setq ss (ssget))
(setq base_pt (getpoint "\nChon diem chuan: "))
(setq dis 0)
(while
(setq huong (getpoint base_pt "\Chon diem thu hai: "))
(command ".copy" ss "" base_pt (polar base_pt (angle base_pt huong) (setq dis (+ dis (distance base_pt huong)))))
)
(setvar "cmdecho" cmd)
(princ)
)
<< |
Tác giả: phamthanhbinh
Bài viết gốc: 386310
Tên lệnh: cco |
Nhờ Viết Lisp Copy Cộng Dồn Khoảng Cách
Nhờ các anh chị trong diễn đàn viết hộ em lisp hoặc có lệnh nào trong cad thì chỉ hộ em như sau:
Thao tác giống lệnh copy nhưng khi nhập khoảng cách lần sau (lần 2,3,4....) nó sẽ cộng thêm các khoảng cách lần trước.
Ví dụ cụ thể như sau: Đánh lệnh CCO -> chọn đối tượng cần copy và chọn...
>>
Nhờ các anh chị trong diễn đàn viết hộ em lisp hoặc có lệnh nào trong cad thì chỉ hộ em như sau:
Thao tác giống lệnh copy nhưng khi nhập khoảng cách lần sau (lần 2,3,4....) nó sẽ cộng thêm các khoảng cách lần trước.
Ví dụ cụ thể như sau: Đánh lệnh CCO -> chọn đối tượng cần copy và chọn hướng muốn copy -> nhập khoảng cách: 1254 (lần 1)->enter -> nhập khoảng cách ->6546 (lần 2) -> enter->nhập khoảng cách 1212 (lần 3)....
Kết quả là:
+ đối tượng thứ 2 cách đối tượng gốc là: 1254
+ đối tượng thứ 3 cách đối tượng gốc là: 1254+6546, cách đối tượng thứ 2 là: 6546
+ đối tượng thứ 4 cách đối tượng gốc là: 1254+6546+1212, ...
Mong các anh chị hiểu ý và giúp đỡ!
Hề hề hề,
Không hiểu ý bạn có phải cái này không???
http://www.cadviet.com/upfiles/5/5194_copymultidist.lsp
(defun c:cco (/ ss p0 p1 a d)
(setq oldos (getvar "osmode"))
(setvar "osmode" 0)
(alert "\n Chon doi tuong can copy")
(setq ss (ssget )
p0 (getpoint "\n Chon diem goc")
p1 (getpoint p0 "\n Chon diem dinh huong copy")
a (angle p0 p1)
e (entlast) )
(while (setq d (getdist "\n Nhap khoang cach can copy tiep theo: "))
(command "copy" ss "" p0 (setq p0 (polar p0 a d)))
(setq ss (ssadd))
(while (setq e (entnext e))
(setq ss (ssadd e ss))
)
(setq e (entlast))
)
(setvar "osmode" oldos)
(princ)
)
<<
|
Tác giả: hiepttr
Bài viết gốc: 386386
Tên lệnh: ec |
Nhờ Viết Lisp Tọa Độ Theo File Đính Kem
Rảnh nên soạn sớ tấu cho bạn đây :D :D :D
(defun c:EC( / i p point lst key base_pnt last_pnt fn pw)
;Export Coordinates
(setq i 1)
(while (setq p (getpoint "\nPick Point: "))
(setq point p)
(MakeText (itoa i) 2.5 0 "L" nil nil 1 nil)
(setq p (list i (car p) (cadr p))
i (1+ i)
lst (cons p lst)))
(if (> (length lst) 2)
(progn
(initget "Cad Excel cadAndexcel")
(setq key (NGT key "Cad" getkword "Enter an option...
>> Rảnh nên soạn sớ tấu cho bạn đây :D :D :D
(defun c:EC( / i p point lst key base_pnt last_pnt fn pw)
;Export Coordinates
(setq i 1)
(while (setq p (getpoint "\nPick Point: "))
(setq point p)
(MakeText (itoa i) 2.5 0 "L" nil nil 1 nil)
(setq p (list i (car p) (cadr p))
i (1+ i)
lst (cons p lst)))
(if (> (length lst) 2)
(progn
(initget "Cad Excel cadAndexcel")
(setq key (NGT key "Cad" getkword "Enter an option [Cad/Excel/cadAndexcel]"))
(cond
((wcmatch key "Cad")
(setq #textheight (NGT #textheight 2 getint "Chieu cao chu"))
(setq base_pnt (getpoint "\nDiem chen: "))
(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 'L4 nil (* 5 #textheight) (* 0.5 #textheight) #textheight "MC" "STT" nil)
(setq base_pnt (polar base_pnt 0 (* 5 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MC" "X" nil)
(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MC" "Y" nil)
(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 nil nil (* 10 #textheight) (* 0.5 #textheight) #textheight "MC" "K/CACH (m)" nil)
;;Xong tieu de
(setq base_pnt (polar (polar base_pnt pi (* 35 #textheight)) (* 1.5 pi) (* 2 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil 'L4 nil (* 5 #textheight) (* 0.5 #textheight) #textheight "MC" (itoa (car (last lst))) nil)
(setq base_pnt (polar base_pnt 0 (* 5 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (cadr (last lst)) 2 3) nil)
(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (last (last lst)) 2 3) nil)
(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
(H:Creat_Cel+Data base_pnt nil 'L2 nil nil nil (* 10 #textheight) (* 0.5 #textheight) #textheight "MC" nil nil)
(setq last_pnt (cdr (last lst)))
;;Xong dong 1
(foreach p (cdr (reverse lst))
(setq base_pnt (polar (polar base_pnt pi (* 35 #textheight)) (* 1.5 pi) (* 2 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil 'L4 nil (* 5 #textheight) (* 0.5 #textheight) #textheight "MC" (itoa (car p)) nil)
(setq base_pnt (polar base_pnt 0 (* 5 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (cadr p) 2 3) nil)
(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (last p) 2 3) nil)
(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
(H:Creat_Cel+Data base_pnt nil 'L2 nil nil nil (* 10 #textheight) (* 0.5 #textheight) #textheight "M" (rtos (distance last_pnt (setq last_pnt (cdr p))) 2 3) nil)
)
;;Xong cac diem giua
(setq base_pnt (polar (polar base_pnt pi (* 35 #textheight)) (* 1.5 pi) (* 2 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil 'L4 nil (* 5 #textheight) (* 0.5 #textheight) #textheight "MC" (itoa (car (last lst))) nil)
(setq base_pnt (polar base_pnt 0 (* 5 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (cadr (last lst)) 2 3) nil)
(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (last (last lst)) 2 3) nil)
(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 10 #textheight) (* 0.5 #textheight) #textheight "M" (rtos (distance last_pnt (cdr (last lst))) 2 3) nil)
;;Xong lap lai dong 1 + k/cach khep
)
((wcmatch key "Excel")
(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
(setq pw (open fn "w"))
(write-line "STT,X,Y,K/cach (m)" pw)
(write-line (strcat (itoa (car (last lst))) "," (rtos (cadr (last lst)) 2 3) "," (rtos (last (last lst)) 2 3)) pw)
(setq last_pnt (cdr (last lst)))
(foreach p (cdr (reverse lst))
(write-line (strcat (itoa (car p)) "," (rtos (cadr p) 2 3) "," (rtos (last p) 2 3) "," (rtos (distance last_pnt (setq last_pnt (cdr p))) 2 3)) pw)
)
(write-line (strcat (itoa (car (last lst))) "," (rtos (cadr (last lst)) 2 3) "," (rtos (last (last lst)) 2 3) "," (rtos (distance last_pnt (cdr (last lst))) 2 3)) pw)
(close pw)
)
(t
(setq #textheight (NGT #textheight 2 getint "Chieu cao chu"))
(setq base_pnt (getpoint "\nDiem chen: "))
(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 'L4 nil (* 5 #textheight) (* 0.5 #textheight) #textheight "MC" "STT" nil)
(setq base_pnt (polar base_pnt 0 (* 5 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MC" "X" nil)
(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MC" "Y" nil)
(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 'L3 nil nil (* 10 #textheight) (* 0.5 #textheight) #textheight "MC" "K/CACH (m)" nil)
;;Xong tieu de
(setq base_pnt (polar (polar base_pnt pi (* 35 #textheight)) (* 1.5 pi) (* 2 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil 'L4 nil (* 5 #textheight) (* 0.5 #textheight) #textheight "MC" (itoa (car (last lst))) nil)
(setq base_pnt (polar base_pnt 0 (* 5 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (cadr (last lst)) 2 3) nil)
(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (last (last lst)) 2 3) nil)
(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
(H:Creat_Cel+Data base_pnt nil 'L2 nil nil nil (* 10 #textheight) (* 0.5 #textheight) #textheight "MC" nil nil)
(setq last_pnt (cdr (last lst)))
;;Xong dong 1
(foreach p (cdr (reverse lst))
(setq base_pnt (polar (polar base_pnt pi (* 35 #textheight)) (* 1.5 pi) (* 2 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil 'L4 nil (* 5 #textheight) (* 0.5 #textheight) #textheight "MC" (itoa (car p)) nil)
(setq base_pnt (polar base_pnt 0 (* 5 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (cadr p) 2 3) nil)
(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (last p) 2 3) nil)
(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
(H:Creat_Cel+Data base_pnt nil 'L2 nil nil nil (* 10 #textheight) (* 0.5 #textheight) #textheight "M" (rtos (distance last_pnt (setq last_pnt (cdr p))) 2 3) nil)
)
;;Xong cac diem giua
(setq base_pnt (polar (polar base_pnt pi (* 35 #textheight)) (* 1.5 pi) (* 2 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil 'L4 nil (* 5 #textheight) (* 0.5 #textheight) #textheight "MC" (itoa (car (last lst))) nil)
(setq base_pnt (polar base_pnt 0 (* 5 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (cadr (last lst)) 2 3) nil)
(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 15 #textheight) (* 0.5 #textheight) #textheight "MR" (rtos (last (last lst)) 2 3) nil)
(setq base_pnt (polar base_pnt 0 (* 15 #textheight)))
(H:Creat_Cel+Data base_pnt 'L1 'L2 nil nil nil (* 10 #textheight) (* 0.5 #textheight) #textheight "M" (rtos (distance last_pnt (cdr (last lst))) 2 3) nil)
;;Xong lap lai dong 1 + k/cach khep
;;Xong chen bang trong cad
(setq fn (getfiled "Chon file de xuat ket qua" "" "csv" 1))
(setq pw (open fn "w"))
(write-line "STT,X,Y,K/cach (m)" pw)
(write-line (strcat (itoa (car (last lst))) "," (rtos (cadr (last lst)) 2 3) "," (rtos (last (last lst)) 2 3)) pw)
(setq last_pnt (cdr (last lst)))
(foreach p (cdr (reverse lst))
(write-line (strcat (itoa (car p)) "," (rtos (cadr p) 2 3) "," (rtos (last p) 2 3) "," (rtos (distance last_pnt (setq last_pnt (cdr p))) 2 3)) pw)
)
(write-line (strcat (itoa (car (last lst))) "," (rtos (cadr (last lst)) 2 3) "," (rtos (last (last lst)) 2 3) "," (rtos (distance last_pnt (cdr (last lst))) 2 3)) pw)
(close pw)
)
)
)
(princ "\n***** Phai pick >2 diem ! ***")
)
(princ)
)
;;;End main
;===============================================================================================
(defun NGT(a mac_dinh ham str_nhac / modul)
;;Nhan gia tri
(or a (setq a mac_dinh))
(setq a (cond
((= "" (setq modul (ham (strcat "\n" str_nhac " <" (vl-princ-to-string a) ">: ")))) a)
(modul)
(a)
)
)
)
;=====================
(defun H:Creat_Cel+Data (base_pnt L1 L2 L3 L4 celheight celwidth offset textheight justify string Ang / pnt2 pnt3 pnt4 justify point)
;===================================
(defun MakeText (string Height Ang justify Style Layer Color xdata / Lst)
; Ang: Radial
(setq Lst (list '(0 . "TEXT")
(cons 8 (if Layer Layer (getvar "Clayer")))
(cons 62 (if Color Color 256))
(cons 10 point)
(cons 40 Height)
(cons 1 string)
(cons 50 (if Ang Ang 0))
(cons 7 (if Style Style (getvar "Textstyle")))
(cons -3 (if xdata (list xdata) nil)))
;justify (strcase justify)
)
(cond ((= 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)))))
((= justify "TL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 3)))))
((= justify "TC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 3)))))
((= justify "TR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 3)))))
((= justify "ML") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 2)))))
((= justify "MC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 2)))))
((= justify "MR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 2)))))
((= justify "BL") (setq Lst (append Lst (list (cons 72 0) (cons 11 point) (cons 73 1)))))
((= justify "BC") (setq Lst (append Lst (list (cons 72 1) (cons 11 point) (cons 73 1)))))
((= justify "BR") (setq Lst (append Lst (list (cons 72 2) (cons 11 point) (cons 73 1)))))
)
(entmakex Lst)
);end
;=================================
;=================================
(defun MakeLine (PT1 PT2 Linetype LTScale Layer Color 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 62 (if Color Color 256))
(cons 10 PT1) (cons 11 PT2)
(cons -3 (if xdata (list xdata) nil))))
);end
;=================================
(if (null celheight) (setq celheight (+ textheight (* 2 offset))))
(setq pnt2 (polar base_pnt 0 celwidth)
pnt3 (polar pnt2 (* 1.5 pi) celheight)
pnt4 (polar pnt3 pi celwidth)
)
(if justify (setq justify (strcase justify)))
(cond
((wcmatch justify "C,BC") (setq point (polar (polar pnt4 (* 0.5 pi) offset) 0 (* 0.5 celwidth))))
((wcmatch justify "R,BR") (setq point (polar pnt3 (* 0.75 pi) (* offset (sqrt 2)))))
((wcmatch justify "M") (setq point (polar base_pnt 0 (* 0.5 celwidth))))
((wcmatch justify "MC") (setq point (polar (polar pnt4 (* 0.5 pi) (* 0.5 celheight)) 0 (* 0.5 celwidth))))
((wcmatch justify "TL") (setq point (polar (polar base_pnt (* 1.5 pi) offset) 0 offset)))
((wcmatch justify "TC") (setq point (polar (polar base_pnt (* 1.5 pi) offset) 0 (* 0.5 celheight))))
((wcmatch justify "TR") (setq point (polar pnt2 (* 1.25 pi) (* offset (sqrt 2)))))
((wcmatch justify "ML") (setq point (polar (polar base_pnt (* 1.5 pi) (* 0.5 celheight)) 0 offset)))
((wcmatch justify "MR") (setq point (polar (polar pnt2 (* 1.5 pi) (* 0.5 celheight)) pi offset)))
(t (setq point (polar pnt4 (* 0.25 pi) (* offset (sqrt 2)))))
)
(if L1 (MakeLine pnt4 pnt3 nil nil nil nil nil))
(if L2 (MakeLine pnt3 pnt2 nil nil nil nil nil))
(if L3 (MakeLine base_pnt pnt2 nil nil nil nil nil))
(if L4 (MakeLine pnt4 base_pnt nil nil nil nil nil))
(if string (MakeText string textheight Ang justify nil nil nil nil))
)
<< |