Viết lisp theo yêu cầu [phần 2]

Tháng 5 15, 2010

cái này thì việc j phải dùng lisp, bạn gõ aa để tính diện tích rồi gõ tiếp o để chọn object cần tính là đc, object có thể là vùng hatch, hình vuông, đường bo ...

bạn đọc kỹ yêu cầu của mình đi.Lệnh aa đâu có viết diện tích cần tính ra text được.Khi đã hỏi đến Lisp là người ta đã dùng các lệnh có sẵn trong cad mà không được rồi.Thân

Tháng 5 16, 2010

Xin chào mọi người.Mình có 1 yêu cầu nhỏ.Mọi người giúp đỡ.Ai có lisp tính diện tích phần hatch rồi ghi ra file text ( có thể ghi bất kỳ chỗ nào mình kích chuột hoặc là chọn text sẵn có cũng được).Trên diễn đàn có file lisp này rồi nhưng link không down được.Ai có hoặc làm được thì up lên giúp mình nhé.Cảm ơn rất nhiều.

Mình có cách nhưng hơi thủ công. Bạn tham khảo nhé, nếu có ai viết lisp giúp bạn thì bạn dùng lisp. À, mà bạn search kỹ lại trên dđ đi, mình thấy hình như vấn đề bạn yêu cầu có bạn khác đã hỏi rồi.

Còn đây là cách của mình:

- Bạn copy cái hatch ra chổ khác. Click đúp vô, chọn Recreate boundary, chọn Polyline, chọn Y/N gì cũng được. => Sẽ tạo ra đc các polyline kín.

- Dùng lisp tính diện tích quét 1 lượt hết các polyline đó, ghi ra text.

Xong.

Lisp tdt trên bạn tư search nhé. Còn ko được thì bạn down ACV 1.0 về cài, sẽ có.

Thân!

Tháng 5 18, 2010

Hề hề hê,

Mình chạy thử rồi, nó đây nè bạn:

Kết quả chạy:

http://www.cadviet.com/upfiles/2/lb2.jpg

Còn đây là cái lisp đã sửa nè:

(defun c:lb2 ()
(vl-load-com)
(command "undo" "be")
(setq en (entsel "\n Chon pline ")
ob (vlax-ename->vla-object (car en))
n (vlax-curve-getEndParam ob)
i 0
li1 (list)
)
(setq pb (getpoint "\n Chon diem dat bang")
h (getreal "\n Nhap chieu cao chu: ")
k (getreal "\n Nhap do rong cot: ")
)
(entmake (list (cons 0 "TEXT") (cons 10 pb) (cons 40 h) (cons 1 "BANG KET QUA")))
(entmake 
(list (cons 0 "TEXT") (cons 10 (list (car pb) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "STT")))
(entmake 
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) k) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "X")))
(entmake 
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 2 k)) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "Y")))
(entmake 
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 3 k)) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "Z")))
(while (<= i n)
(setq p (vlax-curve-getPointAtParam ob i) 
li1 (append li1 (list p))
y (- (cadr pb) (* (+ 2 i) 1.5 h))
)
(entmake (list (cons 0 "TEXT") (cons 10 (list (car p) (+ (cadr p) 5))) (cons 40 1.0)
(cons 1 (strcat "X=" (rtos (car p) 2 2)))))
(entmake (list (cons 0 "TEXT") (cons 10 (list (car p) (+ (cadr p) 2.5))) (cons 40 1.0)
(cons 1 (strcat "Y=" (rtos (cadr p) 2 2)))))
(entmake (list (cons 0 "TEXT") (cons 10 (list (car p) (cadr p))) (cons 40 1.0)
(cons 1 (strcat "Z=" (rtos (caddr p) 2 2)))))
(entmake 
(list (cons 0 "TEXT") (cons 10 (list (car pb) y)) (cons 40 h) (cons 1  (rtos (1+ i) 2 0))))
(entmake 
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) k) y)) (cons 40 h) (cons 1 (rtos (car p ) 2 2))))
(entmake 
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 2 k)) y)) (cons 40 h) (cons 1 (rtos (cadr p ) 2 2))))
(entmake 
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 3 k)) y)) (cons 40 h) (cons 1 (rtos (caddr p) 2 2))))
(setq i (1+ i))
)
(command "undo" "e")
(princ)
)

Hề hề hề, bạn xem xem có giống cái bạn đã sửa không hỉ????

Nhờ bạn giúp cho việc chèn các nút vào các đỉnh đường.

Cám ơn.

Tháng 5 19, 2010

Nhờ bạn giúp cho việc chèn các nút vào các đỉnh đường.
Cám ơn.

Đây bạn dùng thử.

(defun c:lb2 (/ en ob i li1 h k y pb)
(vl-load-com)
(command "undo" "be")
(setq en (entsel "\n Chon pline ")
ob (vlax-ename->vla-object (car en))
n (vlax-curve-getEndParam ob)
i 0
li1 (list)
)
(setq pb (getpoint "\n Chon diem dat bang")
h (getreal "\n Nhap chieu cao chu: ")
k (getreal "\n Nhap do rong cot: ")
)
(entmake (list (cons 0 "TEXT") (cons 10 pb) (cons 40 h) (cons 1 "BANG KET QUA")))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (car pb) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "STT")))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) k) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "X")))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 2 k)) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "Y")))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 3 k)) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "Z")))
(while (<= i n)
(setq p (vlax-curve-getPointAtParam ob i)
li1 (append li1 (list p))
y (- (cadr pb) (* (+ 2 i) 1.5 h))
)
(command "-insert" "Moc Hanh" p "1" "1" "0" (strcat "D" (rtos (1+ i) 2 0)))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (car pb) y)) (cons 40 h) (cons 1 (strcat "D" (rtos (1+ i) 2 0)))))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) k) y)) (cons 40 h) (cons 1 (rtos (car p ) 2 2))))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 2 k)) y)) (cons 40 h) (cons 1 (rtos (cadr p ) 2 2))))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 3 k)) y)) (cons 40 h) (cons 1 (rtos (caddr p) 2 2))))
(setq i (1+ i))
)
(command "undo" "e")
(princ)
)

PS: chỉ đúng với gốc toạ độ WORLD còn khi xoay gốc toạ độ không còn đúng nữa.

Kèm theo block này nữa nhé. (copy block trong file dưới vào bản vẽ của bạn) Chúc bạn thành công.

http://www.cadviet.com/upfiles/2/moc_hanh.dwg

Tháng 5 19, 2010

Nhờ các Bác viết giúp đoạn code dùng để xuất tất cả tên các Layers có trong bản vẽ (vì có nhiều Xref và rất nhiều Layers) ra một file Text.

Mục đích dùng để viết ra 1 Lisp khác tiện việc tắt mở các Layers trong bản vẽ. Cám ơn nhiều.

Tháng 5 19, 2010

Nhờ các Bác viết giúp đoạn code dùng để xuất tất cả tên các Layers có trong bản vẽ (vì có nhiều Xref và rất nhiều Layers) ra một file Text.
Mục đích dùng để viết ra 1 Lisp khác tiện việc tắt mở các Layers trong bản vẽ. Cám ơn nhiều.

Bạn dùng thử lệnh LMAN của bộ EXPRESS chưa?

Tháng 5 19, 2010

Đây bạn dùng thử.

(defun c:lb2 (/ en ob i li1 h k y pb)
(vl-load-com)
(command "undo" "be")
(setq en (entsel "\n Chon pline ")
ob (vlax-ename->vla-object (car en))
n (vlax-curve-getEndParam ob)
i 0
li1 (list)
)
(setq pb (getpoint "\n Chon diem dat bang")
h (getreal "\n Nhap chieu cao chu: ")
k (getreal "\n Nhap do rong cot: ")
)
(entmake (list (cons 0 "TEXT") (cons 10 pb) (cons 40 h) (cons 1 "BANG KET QUA")))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (car pb) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "STT")))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) k) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "X")))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 2 k)) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "Y")))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 3 k)) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "Z")))
(while (<= i n)
(setq p (vlax-curve-getPointAtParam ob i)
li1 (append li1 (list p))
y (- (cadr pb) (* (+ 2 i) 1.5 h))
)
(command "-insert" "Moc Hanh" p "1" "1" "0" (strcat "D" (rtos (1+ i) 2 0)))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (car pb) y)) (cons 40 h) (cons 1 (strcat "D" (rtos (1+ i) 2 0))))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) k) y)) (cons 40 h) (cons 1 (rtos (car p ) 2 2))))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 2 k)) y)) (cons 40 h) (cons 1 (rtos (cadr p ) 2 2))))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 3 k)) y)) (cons 40 h) (cons 1 (rtos (caddr p) 2 2))))
(setq i (1+ i))
)
(command "undo" "e")
(princ)
)

PS: chỉ đúng với gốc toạ độ WORLD còn khi xoay gốc toạ độ không còn đúng nữa.

Kèm theo block này nữa nhé. (copy block trong file dưới vào bản vẽ của bạn) Chúc bạn thành công.

http://www.cadviet.com/upfiles/2/moc_hanh.dwg

Cám ơn , nhưng sao mình chạy lisp không thể hiện gì cả.

Mong được bạn giúp

Tháng 5 20, 2010

Cám ơn , nhưng sao mình chạy lisp không thể hiện gì cả.
Mong được bạn giúp

Mình sửa rồi đấy (copy block của mình vào trước khi chạy lisp nhé)

(defun c:lb2 (/ en ob i li1 h k y pb)
(vl-load-com)
(command "undo" "be")
(setq en (entsel "\n Chon pline ")
ob (vlax-ename->vla-object (car en))
n (vlax-curve-getEndParam ob)
i 0
li1 (list)
)
(setq pb (getpoint "\n Chon diem dat bang")
h (getreal "\n Nhap chieu cao chu: ")
k (getreal "\n Nhap do rong cot: ")
)
(entmake (list (cons 0 "TEXT") (cons 10 pb) (cons 40 h) (cons 1 "BANG KET QUA")))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (car pb) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "STT")))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) k) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "X")))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 2 k)) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "Y")))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 3 k)) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "Z")))
(while (<= i n)
(setq p (vlax-curve-getPointAtParam ob i)
li1 (append li1 (list p))
y (- (cadr pb) (* (+ 2 i) 1.5 h))
)
(command "-insert" "Moc Hanh" p "1" "1" "0" (strcat "D" (rtos (1+ i) 2 0)))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (car pb) y)) (cons 40 h) (cons 1 (strcat "D" (rtos (1+ i) 2 0)))))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) k) y)) (cons 40 h) (cons 1 (rtos (car p ) 2 2))))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 2 k)) y)) (cons 40 h) (cons 1 (rtos (cadr p ) 2 2))))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 3 k)) y)) (cons 40 h) (cons 1 (rtos (caddr p) 2 2))))
(setq i (1+ i))
)
(command "undo" "e")
(princ)
)

Tháng 5 20, 2010

Bac Tue oi. giup minh ti

ãy giúp mình viết lisp cho cái này nhé các ban. cảm ơn

http://www.cadviet.com/upfiles/2/rai_cot_cho_ho_ga_1.dwg

http://www.cadviet.com/upfiles/2/file_hoan...u_the_nay_1.dwg

mình cần rãi hố ga và điền cốt cho các vị trí hố ga với khoảng cách các hố ga đó

khi đã biết hố ga và cốt của hố ga này và cốt ga cuối

cac khoang cach hố ga nay thi tuỳ ý người dung nhập vào

Tháng 5 20, 2010

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ử!

- cột số lượng nếu <10 thì thêm số 0 vào trước ví dụ: 02

thọat nghe có vẽ có lý, nhưng t/hợp cột số lượng có giá trị hàng trăm (hàng ngàn) thì các số khác cũng phải biểu thị cùng format.

VD : 001 002 010 … với hàng ngàn còn rối mắt hơn.

Để giải quyết t/hợp này chỉ cần căn lề phải các số là hợp lý.

- Sort column :

mặc định LISP sort cột Tên theo mẫu tự ABC tên của BLOCK

việc sort theo cột số lượng là t/hợp ít khi dùng nên bỏ qua (đôi khi vẫn sử dụng) :rolleyes:

các t/hợp khác cần phải viết thêm hộp thoại cho USER chọn lựa →

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

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

Code :

(defun c:BlkQty (/ blk_id blk_len blk_name blks cur_var ent h header_lsp height i
	 ins j len0 lst_blk msp pt row ss str tblobj width width1 width2 x y)
;;  By : Gia Bach, gia_bach @  www.CadViet.com             ;;
(defun TxtWidth (val h msp / txt minp maxp)
 (setq	txt (vla-AddText msp val (vlax-3d-point '(0 0 0)) h))
 (vla-getBoundingBox txt 'minp 'maxp )
 (vla-Erase txt)
 (-(car(vlax-safearray->list maxp))(car(vlax-safearray->list minp)))  )

(defun GetOrCreateTableStyle (tbl_name / name namelst objtblsty objtblstydic tablst txtsty)
 (setq objTblStyDic (vla-item (vla-get-dictionaries *adoc) "ACAD_TABLESTYLE") )  
 (foreach itm (vlax-for itm objTblStyDic
	 (setq tabLst (append tabLst (list itm))))
   (if (not
  (vl-catch-all-error-p
    (setq name (vl-catch-all-apply 'vla-get-Name (list itm)))))
     (setq nameLst (append nameLst (list name)))  )  )
 (if (not (vl-position tbl_name nameLst))
   (vla-addobject objTblStyDic tbl_name "AcDbTableStyle"))
 (setq objTblSty (vla-item objTblStyDic tbl_name)
TxtSty (variant-value (vla-getvariable *adoc "TextStyle")))
 (mapcar '(lambda (x)(vla-settextstyle objTblSty x TxtSty))
      (list acTitleRow acHeaderRow acDataRow) )
 (vla-setvariable *adoc "CTableStyle" tbl_name) )

(defun GetObjectID (obj)
 (if (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
   (vlax-invoke-method
     (setq Utility
       (cond
  (Utility)
         ((vla-get-Utility *adoc))))
     'GetObjectIdString obj :vlax-false )
   (vla-get-Objectid obj)))  
;main
 (if (setq ss (ssget (list (cons 0 "INSERT"))))
   (progn
     (vl-load-com)
     (setq i -1 len0 8)
     (while (setq ent (ssname ss (setq i (1+ i))))
(setq blk_name (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) (< (car x) (car y)) ) ))
     (setq cur_var (mapcar 'getvar '("DYNMODE" "DYNPROMPT")))
     (mapcar 'setvar '("DYNMODE" "DYNPROMPT") '(1 1))
     (initget "Yes No")
     (setq ins (getkword "\nChen ki hieu Block [Yes/No ]  : ") )
     (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 <" (rtos *h*) "> :")))      
     (if h (setq *h* h) (setq h *h*) )
     (setq *adoc (vla-get-ActiveDocument (vlax-get-acad-object))
    msp (vla-get-modelspace *adoc)
    blks (vla-get-blocks *adoc))      
     (setq width1 (* 2 (TxtWidth "STT" h msp))
    width (* 2 (TxtWidth "So luong" h msp))
    height (* 2 h))
     (if str
(setq width2 (* 1.5 (TxtWidth (strcase str) h msp)))
(setq width2 width))
     (if (> h 3)
(setq width (* (fix (/ width 10))10)
      width1 (* (fix (/ width1 10))10)
      width2 (* (fix (/ width2 10))10)
      height (* (fix (/ height 5))5)))
     (GetOrCreateTableStyle "CadViet")
     (setq pt (getpoint "\nDiem dat Bang :")
    TblObj (vla-addtable msp (vlax-3d-point pt) (+ (length lst_blk) 2) 5 height width))
     (vla-put-regeneratetablesuppressed TblObj :vlax-true)
     (vla-SetColumnWidth TblObj 0 width1)
     (vla-SetColumnWidth TblObj 1 width2)
     (vla-put-vertcellmargin TblObj (* 0.75 h))
     (vla-put-horzcellmargin TblObj (* 0.75 h))
     (mapcar '(lambda (x)(vla-setTextHeight TblObj x h))
      (list acTitleRow acHeaderRow acDataRow) )
     (mapcar '(lambda (x)(vla-setAlignment TblObj x 2))
      (list acTitleRow acHeaderRow acDataRow))      
     (vla-MergeCells TblObj 0 0 0 3)
     (vla-setText TblObj 0 0 "Bang thong ke")
     (setq j -1 header_lsp (list "STT" "Ten" "Don vi" "So luong" "Ky hieu")) 
     (repeat (length header_lsp)
(vla-setText TblObj 1 (setq j (1+ j)) (nth j header_lsp)))
     (setq row 2 i 1)    
     (foreach pt lst_blk
(setq blk_name (car pt) j -1)
(mapcar '(lambda (x)(vla-setText TblObj row (setq j (1+ j)) x))
	(list i blk_name "cai" (cdr pt)))
(if (= ins "Yes")
  (vla-SetBlockTableRecordId TblObj row 4 (GetObjectID (vla-item blks blk_name)) :vlax-true))
(vla-SetCellAlignment TblObj row 1 7)
(vla-SetCellAlignment TblObj row 3 9)
(setq row (1+ row) i (1+ i))	)
     (vla-put-regeneratetablesuppressed TblObj :vlax-false)
     (vlax-release-object TblObj) )  )
 (princ))

Lisp này gia_bach có thể viết thêm phần hỗ trợ các Block có tên tiếng Việt (Unicode) không ? Được thì hay quá pác. Thanks u

Tháng 5 20, 2010

Lisp này gia_bach có thể viết thêm phần hỗ trợ các Block có tên tiếng Việt (Unicode) không ? Được thì hay quá pác. Thanks u

Update : Thống kê Block trong bản vẽ.

Fix : tên Block tiếng Việt .

(defun c:BlkQty (/ blk_id blk_len blk_name blks ent h header_lsp height i j
	 len0 lst_blk msp pt row ss str tblobj width width1 width2 x y)
;;  By : Gia Bach, gia_bach @  www.CadViet.com             ;;
(defun TxtWidth (val h msp / txt minp maxp)
 (setq	txt (vla-AddText msp val (vlax-3d-point '(0 0 0)) h))
 (vla-getBoundingBox txt 'minp 'maxp )
 (vla-Erase txt)
 (-(car(vlax-safearray->list maxp))(car(vlax-safearray->list minp)))  )

(defun GetOrCreateTableStyle (tbl_name / name namelst objtblsty objtblstydic tablst txtsty)
 (setq objTblStyDic (vla-item (vla-get-dictionaries *adoc) "ACAD_TABLESTYLE") )  
 (foreach itm (vlax-for itm objTblStyDic
	 (setq tabLst (append tabLst (list itm))))
   (if (not
  (vl-catch-all-error-p
    (setq name (vl-catch-all-apply 'vla-get-Name (list itm)))))
     (setq nameLst (append nameLst (list name)))  )  )
 (if (not (vl-position tbl_name nameLst))
   (vla-addobject objTblStyDic tbl_name "AcDbTableStyle"))
 (setq objTblSty (vla-item objTblStyDic tbl_name)
TxtSty (variant-value (vla-getvariable *adoc "TextStyle")))
 (mapcar '(lambda (x)(vla-settextstyle objTblSty x TxtSty))
      (list acTitleRow acHeaderRow acDataRow) )
 (vla-setvariable *adoc "CTableStyle" tbl_name) )

(defun GetObjectID (obj)
 (if (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
   (vlax-invoke-method *util 'GetObjectIdString obj :vlax-false )
   (vla-get-Objectid obj)))  
;main
 (if (setq ss (ssget (list (cons 0 "INSERT"))))
   (progn
     (vl-load-com)
     (setq i -1 len0 8)
     (while (setq ent (ssname ss (setq i (1+ i))))
(setq blk_name (cdr (assoc 2 (entget ent))))
(if (> (setq blk_len (strlen blk_name)) len0)
  (setq str blk_name len0 blk_len) )	
(if (not (assoc blk_name lst_blk))
  (setq lst_blk (cons (cons blk_name 1) lst_blk))
  (setq lst_blk (subst (cons blk_name (1+ (cdr (assoc blk_name lst_blk))))
		       (assoc blk_name lst_blk) lst_blk)))	    )
     (setq lst_blk (vl-sort lst_blk '(lambda (x y) (< (car x) (car y)) ) ))
     (or *h* (setq *h* (* (getvar "dimtxt")(getvar "dimscale"))))
     (initget 6)
     (setq h (getreal (strcat "\nChieu cao chu <" (rtos *h*) "> :")))      
     (if h (setq *h* h) (setq h *h*) )
     (or *adoc (setq *adoc (vla-get-ActiveDocument (vlax-get-acad-object))))
     (setq msp (vla-get-modelspace *adoc)
    *util (vla-get-Utility *adoc)
    blks (vla-get-blocks *adoc))      
     (setq width1 (* 2 (TxtWidth "STT" h msp))
    width (* 2 (TxtWidth "So luong" h msp))
    height (* 2 h))
     (if str
(setq width2 (* 1.5 (TxtWidth (strcase str) h msp)))
(setq width2 width))
     (if (> h 3)
(setq width (* (fix (/ width 10))10)
      width1 (* (fix (/ width1 10))10)
      width2 (* (fix (/ width2 10))10)
      height (* (fix (/ height 5))5)))
     (GetOrCreateTableStyle "CadViet")
     (setq pt (getpoint "\nDiem dat Bang :")
    TblObj (vla-addtable msp (vlax-3d-point pt) (+ (length lst_blk) 2) 5 height width))
     (vla-put-regeneratetablesuppressed TblObj :vlax-true)
     (vla-SetColumnWidth TblObj 0 width1)
     (vla-SetColumnWidth TblObj 1 width2)
     (vla-put-vertcellmargin TblObj (* 0.75 h))
     (vla-put-horzcellmargin TblObj (* 0.75 h))
     (mapcar '(lambda (x)(vla-setTextHeight TblObj x h))
      (list acTitleRow acHeaderRow acDataRow) )
     (mapcar '(lambda (x)(vla-setAlignment TblObj x 8))
      (list acTitleRow acHeaderRow acDataRow))      
     (vla-MergeCells TblObj 0 0 0 4)
     (vla-setText TblObj 0 0 "Bang thong ke")
     (setq j -1 header_lsp (list "STT" "Ten" "Don vi" "So luong" "Ky hieu")) 
     (repeat (length header_lsp)
(vla-setText TblObj 1 (setq j (1+ j)) (nth j header_lsp)))
     (setq row 2 i 1)    
     (foreach pt lst_blk
(setq blk_name (car pt) j -1)
(mapcar '(lambda (x)(vla-setText TblObj row (setq j (1+ j)) x))
	(list i blk_name "cai" (cdr pt)))
(vla-SetBlockTableRecordId TblObj row 4 (GetObjectID (vla-item blks blk_name)) :vlax-true)
(vla-SetCellAlignment TblObj row 1 7)
(vla-SetCellAlignment TblObj row 3 9)
(setq row (1+ row) i (1+ i))	)
     (vla-put-regeneratetablesuppressed TblObj :vlax-false)
     (vlax-release-object TblObj) )  )
 (princ))

Tháng 5 20, 2010

Chào các bác!

hôm trước út có "nhặt" được trên diễn đàn lisp nhập khối lượng rất hay. Nhưng út thấy vẫn còn mật thời gian. Các bác xem chỉnh lại út với.

lisp thực hiện như sau:

Sau khi đánh lệnh lish hỏi số text trên 1 hàng (như trong bv của út thì nhập 28)

rồi sau đó chọn tấc cả các text.

kết quả là được 1 file ketqua.txt

File đính kèm (gồm có 1 lisp út đã sử dụng, 1 file cad ví dụ, 1 file kết quả sau khi chạy lisp)

http://www.cadviet.com/upfiles/2/nhap_khoi_luong.dwg

http://www.cadviet.com/upfiles/2/file_ket_...i_chay_lisp.txt

http://www.cadviet.com/upfiles/2/khoi_luong_kl.lsp

Tháng 5 20, 2010

Mình sửa rồi đấy (copy block của mình vào trước khi chạy lisp nhé)

(defun c:lb2 (/ en ob i li1 h k y pb)
(vl-load-com)
(command "undo" "be")
(setq en (entsel "\n Chon pline ")
ob (vlax-ename->vla-object (car en))
n (vlax-curve-getEndParam ob)
i 0
li1 (list)
)
(setq pb (getpoint "\n Chon diem dat bang")
h (getreal "\n Nhap chieu cao chu: ")
k (getreal "\n Nhap do rong cot: ")
)
(entmake (list (cons 0 "TEXT") (cons 10 pb) (cons 40 h) (cons 1 "BANG KET QUA")))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (car pb) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "STT")))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) k) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "X")))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 2 k)) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "Y")))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 3 k)) (- (cadr pb) (* 1.5 h)))) (cons 40 h) (cons 1 "Z")))
(while (<= i n)
(setq p (vlax-curve-getPointAtParam ob i)
li1 (append li1 (list p))
y (- (cadr pb) (* (+ 2 i) 1.5 h))
)
(command "-insert" "Moc Hanh" p "1" "1" "0" (strcat "D" (rtos (1+ i) 2 0)))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (car pb) y)) (cons 40 h) (cons 1 (strcat "D" (rtos (1+ i) 2 0)))))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) k) y)) (cons 40 h) (cons 1 (rtos (car p ) 2 2))))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 2 k)) y)) (cons 40 h) (cons 1 (rtos (cadr p ) 2 2))))
(entmake
(list (cons 0 "TEXT") (cons 10 (list (+ (car pb) (* 3 k)) y)) (cons 40 h) (cons 1 (rtos (caddr p) 2 2))))
(setq i (1+ i))
)
(command "undo" "e")
(princ)
)

Cám ơn bạn, mình đã chạy được.

Nhưng xin bạn xem giúp : Mổi lần thống kê điểm pline thì mình phải copy block moc_hanh.dwg vào thì bất tiện, mình có thể viết lệnh cho chèn vào được không bạn. Bảng kết qủa mình có thể kẻ bảng cho đẹp.

Nhờ Bạn giúp, mong tin

Tháng 5 20, 2010

Update : Thống kê Block trong bản vẽ.

Fix : tên Block tiếng Việt .

(defun c:BlkQty (/ blk_id blk_len blk_name blks ent h header_lsp height i j
	 len0 lst_blk msp pt row ss str tblobj width width1 width2 x y)
;;  By : Gia Bach, gia_bach @  www.CadViet.com             ;;
(defun TxtWidth (val h msp / txt minp maxp)
 (setq	txt (vla-AddText msp val (vlax-3d-point '(0 0 0)) h))
 (vla-getBoundingBox txt 'minp 'maxp )
 (vla-Erase txt)
 (-(car(vlax-safearray->list maxp))(car(vlax-safearray->list minp)))  )

(defun GetOrCreateTableStyle (tbl_name / name namelst objtblsty objtblstydic tablst txtsty)
 (setq objTblStyDic (vla-item (vla-get-dictionaries *adoc) "ACAD_TABLESTYLE") )  
 (foreach itm (vlax-for itm objTblStyDic
	 (setq tabLst (append tabLst (list itm))))
   (if (not
  (vl-catch-all-error-p
    (setq name (vl-catch-all-apply 'vla-get-Name (list itm)))))
     (setq nameLst (append nameLst (list name)))  )  )
 (if (not (vl-position tbl_name nameLst))
   (vla-addobject objTblStyDic tbl_name "AcDbTableStyle"))
 (setq objTblSty (vla-item objTblStyDic tbl_name)
TxtSty (variant-value (vla-getvariable *adoc "TextStyle")))
 (mapcar '(lambda (x)(vla-settextstyle objTblSty x TxtSty))
      (list acTitleRow acHeaderRow acDataRow) )
 (vla-setvariable *adoc "CTableStyle" tbl_name) )

(defun GetObjectID (obj)
 (if (vl-string-search "64" (getenv "PROCESSOR_ARCHITECTURE"))
   (vlax-invoke-method *util 'GetObjectIdString obj :vlax-false )
   (vla-get-Objectid obj)))  
;main
 (if (setq ss (ssget (list (cons 0 "INSERT"))))
   (progn
     (vl-load-com)
     (setq i -1 len0 8)
     (while (setq ent (ssname ss (setq i (1+ i))))
(setq blk_name (cdr (assoc 2 (entget ent))))
(if (> (setq blk_len (strlen blk_name)) len0)
  (setq str blk_name len0 blk_len) )	
(if (not (assoc blk_name lst_blk))
  (setq lst_blk (cons (cons blk_name 1) lst_blk))
  (setq lst_blk (subst (cons blk_name (1+ (cdr (assoc blk_name lst_blk))))
		       (assoc blk_name lst_blk) lst_blk)))	    )
     (setq lst_blk (vl-sort lst_blk '(lambda (x y) (< (car x) (car y)) ) ))
     (or *h* (setq *h* (* (getvar "dimtxt")(getvar "dimscale"))))
     (initget 6)
     (setq h (getreal (strcat "\nChieu cao chu <" (rtos *h*) "> :")))      
     (if h (setq *h* h) (setq h *h*) )
     (or *adoc (setq *adoc (vla-get-ActiveDocument (vlax-get-acad-object))))
     (setq msp (vla-get-modelspace *adoc)
    *util (vla-get-Utility *adoc)
    blks (vla-get-blocks *adoc))      
     (setq width1 (* 2 (TxtWidth "STT" h msp))
    width (* 2 (TxtWidth "So luong" h msp))
    height (* 2 h))
     (if str
(setq width2 (* 1.5 (TxtWidth (strcase str) h msp)))
(setq width2 width))
     (if (> h 3)
(setq width (* (fix (/ width 10))10)
      width1 (* (fix (/ width1 10))10)
      width2 (* (fix (/ width2 10))10)
      height (* (fix (/ height 5))5)))
     (GetOrCreateTableStyle "CadViet")
     (setq pt (getpoint "\nDiem dat Bang :")
    TblObj (vla-addtable msp (vlax-3d-point pt) (+ (length lst_blk) 2) 5 height width))
     (vla-put-regeneratetablesuppressed TblObj :vlax-true)
     (vla-SetColumnWidth TblObj 0 width1)
     (vla-SetColumnWidth TblObj 1 width2)
     (vla-put-vertcellmargin TblObj (* 0.75 h))
     (vla-put-horzcellmargin TblObj (* 0.75 h))
     (mapcar '(lambda (x)(vla-setTextHeight TblObj x h))
      (list acTitleRow acHeaderRow acDataRow) )
     (mapcar '(lambda (x)(vla-setAlignment TblObj x 8))
      (list acTitleRow acHeaderRow acDataRow))      
     (vla-MergeCells TblObj 0 0 0 4)
     (vla-setText TblObj 0 0 "Bang thong ke")
     (setq j -1 header_lsp (list "STT" "Ten" "Don vi" "So luong" "Ky hieu")) 
     (repeat (length header_lsp)
(vla-setText TblObj 1 (setq j (1+ j)) (nth j header_lsp)))
     (setq row 2 i 1)    
     (foreach pt lst_blk
(setq blk_name (car pt) j -1)
(mapcar '(lambda (x)(vla-setText TblObj row (setq j (1+ j)) x))
	(list i blk_name "cai" (cdr pt)))
(vla-SetBlockTableRecordId TblObj row 4 (GetObjectID (vla-item blks blk_name)) :vlax-true)
(vla-SetCellAlignment TblObj row 1 7)
(vla-SetCellAlignment TblObj row 3 9)
(setq row (1+ row) i (1+ i))	)
     (vla-put-regeneratetablesuppressed TblObj :vlax-false)
     (vlax-release-object TblObj) )  )
 (princ))

Hix , không biết làm gì hơn là cám ơn bác gia_bach . :rolleyes: . Hôm nào rủ bác đi nhậu vậy . :s_big: . Cám ơn bác nhiều .

Tháng 5 20, 2010

Bạn dùng thử lệnh LMAN của bộ EXPRESS chưa?

Bảng Excel xuất từ lệnh này cần chút ít time để lọc lại tên các Layers. Như thế cũng được rồi.

Nhờ các Bác thêm Lisp dưới đây để có thể viết ra danh sách các Layers trong 1 text file. Cám ơn nhiều.

;Generate a sorted list of layer names in the drawing.
;
;	The list is written to a
;	file named .LAY in the current directory.
;	The list can be viewed in AutoCAD by entering
;	!newlist at the command prompt.  A page by page
;	listing can be viewed by entering LLIST after the
;	lay_list routine has been run.
;
;
;	AUTHOR: HENRY C. FRANCIS
;		425 N. ASHE ST.
;		SOUTHERN PINES, NC 28387
;              
;		All rights reserved without prejudice.
;
;	Copyright:	4-28-96
;	Edited:		4-28-96
;
(defun c:Laylst ( / it itn lay_f lay_str)
   (progn
     (setq it (tblnext "layer" "T"))
     (setq itn (cdr(assoc 2 it)))
     (setq newlist (list itn))
     (while
       (setq it (tblnext "layer"))
       (progn
         (setq itn (cdr(assoc 2 it)))
         (setq newlist (append newlist(list itn)))
       );progn
     );while
     (setq newlist (acad_strlsort newlist))
     (setq lay_f (open (strcat(getvar"dwgname")".LAY") "w"))
     (foreach n newlist (write-line n lay_f))
     (close lay_f)
   );progn
);defun
(defun C:LLIST ( / )
 (foreach n newlist
   (princ (strcat "\n" n)))
 (princ)
);defun

Tháng 5 21, 2010

Nhờ các Bác thêm Lisp dưới đây để có thể viết ra danh sách các Layers trong 1 text file. Cám ơn nhiều.
.......................

Bạn chạy thử Lisp này :

Xuất tất cả tên các Layer có trong bản vẽ ra một file Text.

(defun c:L2F (/ fname tbl tbl_lst); Layer to File
;;  By : Gia Bach, gia_bach @  www.CadViet.com             ;;
 (setq tbl (tblnext "layer" 1))
 (while tbl
   (setq tbl_lst (cons (cdr (assoc 2 tbl)) tbl_lst)
  tbl (tblnext "layer"))    )
 (if (setq fName (getfiled "Ten file xuat Layer" (getvar "dwgprefix") "txt" 1))
   (progn
     (setq fName (open fName "a"))
     (write-line (strcat "Danh sach Layer trong file : " (getvar"dwgname"))fName)
     (foreach pt (vl-sort tbl_lst '<)
(write-line pt fName))
     (close fName)))
 (princ))

Tháng 5 21, 2010

Chào các bác!
hôm trước út có "nhặt" được trên diễn đàn lisp nhập khối lượng rất hay. Nhưng út thấy vẫn còn mật thời gian. Các bác xem chỉnh lại út với.

lisp thực hiện như sau:

Sau khi đánh lệnh lish hỏi số text trên 1 hàng (như trong bv của út thì nhập 28)

rồi sau đó chọn tấc cả các text.

kết quả là được 1 file ketqua.txt

File đính kèm (gồm có 1 lisp út đã sử dụng, 1 file cad ví dụ, 1 file kết quả sau khi chạy lisp)

http://www.cadviet.com/upfiles/2/nhap_khoi_luong.dwg

http://www.cadviet.com/upfiles/2/file_ket_...i_chay_lisp.txt

http://www.cadviet.com/upfiles/2/khoi_luong_kl.lsp

út có ý kiến này có vẽ dễ hơn mong các bác giúp đỡ nhé.

Thay vì mình chạy lisp như trên, mình có thể viết lisp thực hiện công việc sau: Xuất tấc cả các text được chọn ra file .txt, Theo thứ tự trong cad: từ trên xuống dưới và từ trái qua phải. Còn khi xuất qua file .txt thì theo thứ tự từ trái sang phải và từ trên xuống dưới. Nghĩa là sắp xếp hết hàng này đến hàng khác. Số text trong 1 hàng được mình tự chọn. Monng các bác giúp đỡ.

Cảm ơn cadviet thật nhiều!

Tháng 5 21, 2010

Bạn tham khảo đoạn code này

(defun C:TG( / n p1 p2 p3 p4 p listDD listDG)
 (defun dxf( name code)
(cdr (assoc code (entget name)))
 )
 (setq n (entsel "Chon doan thang cat"))
 (if n (progn
(setq n (car n))
(setq p1 (dxf n 10) p2 (dxf n 11) listDD nil listDG nil)
(if (setq ss (ssget "f" (list p1 p2) '((0 . "line")))) (progn
  (setq i 0)
  (while (< i (sslength ss))
	(setq n (ssname ss i))
	(setq p3 (dxf n 10) p4 (dxf n 11))
	(if (setq p (inters p1 p2 p3 p4)) (progn
	  (setq listDG (append listDG (list p)))
	  (if (< (car p3) (car p4)) 
		(setq listDD (append listDD (list p3)))
		(setq listDD (append listDD (list p4)))
	  )
	))
	(setq i (1+ i))
  )
))
 ))
;Ket qua listDD chua ds diem dau va listDG chua danh sach diem giao
)

chào bạn tôi có tải lisp của ban về dùng,nhưg không thấy có kết quả gì cả, không hiện ra gì cả, tôi dùng cad2010,mong bạn trả lơời giúp. "cũng có câu chọn đoạn thẳng cắt", nhưng khi chọn xong th nó hỉiện ra"chọn đoạn thẳng cắt 6", vì tôi vẽ 5 đương thẳng song song và 1 đường cắt các đường còn lại.

Tháng 5 21, 2010

chào bạn tôi có tải lisp của ban về dùng,nhưg không thấy có kết quả gì cả, không hiện ra gì cả, tôi dùng cad2010,mong bạn trả lơời giúp. "cũng có câu chọn đoạn thẳng cắt", nhưng khi chọn xong th nó hỉiện ra"chọn đoạn thẳng cắt 6", vì tôi vẽ 5 đương thẳng song song và 1 đường cắt các đường còn lại.

Chào bạn nguyen thanh cao,

Bạn thử thay thế đoạn code sau: listDD nil listDG nil bằng đoạn code này xem sao nhé: listDD (list) listDG (list)

Và nhớ rằng lisp này chỉ có giá trị với các đối tựng là LINE mà thôi. Nếu là các LWPOLYLINE hay POLYLINE thì mình không chắc chắn đâu nha.

Tháng 5 22, 2010

Bạn chạy thử Lisp này :

Xuất tất cả tên các Layer có trong bản vẽ ra một file Text.

(defun c:L2F (/ fname tbl tbl_lst); Layer to File
;;  By : Gia Bach, gia_bach @  www.CadViet.com             ;;
 (setq tbl (tblnext "layer" 1))
 (while tbl
   (setq tbl_lst (cons (cdr (assoc 2 tbl)) tbl_lst)
  tbl (tblnext "layer"))    )
 (if (setq fName (getfiled "Ten file xuat Layer" (getvar "dwgprefix") "txt" 1))
   (progn
     (setq fName (open fName "a"))
     (write-line (strcat "Danh sach Layer trong file : " (getvar"dwgname"))fName)
     (foreach pt (vl-sort tbl_lst '<)
(write-line pt fName))
     (close fName)))
 (princ))

Nhờ bác Gia_bach viết thêm Lisp trên để sau mổi tên Layer là các Status: On hoặc Off, Freeze hoặc Thaw và Lock hoặc Unlock.

Thí dụ như sau:

Layer1, ON, Thaw, Unlock

Layer20, OFF, Thaw, Unlock

...

Xref|C_ex-fence, ON, Thaw, Lock

Xref|C_future, ON, Freeze, Unlock

...vv

Kết quả là khi dùng Excel để đọc thì sẽ thấy được 4 cột.

Xin cám ơn nhiều.

Tháng 5 23, 2010

Nhờ bác Gia_bach viết thêm Lisp trên để sau mổi tên Layer là các Status: On hoặc Off, Freeze hoặc Thaw và Lock hoặc Unlock.
Thí dụ như sau:

Layer1, ON, Thaw, Unlock

Layer20, OFF, Thaw, Unlock

...

Xref|C_ex-fence, ON, Thaw, Lock

Xref|C_future, ON, Freeze, Unlock

...vv

Kết quả là khi dùng Excel để đọc thì sẽ thấy được 4 cột.

Xin cám ơn nhiều.

Vậy thì xuất lqua Excel luôn. Phiphi hãy thử code này :

(defun c:LS2F (/ fname tbl_lst); Layer and Status to File
;;  By : Tue_NV, tue_nvcc@yahoo.com
 (vl-load-com)
 (setq doc (vla-get-activedocument (vlax-get-acad-object))
La (vla-get-layers doc) i -1 tbl_lst '())
 (vlax-for ob La
   	(setq tbl_lst (append tbl_lst (list
		      (list (vla-get-name ob)
			    (status(vla-get-layeron ob))
			    (status(vla-get-freeze ob))
			    (status(vla-get-lock ob)) )) ))
 )
   (if (setq fName (getfiled "Ten file xuat Layer" (getvar "dwgprefix") "xls" 1))
   (progn
     (setq fName (open fName "a"))
     	(write-line (strcat "Danh sach Layer trong file : " (getvar"dwgname"))fName)
  	(write-line "Name\tLAYON\tFreeze\tLOCK" fname)
     (foreach pt (vl-sort tbl_lst '(lambda (x y) (	(write-line (strcat (nth 0 pt) "\t" (nth 1 pt) "\t"
		    (nth 2 pt) "\t" (nth 3 pt)) fName)
     )
     (close fName)))

 (princ)
 )
(defun status(a)
 (if (= a :vlax-true)
   (setq a "ON")
   (setq a "OFF")
 )
)

Tháng 5 23, 2010

út có ý kiến này có vẽ dễ hơn mong các bác giúp đỡ nhé.
Thay vì mình chạy lisp như trên, mình có thể viết lisp thực hiện công việc sau: Xuất tấc cả các text được chọn ra file .txt, Theo thứ tự trong cad: từ trên xuống dưới và từ trái qua phải. Còn khi xuất qua file .txt thì theo thứ tự từ trái sang phải và từ trên xuống dưới. Nghĩa là sắp xếp hết hàng này đến hàng khác. Số text trong 1 hàng được mình tự chọn. Monng các bác giúp đỡ.

Cảm ơn cadviet thật nhiều!

Bác Tuệ và Bác Hoành đâu rồi nhỉ! Giúp dùm út đi!

Tháng 5 23, 2010

út có ý kiến này có vẽ dễ hơn mong các bác giúp đỡ nhé.
Thay vì mình chạy lisp như trên, mình có thể viết lisp thực hiện công việc sau: Xuất tấc cả các text được chọn ra file .txt, Theo thứ tự trong cad: từ trên xuống dưới và từ trái qua phải. Còn khi xuất qua file .txt thì theo thứ tự từ trái sang phải và từ trên xuống dưới. Nghĩa là sắp xếp hết hàng này đến hàng khác. Số text trong 1 hàng được mình tự chọn. Monng các bác giúp đỡ.

Cảm ơn cadviet thật nhiều!

Vừa hay, mới vừa viết xong Code cho Út. Tuy nhiên, không hiểu sao Lisp chạy lần đầu tiên thì không có kết quả. Chạy lần thứ hai trở đi thì OK

Út hãy thử với Code này :

(defun c:xkl(/ doc ss Lptext Lpxtext Ltt sset st fname i team)
 (setq doc (vla-get-activedocument (vlax-get-acad-object))
st (getint "\n So Text tren 1 hang :"))
 (setq ss (ssget '((0 . "TEXT"))) Lptext '() Lpxtext '() Ltt '() i 0
sset (vla-get-activeselectionset doc))
 (vlax-for x sset
   (setq Lptext (cons (cons  (vlax-get x 'InsertionPoint)
			 (vlax-get x 'Textstring)
		) Lptext))
 )
 (setq Lptext (vl-sort Lptext '(lambda (x y) (> (cadar x) (cadar y)))))
 (Repeat (fix  (/ (length Lptext) st))
   	   (setq Ltt (removeL (* st i) (1- (* st (1+ i))) Lptext))
  (setq Lpxtext (append Lpxtext (list Ltt)))
  (setq i (1+ i))
   )
 (if (setq fName (getfiled "Chon file" (getvar "dwgprefix") "txt" 1))
   (progn
     (setq fName (open fName "a"))
     (foreach x Lpxtext
(setq team "")
(foreach y x
    (setq team (strcat team "  " (cdr y)))
)
(write-line team fName)
      )
     )
     (close fName))
 (vla-delete sset)	
 (princ)
 )
;;;;;;;;;;
(defun removeL(d c L)
(reverse
 (member (nth c L)
 	(reverse (member (nth d L) L))
 )
)
)

Bac Tue oi. giup minh ti
Hãy giúp mình viết lisp cho cái này nhé các ban. cảm ơn

http://www.cadviet.com/upfiles/2/rai_cot_cho_ho_ga_1.dwg

http://www.cadviet.com/upfiles/2/file_hoan...u_the_nay_1.dwg

mình cần rãi hố ga và điền cốt cho các vị trí hố ga với khoảng cách các hố ga đó

khi đã biết hố ga và cốt của hố ga này và cốt ga cuối

cac khoang cach hố ga nay thi tuỳ ý người dung nhập vào

Chào thanhliemvqh : file kết quả của bạn upload có vấn đề : không load về được.

Trước đây thanhliem có gửi 1 yêu cầu như yêu cầu này, Tue_NV thấy kết quả bạn nội suy, theo Tue_NV được biết thì nội suy tuyến tính (theo tam giác đồng dạng) nhưng sao kết quả mình tính sao không thấy giống????

-> Bạn thử minh hoạ 1 cái cốt hố ga mà bạn cần đánh (công thức tính) nội suy, kết quả xuất qua file .dwg 1 cách cụ thể nhé.

Chỉnh sửa Tháng 5 24, 2010 theo Tue_NV

Tháng 5 23, 2010

Xin hỏi các bác đây xem có ai biết đc cách nào để lọc các PL có Z=0 không, số là khi e làm HS, nhập cao độ cho đwờng đồng mức hay vấp phải lỗi là 1 số PL chưa nhập Z nhưng e cứ twởng nhập rồi mặc dù e rất cẩn thận. Thế nên khi tính khối lwợng, chwơng trình sẽ tự hiểu các PL chưa nhập Z là các PL có Z=0, khối lwợng sẽ bị tính sai, mong các bác giúp e : :rolleyes:

Tháng 5 23, 2010

Vậy thì xuất lqua Excel luôn. Phiphi hãy thử code này :

(defun c:LS2F (/ fname tbl_lst); Layer and Status to File
;;  By : Tue_NV, tue_nvcc@yahoo.com
 (vl-load-com)
 (setq doc (vla-get-activedocument (vlax-get-acad-object))
La (vla-get-layers doc) i -1 tbl_lst '())
 (vlax-for ob La
   	(setq tbl_lst (append tbl_lst (list
		      (list (vla-get-name ob)
			    (status(vla-get-layeron ob))
			    (status(vla-get-freeze ob))
			    (status(vla-get-lock ob)) )) ))
 )
   (if (setq fName (getfiled "Ten file xuat Layer" (getvar "dwgprefix") "xls" 1))
   (progn
     (setq fName (open fName "a"))
     	(write-line (strcat "Danh sach Layer trong file : " (getvar"dwgname"))fName)
  	(write-line "Name\tLAYON\tFreeze\tLOCK" fname)
     (foreach pt (vl-sort tbl_lst '(lambda (x y) (< (car x) (car y))))
(write-line (strcat (nth 0 pt) "\t" (nth 1 pt) "\t"
		    (nth 2 pt) "\t" (nth 3 pt)) fName)
     )
     (close fName)))

 (princ)
 )
(defun status(a)
 (if (= a :vlax-true)
   (setq a "ON")
   (setq a "OFF")
 )
)

Cám ơn bác Tue_NV nhưng đoạn code trên hình như còn thiếu đoạn cuối...nên chưa chạy được.

Nhớ Bác check lại nhé.

Command: ap

APPLOAD LS2F.lsp successfully loaded.

Command: ; error: bad argument type: numberp: nil

Command:

Đăng nhập

Viết lisp theo yêu cầu [phần 2]

Các bài được khuyến nghị

queen2k8 4

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

funnyzui 1

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

dacvien2007 10

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

18011985 62

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

Phiphi- 176

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

duy782006 1.549

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

khaosat2009 11

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

18011985 62

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

thanhliemvqh 0

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

quan_elec 0

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

gia_bach 1.550

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

ut_cung 2

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

khaosat2009 11

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

quan_elec 0

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

Phiphi- 176

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

gia_bach 1.550

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

ut_cung 2

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

nguyenthanhcao 10

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

phamthanhbinh 3.146

Chia sẻ bài đăng này

Liên kết tới bài đăng

Chia sẻ trên các trang web khác

Phiphi- 176