Jump to content
InfoFile
Tác giả: phamxuanly.gtvt
Bài viết gốc: 180625
Tên lệnh: glt
Lisp tính lý trình các điểm trên 1 polyline/line

Hề hề hề,

Nó bảo bạn rằng không có hệ tọa độ nào của người dùng được tạo ra trước đó cả. và thế là nó...

>>

Hề hề hề,

Nó bảo bạn rằng không có hệ tọa độ nào của người dùng được tạo ra trước đó cả. và thế là nó out.

Như vậy chứng tỏ rằng cái bản vẽ này của bạn khác với cái bản vẽ cũ. Và đó cũng chính là điều mà người dùng lisp nhiều khi không lưu ý đến điều này. Mỗi lisp được viết ra có thể chỉ phù hợp với một số giới hạn các cấu trúc bản vẽ mà thôi.

Bạn đã sửa cái lisp này có đúng như mình nói không???

Bạn hãy thử cái này xem sao nhé:



(defun c:glt (/ pl plst pa pd k l a lt lt1 lt2 txt tg etg txtp txtp1 txtp2 dl dl1 dl2)
(vl-load-com)
(command "undo" "be")
(setq ucsold (getvar "ucsname"))
(command "ucs" "W")
(setq pl (car (entsel "\n Chon polyline can ghi ly trinh")))
(setq plst (vl-sort (acet-geom-vertex-list pl) '(lambda (x y) (< (car x) (car y)))))
(setq pa (getstring t "\n Chon diem goc ghi ly trinh <T or P>: "))
(if (= (strcase pa) "T")
   (setq pd (car plst))
   (setq pd (last plst))
)
(setq k (getint "\n Chon so chu so thap phan: "))
(setq l (getint "\n Chon phuong an ghi ly trinh <1 or 2>: "))
(setq a (getpoint "\n Chon point can ghi ly trinh"))
(while ( /= a nil)
(if (= l 1)
   (progn
         (if (equal (vlax-curve-getStartPoint (setq obj (vlax-ename->vla-object pl))) pd 0.001)
             (setq lt (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a)))
             (setq lt (- (vlax-curve-getDistAtPoint obj (vlax-curve-getEndPoint obj))
                           (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a))))
         )
         (setq dl (- lt (* (fix (/ lt 1000)) 1000)))
         (if (< (fix dl) 100)
             (if (< (fix dl) 10)
                 (setq txtp (strcat "00" (rtos dl 2 k)))
                 (setq txtp (strcat "0" (rtos dl 2 k)))
             )
             (setq txtp (rtos dl 2 k))
         )
         (setq txt (strcat "Km" (itoa (fix (/ lt 1000))) "+" txtp))
         (setq tg (car (entsel "\n Chon text can thay the ")))
         (setq etg (entget tg))
         (setq etg (subst (cons 1 txt) (assoc 1 etg) etg))
         (entmod etg)
   )
   (progn
		(if (equal (vlax-curve-getStartPoint (setq obj (vlax-ename->vla-object pl))) pd 0.001)
    		(progn
                 (setq lt1 (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a)))
                 (setq lt2 (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj (getpoint "\n Chon second point can ghi ly trinh"))))
    		)
    		(progn
        		(setq lt1 (- (vlax-curve-getDistAtPoint obj (vlax-curve-getEndPoint obj))
                        		(vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a))))
        		(setq lt2 (- (vlax-curve-getDistAtPoint obj (vlax-curve-getEndPoint obj))
                        		(vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj (getpoint "\n Chon second point can ghi ly trinh")))))
    		)
         )
         (setq dl1 (- lt1 (* (fix (/ lt1 1000)) 1000)))
         (if (< (fix dl1) 100)
             (if (< (fix dl1) 10)
                 (setq txtp1 (strcat "00" (rtos dl1 2 k)))
                 (setq txtp1 (strcat "0" (rtos dl1 2 k)))
             )
             (setq txtp1 (rtos dl1 2 k))
         )
         (setq dl2 (- lt2 (* (fix (/ lt2 1000)) 1000)))
         (if (< (fix dl2) 100)
             (if (< (fix dl2) 10)
                 (setq txtp2 (strcat "00" (rtos dl2 2 k)))
                 (setq txtp2 (strcat "0" (rtos dl2 2 k)))
             )
             (setq txtp2 (rtos dl2 2 k))
         )
         (setq txt (strcat "Km" (itoa (fix (/ lt1 1000))) "+" txtp1 "-Km" (itoa (fix (/ lt2 1000))) "+" txtp2 ))
         (setq tg (car (entsel "\n Chon text can thay the ")))
         (setq etg (entget tg))
         (setq etg (subst (cons 1 txt) (assoc 1 etg) etg))
         (entmod etg)
)
)
(setq a (getpoint "\n Ban hay chon diem tiep theo: "))
)
(if (/= ucsold "")
   (command "ucs" "p")
)
(command "undo" "e")
(princ)
)

 

Nếu vẫn không được thì bạn hãy bỏ dòng code (command "ucs" "p") đi nhé. Vì dòng này sẽ trả bản vẽ về hệ tọa độ người dùng sử dụng trước đó khi nó tồn tại.

Lúc này bạn phải lưu ý rằng tất cả các bản vẽ khi sử dụng lisp này sẽ bị trả hết về hệ tọa độ World và nếu muốn sử dụng lại các hệ tọa độ cũ bạn phải tự làm bằng cách sử dụng lệnh ucsman.

 

Chúc bạn vui.

Giờ thi em làm được rồi, cũng đã hiểu rồi.

Cảm ơn anh nhiều.

chúc anh thành công


<<

Filename: 180625_glt.lsp
Tác giả: angelofmine
Bài viết gốc: 186641
Tên lệnh: lo
Hỏi về Block thuộc tính

Mình cũng ko chắc nhưng có lẽ là do dynamic block nen nó ko làm việc dc???

bạn có thể xài cái lisp mình viết, lisp này chỉ yêu cầu...

>>

Mình cũng ko chắc nhưng có lẽ là do dynamic block nen nó ko làm việc dc???

bạn có thể xài cái lisp mình viết, lisp này chỉ yêu cầu bạn chọn block mẫu, sau đó tự nó làm việc. Xong rồi bạn có thể test lại bằng lệnh attsync xem nó có bị nữa ko nhá!

(defun c:lo(/ ent dtc dt1 sdt id sl nd1 lst1 lt)
 (setq dtc(car (entsel "\nchon block:")))
 (get-block dtc)
 (setq
sdt (sslength dt1)
id 0
lt (list))
 (repeat sdt
(setq ent (ssname dt1 id)
  id (1+ id)
  nd1 (assoc 1 (entget (entnext ent)))
  lt (cons nd1 lt)
  )
)
 (command "attsync" "s" dtc "y")
 (setq sl -1
id (- id 1)
)
 (repeat sdt
(setq ent (ssname dt1 id)
  id (1- id)
  lst1 (entget (entnext ent))
  lst1 (subst (nth (+ sl 1) lt) (assoc 1 lst1) lst1)  
  )
(setq sl (+ sl 1))
(entmod lst1)

)
 )

;;;;;;;;;;;;;;;;;;;;;;;
(defun get-block(entm / sdtb idb ent2 entb dtm namem name BBB entb)
 (setq dtm (vlax-ename->vla-object entm))
 (setq namem (if(vlax-property-available-p dtm 'effectivename)
  (vla-get-effectivename dtm)
  (vla-get-name dtm)
  ));;;
 (setq BBB(SSGET "all" (list(cons 0 "INSERT") (assoc 8 (entget entm))))
sdtb (sslength BBB)
idb 0
dt1 (ssadd)
)
 (repeat sdtb;;repeat
(setq entb (ssname BBB idb)
idb (1+ idb)
)
(setq ent2(vlax-ename->vla-object entb))
(setq name (if(vlax-property-available-p ent2 'effectivename)
  (vla-get-effectivename ent2)
  (vla-get-name ent2)
  ))
(if (= name namem)
 	(setq dt1 (ssadd entb dt1))
 	)
);;repeat
 )

 

Cảm ơn bác nhiều.

Cái Lisp của bác quá tuyệt. Sau khi dùng nó thì đã có thể thay ATTSYNC và không lỗi nữa.


<<

Filename: 186641_lo.lsp
Tác giả: unbroken
Bài viết gốc: 250473
Tên lệnh: ltt
Lisp làm tròn số ( là Text) trong CAD ???????

 

Bạn dùng lisp này thử xem. Lệnh LTT:

 

;;;-------------------------------------------------------(defun etype (e)...
>>

 

Bạn dùng lisp này thử xem. Lệnh LTT:

 

;;;-------------------------------------------------------(defun etype (e) ;;;Entity Type(cdr (assoc 0 (entget e))));;;-------------------------------------------------------(defun C:LTT( / ss n i oldDimzin e d v S)(if (not n0) (setq n0 2))(setq    ss (ssget '((0 . "TEXT,MTEXT")))    n (getint (strcat "\nSo chu so thap phan <" (itoa n0) ">:"))    i 0    oldDimzin (getvar "dimzin"))(if n (setq n0 n) (setq n n0))(setvar "dimzin" 1)(repeat (sslength ss)    (setq e (ssname ss i))    (if (= (etype e) "MTEXT") (progn        (command "explode" e "")        (setq e (entlast))    ))    (setq        d (entget e)        v (atof (cdr (assoc 1 d)))        S (rtos v 2 n)        d (subst (cons 1 S) (assoc 1 d) d)    )    (entmod d)    (setq i (1+ i)))(setvar "dimzin" oldDimzin)(princ));;;-------------------------------------------------------

 

@Tue_NV

Ssg đã xem lại vấn đề hôm nọ. Trong các system var liên quan, chỉ có dimzin ảnh hưởng trực tiếp, các "thằng" khác không thấy tác dụng gì khi dùng (rtos value 2 n). Có lẽ do số 2 đã xác định kiểu decimal. Nếu vậy, ta cứ "chơi" như trên đơn giản hơn.

cái của bạn k dùng được bạn ơi


<<

Filename: 250473_ltt.lsp
Tác giả: txquychk51
Bài viết gốc: 410892
Tên lệnh: gh
Chỉnh Sửa Hàng Loạt Text

 

Bạn thử code này:

(defun c:gh(/ i ss ename entg)
  (setq i -1)
  (if (setq ss (ssget '((0 . "TEXT") (1 . "*# *...
>>

 

Bạn thử code này:

(defun c:gh(/ i ss ename entg)
  (setq i -1)
  (if (setq ss (ssget '((0 . "TEXT") (1 . "*# * #*"))))
    (while (setq ename (ssname ss (setq i (1+ i))))
      (setq entg (entget ename))
      (setq txt (cdr(assoc 1 entg)))
      (setq entg (subst (cons 1 (strcat (substr txt (+ 3 (vl-string-position (ascii "*") txt)) (strlen txt))
       " * "
      (substr txt 1 (- (vl-string-position (ascii "*") txt) 1))
     )
)
        (assoc 1 entg) entg))
      (entmod entg)
    )
  )
  (princ)
)

e đã tử và thành công ạ. cảm ơn a đã giúp


<<

Filename: 410892_gh.lsp
Tác giả: vndesperados
Bài viết gốc: 3678
Tên lệnh: xo
Xoay text thuộc tính trong block
Lệnh XO của lisp dưới đây sẽ xoay góc nghiêng của Attribute Block về 0.

 

(defun c:XO( / ssdt sodt index tt entdt)  
 (setq ssdt (ssget)
sodt...
>>
Lệnh XO của lisp dưới đây sẽ xoay góc nghiêng của Attribute Block về 0.

 

(defun c:XO( / ssdt sodt index tt entdt)  
 (setq ssdt (ssget)
sodt (sslength ssdt)
index 0
 )
 (repeat sodt
   (setq entdt (ssname ssdt index)
  index (1+ index)
  entdt (entnext entdt)
  tt (entget entdt)
  tt (subst (cons 50 0.0) (assoc 50 tt) tt)
   )
   (entmod tt)
   (entupd entdt)
 )
 (princ)
)

 

Sử dụng đặc hiệu trong trường hợp block ký hiệu trục nằm nghiêng.

XoayAttr.gif

 

 

 

Cái này chỉ dùng cho những Block có điểm chèn trùng với tâm Block (BLock có tính đối xứng)

Nếu gặp những Block không có tính đối xứng thì sao???


<<

Filename: 3678_xo.lsp
Tác giả: Doan Van Ha
Bài viết gốc: 421196
Tên lệnh: s1
STRETCH theo 1 phương

Quick code

	(defun C:S1(/ ss p1 p2)
 (initget "N D") (setq ph (getkword "\nChon phuong stretch : "))
 (setq ss (ssget) p1 (getpoint "\nDiem goc: ") p2 (getpoint p1 "\nDiem den: "))
 (if (= ph "N")
  (command "stretch" ss "" p1 (list (car p2) (cadr p1)))
  (command "stretch" ss "" p1 (list (car p1) (cadr p2))))
 (princ))
	


Filename: 421196_s1.lsp
Tác giả: vanduong
Bài viết gốc: 21718
Tên lệnh: fp
Plot nhiều file bản vẽ cùng một lúc
Nhu cầu in hàng loạt chỉ xuất hiện khi đã hoàn thành hồ sơ thiết kế, cần in để trình duyệt hoặc triển khai sản xuất. Các việc cần làm khi đó là:

1) Open hàng loạt file...

>>
Nhu cầu in hàng loạt chỉ xuất hiện khi đã hoàn thành hồ sơ thiết kế, cần in để trình duyệt hoặc triển khai sản xuất. Các việc cần làm khi đó là:

1) Open hàng loạt file bản vẽ cần in

2) Dùng lệnh FP của lisp sau (luôn luôn cho autoload):

 

(defun C:FP( / Dwn)
;;;Fast Print multi-drawings
(setq Dwn (getvar "DWGNAME"))
(command "plot" "" "" "" "" "" "" "" "")
(command "qsave")
(command "close" "Dwn")
)

 

 

Nói thì dài dòng, nhưng tóm gọn lại như sau:

- Lệnh Open, select hàng loạt file bản vẽ và chỉ bấm 1 phát nút "Open"

- Gõ liên tục 2 phím FP cho đến khi... không còn cái gì để gõ và chờ lấy bản vẽ

Nói chung, cách làm này còn hơi có vẻ thủ công, nhưng mình rất yên tâm vì trước khi gõ FP, mình có thể xem lại nội dung bản vẽ đang hiển thị trên màn hình và chắc chắn rằng không có sự nhầm lẫn nào.

Mong được các bạn góp ý thêm.

----------------

Ủa sao tôi chỉ được một bản là sao nhỉ ? nếu gõ tiếp FP thì nó lại chuyển luôn file. dwg >> file.pdf

chả hiểu nữa

----------------

Mong bác SSG giải thích dùm


<<

Filename: 21718_fp.lsp
Tác giả: huunhantvxdts
Bài viết gốc: 266022
Tên lệnh: ed
- Tự động bật - tắt chế độ gõ tiếng việt trong CAD

Lisp này mình lấy về tự chế lại còn bị lỗi 1 số chổ chưa sữa được (đó là phải nhập lệnh ed) nhưng dùng cũng tạm...

>>

Lisp này mình lấy về tự chế lại còn bị lỗi 1 số chổ chưa sữa được (đó là phải nhập lệnh ed) nhưng dùng cũng tạm được. Mình dùng cad2008

;; free lisp from cadviet.com
;;; this lisp was downloaded from http://www.cadviet.com/forum/topic/66851-da-xong-tu-dong-bat-tat-che-do-go-tieng-viet-trong-cad/page-2
 
(vl-load-com)
;;; Dinh nghia lai lenh ED de lay ename doi tuong
(defun c:ed (/ textedit font ent n-textedit n-obj n-ent dk code l-obj obj lst)
(SETQ OLDERR *error*
*error* myerror)
(sendkeys "^+")
(and (or (and (setq textedit (ssget "I"))
           	(sssetfirst textedit)
           	(setq obj (ssname textedit 0)))
      	(setq textedit (entsel) obj (car textedit)))
(while obj
;(setq lst (Start-defun nil))
;(setq textedit (car (entsel)))
(setq ent (cdr (assoc 0 (entget obj))))
(cond ((wcmatch ent "*TEXT"); text
(progn
(setq font (cdr (assoc 7 (entget obj))))
;(setq font (vla-get-stylename (vlax-ename->vla-object textedit)))
(call font)
(command "ddedit" textedit "")
))
((= ent "DIMENSION") ;Dimension
(progn
          	(setq font (vla-get-textstyle (vlax-ename->vla-object obj)))
			;(setq font (vla-get-textstyle (vlax-ename->vla-object textedit)))
          	(call font)
			(command "ddedit" textedit "")
))
((= ent "HATCH") ;Hatch
(progn
          	(initdia)
			(call font)
			(command "hatchedit" textedit)
))
((= ent "INSERT") ;Block
          	(and (eq (type textedit) 'LIST)
               	(setq n-textedit (nentselp (cadr textedit)))
               	(setq n-obj (car n-textedit))
               	(setq n-ent (entget n-obj))
               	(setq n-obj (vlax-ename->vla-object n-obj))
               	(cond ((= (cdr (assoc 0 n-ent)) "ATTRIB") ; Attribute
                      	(setq code (check-font-code (cdr (assoc 7 n-ent))))
                      	(if (eq (vla-get-mtextattribute n-obj) :vlax-false)
                       	(progn
                        	;(setq dk nil dk (sendkeys "^+"))
                        	(cond ((= code "TCVN3") (sendkeys "^+{F2}"))
                              	((= code "UNICODE") (sendkeys "^+{F1}"))
                              	((= code "VNI") (sendkeys "^+{F3}")))))
						(vl-cmdf "eattedit" textedit)
                       	(if dk (sendkeys "^+")))
                     	((wcmatch (cdr (assoc 0 n-ent)) "TEXT,MTEXT") ; Text,Mtext in Block
                      	(if (or extract_clone (and (not extract_clone) (load "trexblk.lsp")))
                       	(progn
                        	(extract_clone n-textedit)
                        	(vla-put-visible n-obj :vlax-false)
                        	(entupd obj)
                        	(progn
							(setq l-obj (entlast) font (cdr (assoc 7 n-ent)))
							(call font)
							(vl-cmdf "DDedit" l-obj "")
							)
                        	(vla-put-textstring n-obj (cdr (assoc 1 (entget l-obj))))
                        	(vla-put-visible n-obj :vlax-true)
                        	(entdel l-obj)
                        	(entupd obj))
                       	(princ "Ban chua cai dat goi Express tool cho CAD\n"))))))
); cond	
;(Done-defun lst)		
(setq textedit (entsel) obj (car textedit))
);while
);and
(back)
(command "HIGHLIGHT" 1 "")
(SETQ *error* OLDERR)
(princ))
;;; Ham call dieu khien bo go tieng viet
(defun call (font / code Crfont)
(if font (setq Crfont font) (setq Crfont (getvar "textstyle")))
   (setq code (check-font-code Crfont))
   (cond ((= code "TCVN3") (sendkeys "^+{F2}"))
((= code "UNICODE") (sendkeys "^+{F1}"))
((= code "VNI") (sendkeys "^+{F3}"))
)
)
;;; Ham tra lai English
(defun back ()
(sendkeys "^+")
)
;;; Ham kiem tra bang ma cua textstyle (su dung true type font)
;;; style: String - ten cua textstlye kiem tra
(defun Check-Font-Code (style / ts font Bold Italic charSet PitchandFamily)
(setq ts (vlax-ename->vla-object (tblobjname "style" style)))
(vla-GetFont ts 'font 'Bold 'Italic 'charSet 'PitchandFamily)
(if (= font "") (setq font (vla-get-fontfile ts)))
(cond ((wcmatch (setq font (strcase font)) "ARIAL*,TAHOMA*,TIMES*,COURIER NEW,CAMBRIA,CONSOLAS") "UNICODE")
    ((wcmatch font ".VN*") "TCVN3")
    ((wcmatch font "VNI*") "VNI")))
;;; Ham senkeys
(defun SendKeys (keys / wscript)
(vlax-invoke-method (setq wscript (vlax-create-object "WScript.Shell")) 'sendkeys keys)
(vlax-release-object wscript))
;;;Ham bay loi
(defun myerror (s)
(if (= s "Function Cancelled") (sendkeys "^+"))
  (setq *error* OLDERR)
  (princ)
)
(defun Start-defun (lst-var)
(defun *error* (msg)
(redraw)
(vl-cmdf "undo" "end")
(vl-cmdf "undo" "")
(princ));end
(vl-cmdf "undo" "begin")
(mapcar '(lambda(x) (list x (getvar x))) lst-var));end
;;;
(defun Done-defun (lst-var / )
(mapcar '(lambda (x) (setvar (car x) (cadr x))) lst-var)
(vl-cmdf "undo" "end")
(princ));end

Bạn kiểm tra lại xem sau khi load lsp lên,khi chỉnh sửa text xong nó lại ko tự tắt unikey đi nhể!

Thanks!

Có ai bị như vậy ko nhể chứ của mình vẫn sử dụng bình thường mà ko bị như vậy. chắc bạn chỉnh text xong ấn ESC phải ko??? phải ấn enter để hết lệnh


<<

Filename: 266022_ed.lsp
Tác giả: Tue_NV
Bài viết gốc: 107893
Tên lệnh: md
Lisp sửa giá trị của dim
mình viết cho bạn rồi đó. chúc thành công

http://www.cadviet.com/upfiles/3/md.lsp

>>
mình viết cho bạn rồi đó. chúc thành công

http://www.cadviet.com/upfiles/3/md.lsp

(defun ttt(AA / aa pt1 pt2 pt3 pt4 pt5 so d1 d2 pt11 k50)
   (SETQ PT1 (CDR (ASSOC '13 AA)))
   (SETQ PT2 (CDR (ASSOC '14 AA)))
   (SETQ pt3 (list (car pt2) (cadr pt1)))
   (SETQ pt4 (list (car pt1) (cadr pt2)))
   (SETQ PT11 (CDR (ASSOC '11 AA)))
   (setq d1 (distance pt1 pt3))
   (setq d2 (distance pt1 pt4))
   (setq k50 (cdr (ASSOC '50 AA)))
   (if (= k50 0)
     (setq so (rtos d1))
     (setq so (rtos d2))
     )
   )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun c:md(/ so dt m dtc t1 t2 ent ent_ht sodoituong index)
 (prompt "\nChon dim thay doi gia tri: ")
 (setq dtc (ssget '((0 . "dimension"))))
 (prompt "\nChon dim tham chieu: ")
 (setq dtm (entsel))  
 (setq t1 (entget (car dtm)))
 (if (= (atof (cdr(assoc 1 t1))) 0.0)	
(setq so (ttt t1))
(setq so (cdr(assoc 1 t1)))
)
 (defun chu (ent / ent)
   (setq t2 (entget ent))
   (setq t2 (subst (cons 1 so) (assoc 1 t2) t2 ))
   (entmod t2)
   )
 (setq
   sodoituong (sslength dtc)
   index 0    
   )
 (repeat sodoituong
   (setq
     ent_ht (ssname dtc index)
     index (1+ index)
     )
   (chu ent_ht)
   )
 (princ)  
 )

bạn có thể chọn nhiều đối tượng dim để thay đổi giá trị theo một đối tượng tham chiễu

Lisp này không đúng yêu cầu của bạn vminh_ct rồi

Bác nào có lisp thay đổi giá trị của dim khi mình pick vào 1 điểm, vd như hình vẽ của e dưới đây. Làm sao líp dùng chọn đối tượng dim có giá trị 1358.98 rồi pick vào điểm thuộc đường đỏ dim này sẽ biến thành giá trị của dim dưới có giá trị 1094,02.

đây là file cad của em.

http://www.cadviet.com/upfiles/3/sua_gia_tri_dim.dwg

Theo như yêu cầu của bạn vminh_ct thì Lisp có thể xây dựng được nhưng Tue_NV nghĩ rằng nó cũng không nhanh hơn CAD là bao nhiêu (Chỉ cần dùng Grid mà kéo là được)

 

Lisp của lp_hai là Lisp sửa giá trị Dim hay nói cách khác là "độ chế" Dim. Nó cũng như lệnh Ded (dimedit) nhưng lệnh Ded (dimedit) có nhiều tính năng hơn


<<

Filename: 107893_md.lsp
Tác giả: jangboko
Bài viết gốc: 404648
Tên lệnh: tt%C2%A0
Nhờ Chỉnh Sửa Lisp Chuyển Dim Về Dim Hiện Hành

 

Thử cái này xem:

(defun c:tt  (/ adoc ent obj)
 (if (setq ent (car (entsel "\nChon 1 doi tuong:...
>>

 

Thử cái này xem:

(defun c:tt  (/ adoc ent obj)
 (if (setq ent (car (entsel "\nChon 1 doi tuong: ")))
  (progn (setq adoc (vla-get-activedocument (vlax-get-acad-object))
               obj  (vlax-ename->vla-object ent))
         (mapcar 'setvar
                 '("CLAYER" "CELTYPE" "CECOLOR")
                 (mapcar '(lambda (x) (vl-princ-to-string (vlax-get obj x))) '("Layer" "Linetype" "Color")))
         (cond ((wcmatch (strcase (vla-get-ObjectName obj)) "*TEXT") (setvar 'TEXTSTYLE (vlax-get obj 'StyleName)))
               ((wcmatch (strcase (vla-get-ObjectName obj)) "*DIMENSION")
                (vla-put-activedimstyle adoc (vla-item (vla-get-dimstyles adoc) (vlax-get obj 'StyleName)))
                (setvar 'DIMSCALE (vlax-get obj 'ScaleFactor))))))
 (princ))

 

cảm ơn anh đã giúp em, lisp của anh gần đúng với ý của em rồi, chỉ còn 1 thông số " Dim scale linear" nó chưa thay đổi theo dim hiện hành. Anh chỉnh sửa thêm cho em  nhé. Cám ơn anh !!!!


<<

Filename: 404648_tt%C2%A0.lsp
Tác giả: vantran
Bài viết gốc: 92751
Tên lệnh: hkh
chuyển tọa độ từ file excel sang cad
Chào vantran, Lisp này chạy khi trong bản vẽ của bạn đã có block "HOKHOAN" và trong file dữ liệu thêm 1 dòng tiêu đề như trong file Thiep gửi cho bạn sau:

>>
Chào vantran, Lisp này chạy khi trong bản vẽ của bạn đã có block "HOKHOAN" và trong file dữ liệu thêm 1 dòng tiêu đề như trong file Thiep gửi cho bạn sau:

http://www.cadviet.com/upfiles/2/dulieudavoi.zip

Còn đây là lisp:

;| Lisp nhap cac blockref LOKHOAN tu file du lieu *.txt
  copyright by TRAN THIEP V1 03/2010
  Yeu cau: ACAD da co cai dat Express Tools
=====================================================|;
(vl-load-com)
(defun c:hkh (/ ActDoc  *Model* *layer*	f       Lh      posX    posY
      name    Z	  Se	p       objblk  n	    taglst
     )
 (setq ActDoc   (vla-get-ActiveDocument (vlax-get-acad-object))
       *Model*  (vla-get-ModelSpace ActDoc)
       *layer*  (vla-get-Layers ActDoc)
       *sumary* (vla-get-SummaryInfo ActDoc)
 )
 (vla-StartUndoMark ActDoc)
 (or fn (setq fn (getfiled "chon file du lieu"
	     "d:/"
	     "txt"
	     0
     )
     )
 )
 (or (tblobjname "layer" "LOKHOAN")(vla-add *layer* "LOKHOAN"))
 (acet-sysvar-set
   (list "cmdecho" 0 "osmode" 0 "clayer" "LOKHOAN")
 )
 (setq f (open fn "r"))
 (setq	Lh   (ACET-STR-TO-LIST "\t" (read-line f))
posX (vl-position "Y" Lh)
posY (vl-position "X" Lh)
name (vl-position "TEN" Lh)
Z    (vl-position "H" Lh)
 )
 (setq	tyle (cond	(tyle)
	(1)
  )
 )
 (setq oldtyle tyle)
 (setq tyle (getreal (strcat "\nChon ty le chen khoi <"
		   (rtos oldtyle 2 0)
		   "> : "
	   )
  )
 )
 (if (null tyle)
   (setq tyle oldtyle)
 )
 (while (setq Lh (read-line f))
   (setq Se (ACET-STR-TO-LIST "\t" Lh)
  p  (list (distof (nth posX Se) 2)
	   (distof (nth posY Se) 2)
	   (distof (nth Z Se) 2)
     )
   )
   (setq	objblk (vla-InsertBlock
         *Model*
         (vlax-3d-point p)
         "HOKHOAN"
         tyle
         tyle
         1
         0
       )
n      0
   )
   (setq taglst (vlax-safearray->list
	   (vlax-variant-value
	     (vla-getattributes objblk)
	   )
	 )
   )
   (foreach att taglst
     (cond ((eq (vla-get-tagstring att) "TENHK")
     (vla-put-textstring att (nth name Se))
    )
    ((eq (vla-get-tagstring att) "Z")
     (vla-put-textstring att (nth Z Se))
    )

     )
   )
 )
 (close f)
 (acet-sysvar-restore)
 (vla-EndUndoMark ActDoc)
 (vla-put-Author *sumary* "TRAN-THIEP 0918841230")
 (vla-put-Comments
   *sumary*
   (strcat
     "This drawing used to use hokhoan.lsp"
     " "
     " Copyright by Tran Thiep"
     " "
     " Thank you very much"
    )
 )
 (princ "\nThiep chuc ban thanh cong")
 (princ)
)

Thanks Thiep nhe. mình đã làm được rồi. hy vọng sẽ được học hỏi nhiều


<<

Filename: 92751_hkh.lsp
Tác giả: Tue_NV
Bài viết gốc: 94042
Tên lệnh: blkqty
Viết lisp theo yêu cầu [phần 2]
Vụ chèn hình là “chuyện nhỏ” cũng không phải "giữ bí mật" nhưng vì muốn giải quyết rốt ráo nên chậm Update cho anh em.

Nhưng nay thấy "AKA...

>>
Vụ chèn hình là “chuyện nhỏ” cũng không phải "giữ bí mật" nhưng vì muốn giải quyết rốt ráo nên chậm Update cho anh em.

Nhưng nay thấy "AKA buông súng" nên Post lên anh em sài thử!

 

...........

 

Sau  02 bà rồi sẽ là cái này :333.jpg

 

Bổ sung tùy chọn : nhập ký hiệu Block

Code :

(defun c:BlkQty (/ blk_id blk_len blk_name cur_var ent h height i ins 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")))
 (vla-settextstyle objTblSty acTitleRow  TxtSty)
 (vla-settextstyle objTblSty acHeaderRow TxtSty)
 (vla-settextstyle objTblSty acDataRow   TxtSty)
 (vla-setvariable *adoc "CTableStyle" tbl_name) )
;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 (vla-get-name (vlax-Ename->Vla-Object 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) (      (setq cur_var (mapcar 'getvar '("DYNMODE" "DYNPROMPT")))
     (mapcar 'setvar '("DYNMODE" "DYNPROMPT") '(1 1))
     (initget "Yes No")
     (setq ins (getkword "\nChen ki hieu Block  : ") )
     (or ins (setq ins "Yes"))
     (mapcar 'setvar '("DYNMODE" "DYNPROMPT") cur_var)      
     (or *h* (setq *h* (* (getvar "dimtxt")(getvar "dimscale"))))
     (initget 6)
     (setq h (getreal (strcat "\nChieu cao chu  :")))      
     (if h (setq *h* h) (setq h *h*) )
     (setq *adoc (vla-get-ActiveDocument (vlax-get-acad-object))
    msp (vla-get-modelspace *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 2))
      (list acTitleRow acHeaderRow acDataRow))      
     (vla-MergeCells TblObj 0 0 0 3)
     (vla-setText TblObj 0 0 "Bang thong ke")
     (mapcar '(lambda (x y)(vla-setText TblObj 1 x y))
      (list 0 1 2 3 4)
      (list "STT" "Ten" "Don vi" "So luong" "Ky hieu"))      
     (setq row 2 i 1)    
     (foreach pt lst_blk
(setq blk_name (car pt) )
(mapcar '(lambda (x y)(vla-setText TblObj row x y))
      (list 0 1 2 3)
      (list i blk_name "cai" (cdr pt)))
(if (= ins "Yes")
  (vla-SetBlockTableRecordId TblObj row 4 (vla-get-objectID (vla-item (vla-get-blocks *adoc) 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))

Code quá tuyệt, gãi đúng ngay chổ ngứa :cheers: . Tick thanks không chưa đã, phải nói lời cảm ơn mới được.

Tue_NV chân thành cảm ơn anh gia bach thật nhiều


<<

Filename: 94042_blkqty.lsp
Tác giả: gia_bach
Bài viết gốc: 186968
Tên lệnh: extag1
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Các bác giúp mình với:

- Mình có vla-object name của đối tượng block insert chứa một số attribute, tag là "a" "b" "c"... chẳng...

>>

Các bác giúp mình với:

- Mình có vla-object name của đối tượng block insert chứa một số attribute, tag là "a" "b" "c"... chẳng hạn.

giờ mình muốn lấy vla-object name của thằng ku "a" thì làm thế nào? mình ngại chuyển về ename nên không muốn dùng cách này.

 

- mở rộng hơn, mình có ActiveSelectionSet là tập hợp của các block trên:

(ssget '((0 . "INSERT")))

(vla-get-ActiveSelectionSet *document*)

giờ mình muốn có code ngắn nhất để lấy được danh sách (list) vla-object của tất cả đối tượng con có tag là "a"

Thaistreetz tham khảo Lisp này (đổi nội dung biến tag theo nhu cầu):

(defun c:exTag (/  attlst e i obj reslst ss tag tagname)
 (vl-load-com)
 (if (setq ss (ssget (list (cons 0 "INSERT")(cons 66 1))))
(progn
 	(setq i -1 tag "a") ; doi ten tag
 	(while (setq e (ssname ss (setq i (1+ i))))
(setq obj (vlax-Ename->Vla-Object e)
  	attLst (vlax-invoke obj 'GetAttributes))
(foreach att attLst
  (setq tagName (vla-get-TagString att))
  (if (= tagName tag)
(setq resLst (cons att resLst)) )) );(vla-get-TextString att)
 	(princ (vl-princ-to-string resLst)) ))
 (princ))

 

hay

(defun c:exTag1 (/  reslst tag )
 (vl-load-com)
 (if (ssget(list (cons 0 "INSERT")(cons 66 1)))
(progn
 	(setq tag "a") ; doi ten tag
 	(vlax-for obj (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(foreach att (vlax-invoke obj 'GetAttributes)
  (if (= (vla-get-TagString att) tag)
(setq resLst (cons att resLst)) )));(vla-get-TextString att)
 	(princ (vl-princ-to-string resLst))   ) )
 (princ))


<<

Filename: 186968_extag1.lsp
Tác giả: Thaistreetz
Bài viết gốc: 186977
Tên lệnh: fg
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Cảm ơn các bác. đúng là 1 lúc ngâm cứu code của bác Gia Bách thì thấy chuẩn luôn rồi. mình hồ đồ quá :P

(defun c:fg (/ lst)
(ssget '((0 . "INSERT")))
(setq tag "a")
(vlax-for Obj (vla-get-ActiveSelectionSet *document*)
(setq lst (append (vlax-invoke obj 'GetAttributes) lst)))
(vl-remove-if-not '(lambda (x) (and x (= tag (vla-get-TagString x)))) lst))

 

Mình có 1 chút thắc mắc nữa...

>>

Cảm ơn các bác. đúng là 1 lúc ngâm cứu code của bác Gia Bách thì thấy chuẩn luôn rồi. mình hồ đồ quá :P

(defun c:fg (/ lst)
(ssget '((0 . "INSERT")))
(setq tag "a")
(vlax-for Obj (vla-get-ActiveSelectionSet *document*)
(setq lst (append (vlax-invoke obj 'GetAttributes) lst)))
(vl-remove-if-not '(lambda (x) (and x (= tag (vla-get-TagString x)))) lst))

 

Mình có 1 chút thắc mắc nữa chưa tìm được lời giải:

mới đầu mình dùng code này để lấy list att : (vlax-safearray->list (vlax-variant-value (vla-getattributes obj)))

tuy nhiên nó không khả thi vì lúc thì nó lấy được, lúc thì nó báo lỗi tại hàm vlax-variant-value, nội dung như thế này:

error: ActiveX Server returned an error: Invalid index

thế là sao nhỉ?


<<

Filename: 186977_fg.lsp
Tác giả: gia_bach
Bài viết gốc: 187098
Tên lệnh: fg
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Cảm ơn các bác. đúng là 1 lúc ngâm cứu code của bác Gia Bách thì thấy chuẩn luôn rồi. mình hồ đồ quá :P

>>

Cảm ơn các bác. đúng là 1 lúc ngâm cứu code của bác Gia Bách thì thấy chuẩn luôn rồi. mình hồ đồ quá :P

(defun c:fg (/ lst)
(ssget '((0 . "INSERT")))
(setq tag "a")
(vlax-for Obj (vla-get-ActiveSelectionSet *document*)
(setq lst (append (vlax-invoke obj 'GetAttributes) lst)))
(vl-remove-if-not '(lambda (x) (and x (= tag (vla-get-TagString x)))) lst))

 

Mình có 1 chút thắc mắc nữa chưa tìm được lời giải:

mới đầu mình dùng code này để lấy list att : (vlax-safearray->list (vlax-variant-value (vla-getattributes obj)))

tuy nhiên nó không khả thi vì lúc thì nó lấy được, lúc thì nó báo lỗi tại hàm vlax-variant-value, nội dung như thế này:

error: ActiveX Server returned an error: Invalid index

thế là sao nhỉ?

Do đối tuợng không phải là Block thuộc tính.

Cách khắc phục :

- kiểm tra block có thuộc tính hay không : (eq :vlax-true (vla-get-hasAttributes obj))

- hoặc lọc ngay từ ssget : (ssget(list (cons 0 "INSERT")(cons 66 1)))


<<

Filename: 187098_fg.lsp
Tác giả: gia_bach
Bài viết gốc: 186968
Tên lệnh: extag
Hỏi về Lisp (thuật toán, ý tưởng, coding,...)

Các bác giúp mình với:

- Mình có vla-object name của đối tượng block insert chứa một số attribute, tag là "a" "b" "c"... chẳng...

>>

Các bác giúp mình với:

- Mình có vla-object name của đối tượng block insert chứa một số attribute, tag là "a" "b" "c"... chẳng hạn.

giờ mình muốn lấy vla-object name của thằng ku "a" thì làm thế nào? mình ngại chuyển về ename nên không muốn dùng cách này.

 

- mở rộng hơn, mình có ActiveSelectionSet là tập hợp của các block trên:

(ssget '((0 . "INSERT")))

(vla-get-ActiveSelectionSet *document*)

giờ mình muốn có code ngắn nhất để lấy được danh sách (list) vla-object của tất cả đối tượng con có tag là "a"

Thaistreetz tham khảo Lisp này (đổi nội dung biến tag theo nhu cầu):

(defun c:exTag (/  attlst e i obj reslst ss tag tagname)
 (vl-load-com)
 (if (setq ss (ssget (list (cons 0 "INSERT")(cons 66 1))))
(progn
 	(setq i -1 tag "a") ; doi ten tag
 	(while (setq e (ssname ss (setq i (1+ i))))
(setq obj (vlax-Ename->Vla-Object e)
  	attLst (vlax-invoke obj 'GetAttributes))
(foreach att attLst
  (setq tagName (vla-get-TagString att))
  (if (= tagName tag)
(setq resLst (cons att resLst)) )) );(vla-get-TextString att)
 	(princ (vl-princ-to-string resLst)) ))
 (princ))

 

hay

(defun c:exTag1 (/  reslst tag )
 (vl-load-com)
 (if (ssget(list (cons 0 "INSERT")(cons 66 1)))
(progn
 	(setq tag "a") ; doi ten tag
 	(vlax-for obj (vla-get-ActiveSelectionSet (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(foreach att (vlax-invoke obj 'GetAttributes)
  (if (= (vla-get-TagString att) tag)
(setq resLst (cons att resLst)) )));(vla-get-TextString att)
 	(princ (vl-princ-to-string resLst))   ) )
 (princ))


<<

Filename: 186968_extag.lsp
Tác giả: thanhduan2407
Bài viết gốc: 104476
Tên lệnh: ftext
Viết giúp Lisp xoá text trong khoảng nhất định
Bạn chạy thử LISP : Lọc các Text thỏa điều kiện có k/cách nhỏ hơn 1 giá trị cho truớc -> chuyển sang layer khác (cho phép chọn tên layer) + Xuất các Text ra 2...
>>
Bạn chạy thử LISP : Lọc các Text thỏa điều kiện có k/cách nhỏ hơn 1 giá trị cho truớc -> chuyển sang layer khác (cho phép chọn tên layer) + Xuất các Text ra 2 file (Txt hoặc CSV)

 

Cách sử dụng :

gõ lệnh : Ftext (Filter Text)

- chọn Text

- nhập k/cách

- nhập tên Layer chứa Text cần lọc (nếu layer chưa có, lisp sẽ tạo mới)

- chọn tên file xuất Text gốc, Lisp sẽ tự tao file chứa Text cần lọc với qui tắc : tên file gốc + _filter

vd : tên file gốc là Cadviet.csv -> tên file chứa Text cần lọc : Cadviet_filter.csv

Hy vọng hữu ích với bạn.

;Filter Text
(defun c:FText (/ ent ent1 fil fil1 flag j kc newlayer pos ss ss1 str str1 ss_tmp tmp tmp1)
 ;|By Gia Bach 2010|;
 (command "_.undo" "be")
 (setq ss (ssget (list (cons 0 "TEXT"))) ss1 (ssadd))
 (or kc1 (setq kc1 5))
 (setq kc (getreal (strcat "\nNhap khoang cach : <" (rtos kc1) ">")))
 (if (= kc nil)  (setq kc kc1) (setq kc1 kc))
 (while (> (sslength ss) 0)
   (setq ent (ssname ss 0)
  pos (cdr (assoc 10 (entget ent)))  
  ss (ssdel ent ss)
  ss_tmp ss
  flag nil)
   (setq j -1)
   (while (setq ent1 (ssname ss_tmp (setq j (1+ j))))
     (if (<= (distance pos (cdr (assoc 10 (entget ent1)))) kc)
(setq flag t
      str1 (append (list (cdr (assoc 1 (entget ent1)))) str1)
      ss1 (ssadd ent1 ss1)
      ss (ssdel ent1 ss)) ) )
   (if flag
     (setq ss1 (ssadd ent ss1)
    str1 (append (list(cdr (assoc 1 (entget ent)))) str1))
     (setq str (append (list(cdr (assoc 1 (entget ent)))) str)) ) )
 (if (> (sslength ss1) 0)
   (progn
     (setq newlayer (getstring t "\nNhap ten layer chua Text can filter :"))
     (if (not (tblsearch "layer" newlayer))
(command "-layer" "n" newlayer"")	)         
     (command "change" ss1 "" "p" "la" newlayer "")
     (if (setq tmp (getfiled "Chon file xuat Text goc" (getvar "dwgprefix") "csv;txt" 1))
(progn
  (setq fil (open tmp "w") )
  (foreach txt str
    (write-line txt fil)   )
  (close fil)
  (setq tmp1 (strcat (vl-filename-directory tmp) "\\"
		     (vl-filename-base tmp) "_filter"
		     (vl-filename-extension tmp))
	fil1 (open tmp1 "w"))
  (foreach txt str1
    (write-line txt fil1)   )
  (close fil1)	  ))  ))
 (command "_.undo" "e")
 (princ))

Nói như bạn NDBNGO: "Xoá khủng khiếp quá " không đúng vì lisp bác Gia_bach viết đúng theo yêu cầu của bạn đưa ra. Nhưng có một vấn đề khi chạy chương trình là bác đã xác định những text nào nằm đè lên nhau thì nó cũng xoá. Như vậy, nếu các text cứ nằm đè lên nhau và trải dài thì nó chỉ để lại text đầu tiên. Trong công việc đo sâu của chúng em khi đo trên sông thì đo bằng máy hồi âm nó sẽ đo liên tục và đến đoạn xoay tàu khi đo đến gần bờ thì nó sẽ có rất nhiều điểm gần và trùng nhau cần phải xoá bớt đi. Vì vậy lisp của bác Gia_Bach sẽ không giải quyết được vấn đề. Vậy em đưa ra một ý tưởng là bác có thể dùng mắt lưới để lọc text. Ví dụ như kích thước mắt lưới là 15x15 chẳng hạn, lưới kích thước 15x15 này bao trùm tất cả các text được chọn. Với mắt lưới như vậy, xét tất cả các text nằm trong cùng một ô với kích thước 15x15, text nào nằm gần với tâm của ô lưới nhất thì được giữ lại và xoá (hoặc tạo 1 layer có màu khác). Em đưa ra ý tưởng như thế có được không hả bác? Mong bác đóng góp ý kiến (ghi chú: text có tọa độ nằm trên cạnh mắt lưới thì xoá). Cảm ơn mọi người đã đóng góp ý kiến. Cảm ơn bác Gia_Bach, bác luôn lên tiếng đúng lúc mọi người cần. Thanks bác nhiều.


<<

Filename: 104476_ftext.lsp
Tác giả: thanhduan2407
Bài viết gốc: 104502
Tên lệnh: ftext
Viết giúp Lisp xoá text trong khoảng nhất định
Tui không phải trong nghề nên cũng không hiểu hết được yêu cầu của các bạn.

Như đã viết ở trên, tui nghĩ vấn đề của các bạn là : Xóa(chuyển Layer) các TEXT...

>>
Tui không phải trong nghề nên cũng không hiểu hết được yêu cầu của các bạn.

Như đã viết ở trên, tui nghĩ vấn đề của các bạn là : Xóa(chuyển Layer) các TEXT nằm chồng lấp lên nhau sau đó xuất ra file các số liệu của TEXT.

Các bạn dùng thử LISP này xem có đáp ứng đuợc không.

- bổ sung : File xuât ra phải có 4 cột: N0(Text) X (Tọa độ X) Y (Tọa dộ Y) H (Tọa dộ Z)

(do không biết qui luật của Số thứ tự)

 

to NDBNGO : việc lọc LAYER không khó, cái chính là chúng ta thống nhất đuợc mục tiêu của vấn đề, đang chờ ý kiến của bạn. Đã chạy thử LISP trên file Cad bạn gửi.

(defun c:FText (/ ent ent1 fil fil1 i j lst newlayer pos ss ss0 ss1 ss_tmp str str1 tmp tmp1)
 ;|By Gia Bach 2010|;
(defun MakeBound (ent / ang elist ll lr tb tb1 tb2 ul ur)
 (setq elist (entget ent)
ang   (cdr (assoc 50 elist))
tb    (textbox elist)
tb1   (car tb)
tb2   (cadr tb)
ll    (polar (cdr (assoc 10 elist))
	     (+(angle '(0 0) tb1) ang) (DISTANCE '(0 0) tb1))
lr    (polar ll ang (- (car tb2) (car tb1)))
ur    (polar ll (+ ang (angle tb1 tb2)) (distance tb1 tb2))
ul    (polar ll (+ ang (/ pi 2)) (- (cadr tb2) (cadr tb1)))    )
 (list ll lr ur ul))

 (command "_.undo" "be")
 (setq ss (ssget (list (cons 0 "TEXT"))) ss1 (ssadd) ss0 (ssadd))
 (while (> (sslength ss) 0)
   (setq ent (ssname ss 0)
  lst (MakeBound ent) )
   (ssdel ent ss)
   (if (setq ss_tmp (ssget "cp" lst (list(cons 0 "TEXT"))))
     (progn
(setq i -1)
(while (setq ent1 (ssname ss_tmp (setq i (1+ i))))
  (if (not (equal ent ent1))
    (progn
      (setq str1 (append (list (list (cdr (assoc 1 (entget ent1)))
				     (cdr (assoc 10 (entget ent1))))) str1))
      (ssadd ent1 ss1)
      (if (ssmemb ent1 ss) (ssdel ent1 ss))
      (if (ssmemb ent1 ss0) (ssdel ent1 ss0)))))	) )
   (if (not (ssmemb ent ss1)) (ssadd ent ss0))    )
 (setq j -1)
 (while (setq ent (ssname ss0 (setq j (1+ j))))
   (setq str (append (list (list (cdr (assoc 1 (entget ent)))
			  (cdr (assoc 10 (entget ent))))) str)) )
 (if (> (sslength ss1) 0)
   (progn
     (setq newlayer "CV");(getstring t "\nNhap ten layer chua Text can filter :"))
     (if (not (tblsearch "layer" newlayer))
(command "-layer" "n" newlayer "c" 2 newlayer "")	)         
     (command "change" ss1 "" "p" "la" newlayer "")
     (if (setq tmp (getfiled "Chon file xuat Text goc" (getvar "dwgprefix") "csv;txt" 1))
(progn
  (setq fil (open tmp "w") )
  (foreach txt str
    (setq pos (cadr txt))
    (write-line (strcat (car txt) (chr 44) (rtos(car pos)) (chr 44) (rtos(cadr pos))(chr 44) 
                           (rtos(caddr pos)))fil)   )
  (close fil)
  (setq tmp1 (strcat (vl-filename-directory tmp) "\\"
		     (vl-filename-base tmp) "_filter"
		     (vl-filename-extension tmp))
	fil1 (open tmp1 "w"))
  (foreach txt str1
    (setq pos (cadr txt))
    (write-line (strcat (car txt) (chr 44) (rtos(car pos)) (chr 44) (rtos(cadr pos))(chr 44) 
                           (rtos(caddr pos))) fil1)   )
  (close fil1)  ))  ) )
 (command "_.undo" "e")
 (princ))

Tuyệt vời.


<<

Filename: 104502_ftext.lsp
Tác giả: npkh1981
Bài viết gốc: 14084
Tên lệnh: c2e
chuyển text bảng từ cad sang excel
Lệnh C2E dưới đây sẽ giúp bạn.

(defun c:c2e ( / hangdau)
 (defun sosanh	(e1 e2 / p1 p2)
   (setq p1 (car e1)
  p2 (car e2)
   )
   (if	(equal (cadr p1) (cadr p2)...
>>
Lệnh C2E dưới đây sẽ giúp bạn.

(defun c:c2e ( / hangdau)
 (defun sosanh	(e1 e2 / p1 p2)
   (setq p1 (car e1)
  p2 (car e2)
   )
   (if	(equal (cadr p1) (cadr p2) fuzz)
     (< (car p1) (car p2))
     (> (cadr p1) (cadr p2))
   )
 )
 (setq
   ss	    (ssget '((0 . "TEXT")))    
   lst	    (ss2ent ss)
   lst     (mapcar '(lambda (e) (cons (cdr (assoc 10 (entget e))) (cdr (assoc 1 (entget e))))) lst)  
   caotext (cdr (assoc 40 (entget (ssname ss 0))))
   fuzz    (* caotext 1.0)
   lst	    (vl-sort lst 'sosanh)
   index   1
   oldy nil
   fn      (getfiled "Chon file de save" "" "csv" 1)
   fid     (open fn "w")
 )

 (foreach e lst
   (if	(equal oldy (cadr (car e)) fuzz)
     (progn        
(princ "," fid)
(setq index (1+ index))
     )      
     (progn
(if hangdau
  (progn
    (setq index 1)	
    (princ "\n" fid)	    
  )
  (setq hangdau t)
 )
     )
   )
   (princ (cdr e) fid)
   (setq oldy (cadr (car e)))
 )
 (close fid)
)

(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)
)

Cám ơn bác đã giúp mình

Nhưng có cách nào tách riêng từng text ra từng ô được không


<<

Filename: 14084_c2e.lsp
Tác giả: quan_elec
Bài viết gốc: 95365
Tên lệnh: draw name
viết lisp thống kê bản vẽ
Để Tue_NV giúp anh gia_bach một tay nhé :

Các bạn chạy lại code thử và góp ý nhé :

(defun c:draw_name (/ att doc i kyhieu lst lstatt msp pt row ss tblobj...
>>
Để Tue_NV giúp anh gia_bach một tay nhé :

Các bạn chạy lại code thử và góp ý nhé :

(defun c:draw_name (/ att doc i kyhieu lst lstatt msp pt row ss tblobj ten) ;Bang ten ban ve
;; By : Gia Bach, Copyright- December 2009 ;;
;; Contact : gia_bach @ www.CadViet.com ;;
(defun VxGetAtts (Obj)
(mapcar
'(lambda (Att)
(cons (vla-get-TagString Att)
(vla-get-TextString Att) ) )
(vlax-invoke Obj 'GetAttributes) ))
(if (> (atof (substr (getvar "ACADVER") 1 4)) 16.0) (progn

(if (setq ss (ssget "_A"(list (cons 0 "INSERT")(cons 66 1)(cons 2 "KHUNG CHUAN SEICO"))))
(progn
(vl-load-com)
(setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object))
msp (vla-get-modelspace doc))
(foreach e (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
(setq lstAtt (VxGetAtts (vlax-ename->vla-object e))
kyhieu (cdr (assoc "DWNNO" lstAtt))
ten (cdr (assoc "DRAWING1" lstAtt)))
(setq lst (cons (cons kyhieu ten) lst)) )
(setq lst (vl-sort lst '(lambda (x y) (< (atoi(substr (car x) 4 (- (strlen (car x)) 3)))
(atoi (substr (car y) 4 (- (strlen (car y)) 3)))
) ) ))
(setq i 1
row 2
pt (getpoint "\nDiem dat Bang :")
TblObj (vla-addtable msp (vlax-3d-point pt) (+ (length lst) 2) 3 15 100))
(vla-put-vertcellmargin TblObj 4)
(vla-SetColumnWidth TblObj 0 50)
(mapcar '(lambda (x)(vla-setTextHeight TblObj x 5))
(list acTitleRow acHeaderRow acDataRow) )
(mapcar '(lambda (x)(vla-setAlignment TblObj x 2))
(list acTitleRow acHeaderRow acDataRow))
(vla-setText TblObj 0 0 "list of drawings") 
(vla-setText TblObj 1 0 "STT")
(vla-setText TblObj 1 1 "Ten ban e")
(vla-setText TblObj 1 2 "Ky hieu")
(foreach pt lst
(vla-setText TblObj row 0 (itoa i))
(vla-setText TblObj row 1 (cdr pt))
(vla-setText TblObj row 2 (car pt))
(setq row (1+ row) i (1+ i))
)
(vlax-release-object TblObj)
(princ lst) ) ) )
(alert "\nPhien ban Cad cua ban khong ho tro tao Bang (TABLE)")
))

@anh gia_bach : Hàm vl-sort nó sắp xếp các kí tự chuỗi theo alphabet.

Ví dụ như List :

(setq L (list "1" "2" "3" "4" "5" "6" "7" "8" "9" "10" "11" "12" "98" "99" "100"))

 

khi sử dụng vl-sort nó sắp xếp các kí tự chuỗi theo alphabet.

=> Kết quả sẽ trả về như thế này thì không theo ý của User

("1" "10" "100" "11" "12" "2" "3" "4" "5" "6" "7" "8" "9" "98" "99")

-> Nó ưu tiên sắp xếp kí tự "1.." trước mà anh

 

Nhưng khi ta set nó về số thì sẽ đúng theo ý User

.Ví dụ :

(setq L (list 1 2 3 4 5 6 7 8 9 10 11 12 99 100))

(vl-sort L '<)

(1 2 3 4 5 6 7 8 9 10 11 12 99 100)

thì khi sử dụng vl-sort theo ý của mình nên em đã sử dụng hàm atoi để chuyển chuõi kí tự về dạng số rồi so sánh chúng với nhau để theo ý của mình

 

Anh gia_bach cho Tue_NV hỏi thêm về chổ này một chút :

(mapcar '(lambda (x)(vla-setTextHeight TblObj x 5))

(list acTitleRow acHeaderRow acDataRow) )

(mapcar '(lambda (x)(vla-setAlignment TblObj x 2))

(list acTitleRow acHeaderRow acDataRow))

 

4 mã code này em chưa rõ ý nghĩa của nó lắm. Anh có thể giải thích dùm em 1 chút nhé.

Cảm ơn anh

 

-Cám ơn bác gia_bach và Tue_NV , mình đã download Lisp này và "xào , nấu " lại cho khung tên của công ty mình .Kết quả là việc thống kê rất nhanh chóng . Tuy nhiên

có phần vẫn hơi vướng :

+ Đối với những tên bản vẽ dài phải sử dụng 2 text mới thể hiện đủ tên bản vẽ thì lisp này không thể hiện được text thứ 2 .

- Để thể hiện được cả 2 text này thì phải làm sao ? 2 bác giúp em với nhé . (Do căn bản Lisp không có nên mò mẫm mấy buổi trời vẫn không ra , HIX) .

- Sẵn đây hỏi các bác chỗ dạy Autolisp trong Saigon luôn , bác nào có chỗ dạy hay chỉ em với nhé . Thanks . :cheers:


<<

Filename: 95365_draw_name.lsp

Trang 247/304

247