Nhờ sửa Lisp Copy Text Cad sang Excel

Tháng 10 9, 2014

Mình sưu tầm được lisp này trên mạng phục vụ việc Copy Text từ Cad sang Excel. Hiện tại cái này nó đang có thể copy theo thứ tự chọn sang 1 cột bên Excel. Nay mình muốn nhờ các bác trên diễn đàn sửa giúp mình cái lisp này làm sao có thể quét chọn hết cả vùng dữ liệu rồi sao chép sang 1 cột bên Excel như hình mình mô tả.

Lệnh như sau:

1. Gõ lệnh TTX

2. Quét chọn các Text cần copy

3. Enter kết thúc lệnh. Sẽ được 1 file Excel sinh ra có thứ tự Text như trong hình.

Nói chung, Lisp này dùng khá là ổn rồi. Chỉ cần sửa lại thứ tự Copy sang Excel thôi. Mong các bác giúp đỡ.

Xin chân thành cám ơn!

File Cad http://www.cadviet.com/upfiles/3/64997_ttx.dwg

File Lip http://www.cadviet.com/upfiles/3/64997_ttx_1.lsp

Tháng 10 15, 2014

hjx. ko có ai giúp mình ah @@

Tháng 10 15, 2014

File lsp ko down dc.

Tháng 10 16, 2014

Mình up lại thử vẫn lỗi như vậy. Mình up qua Dropbox, bạn vào down nhé:

https://dl.dropboxusercontent.com/u/75898261/TTX.lsp

Tháng 10 16, 2014

Mình up lại thử vẫn lỗi như vậy. Mình up qua Dropbox, bạn vào down nhé:

https://dl.dropboxusercontent.com/u/75898261/TTX.lsp

Hề hề hề,

Bạn thử dùng cái ni coi sao nhé.

http://www.mediafire.com/download/w9zgqk2wggn9o8w/text2excel-1.lsp

(defun c:ttx (/ ss xlApp xlCells row col i)

(vl-load-com)

(setq ss1 (ssget '((0 . "*TEXT"))))

(setq ssl (acet-ss-to-list ss1)

ssl (vl-sort ssl '(lambda (x y) (< (atof (cdr (assoc 1 (entget x)))) (atof (cdr (assoc 1 (entget y)))) ))) )

(setq ss (acet-list-to-ss ssl))

(if ss

(progn

(setq xlApp (vlax-get-or-create-object "Excel.Application")

xlCells (vlax-get-property

(vlax-get-property

(vlax-invoke-method

(vlax-get-property xlApp "Workbooks")

"Add") "Sheets") "Item" 1) "Cells") row 0 col 1)

(vla-put-visible xlApp :vlax-true)

(foreach y

(mapcar '(lambda (x / iPt)

(setq iPt (vlax-get x 'InsertionPoint))

(list (vla-get-TextString x)

(rtos (car iPt) 2 2)

(rtos (cadr iPt) 2 2)

(rtos (caddr iPt) 2 2)))

(mapcar 'vlax-ename->vla-object

(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))

(if (> row 65536) (setq col 5))

(setq i -1 row (1+ row))

(mapcar

(function

(lambda (x)

(vlax-put-property xlCells "Item" row

(+ col (setq i (1+ i))) x))) y))))

(mapcar 'vlax-release-object (list xlApp xlCells))

(princ))

Tháng 10 17, 2014

Còn cái này là sửa lại cái lsp bạn post.

http://www.cadviet.com/upfiles/3/127168_ttx.rar

Tháng 10 17, 2014

Còn cái này là sửa lại cái lsp bạn post.

http://www.cadviet.com/upfiles/3/127168_ttx.rar

Hề hề hề,

Bác Tot77 phân loại đối tượng theo điểm đặt của nó phải không ạ?? Điều này có hơi khác với mình suy nghĩ là vì mình phân loại theo giá trị của đối tượng.

Trong trường hợp cụ thể này thì hai cách phân loại này đều có chung kết quả. Tuy nhiên với các trường hợp khác thì kết quả sẽ không giống nhau.

Không hiểu ý chủ thớt ra sao nhể???

Tháng 10 17, 2014

TÔi theo cái hình ở #1, vị trí từ trái qua và từ dưới lên (theo chiều mũi tên)

Những giá trị trong hình chỉ là ví dụ thôi (tôi nghĩ thế).

Tháng 10 17, 2014

TÔi theo cái hình ở #1, vị trí từ trái qua và từ dưới lên (theo chiều mũi tên)

Những giá trị trong hình chỉ là ví dụ thôi (tôi nghĩ thế).

Hề hề hề,

Chắc là bác đúng. Mình căn cứ vào cái kết quả trên exel nên chọn cách phân loại như vầy.

Vấn đề cơ bản ở đây chỉ là việc sắp xếp lại tập chọn theo một trật tự nào đó mà thôi.Nếu chủ thớt nói rõ hơn về cái trật tự này thì sẽ tốt hơn là để người làm lisp phải tự nghĩ .......

Tháng 10 17, 2014

Bác Tot77 sửa Lisp đúng ý mình rồi. Còn bác phamthanhbinh cũng có cách xuất theo giá trị từ nhỏ đến lớn cũng khá hay, mình sẽ lưu lại cả. Cám ơn các bác nhiều lắm.

Mình còn 1 bài toán nữa ko biết có làm khó các bác hơn chút nào ko? Nhưng mình hay phải copy tới cả nghìn text như thế này sang Excel, rồi rà soát lại rất mệt nên rất thủ công.

Bài toán như sau: Có các text như trong hình.

1. Gõ lệnh TTX1

2. Quét chọn cả 4 text số lần lượt trong các ô từ (Ô – 1) đến (Ô – 8). Chú ý cứ quét chọn cả 4 text 1 lần, do đó như trong hình ta cần quét 8 lần.

3. File Excel xuất ra có kết quả theo thứ tự của mũi tên như trong hình mô tả.

Kết thúc lệnh. Rất mong có được sự giúp đỡ của diễn đàn.

Xin chân thành cám ơn sự giúp đỡ của các bác :)

File Cad: http://www.cadviet.com/upfiles/3/64997_txt_new.dwg

Tháng 10 18, 2014

Cái này cũng gần giống cái trên.

(defun c:tty  (/ ss ss1 y xlApp xlCells row col i iPt)
  (vl-load-com)
  (setq xlApp   (vlax-get-or-create-object "Excel.Application")
            xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                          (vlax-invoke-method
                            (vlax-get-property xlApp "Workbooks")
                            "Add") "Sheets") "Item" 1) "Cells") row 0 col 1)
  (vla-put-visible xlApp :vlax-true)
  
  (while (setq ss (ssget '((0 . "*TEXT"))))      
      (setq ss (mapcar '(lambda (x) (list (vlax-get (vlax-ename->vla-object x) 'InsertionPoint)
 (vlax-ename->vla-object x))) 
      (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))    
      (while ss
(setq  ss (vl-sort ss '(lambda (x y) (> (cadr (car x)) (cadr (car y)))))
      ss1 (vl-remove-if-not '(lambda (x) (equal (cadr (caar ss)) (cadr (car x)) 0.2)) ss)
      ss1 (vl-sort ss1 '(lambda (x y) (< (caar x) (caar y))))
      ss (vl-remove-if '(lambda (x) (member x ss1)) ss)
)
(foreach z ss1
          (setq iPt (car z)
y (list (vla-get-TextString (last z))  (rtos (car iPt) 2 2)  (rtos (cadr iPt) 2 2) (rtos (caddr iPt) 2 2))
 ) 
          (if (> row 65536) (setq col 5))
          (setq i -1 row (1+ row))
          (mapcar '(lambda (x) (vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) x)) y)
)
      )
    )
  (mapcar 'vlax-release-object (list xlApp xlCells))
  (princ)
)

Tháng 10 19, 2014

Cảm ơn Bác Tot 77. Lisp này của bác dùng rất tốt rồi. Nhưng bác có thể chỉnh giúp mình lsao để mình có thể chọn hết xong rồi mới ấn enter dc ko? Chứ lisp này là cứ mỗi lần chọn lại enter 1 lần thì hơi chậm 1 tý ^^

Cái này cũng gần giống cái trên.

(defun c:tty  (/ ss ss1 y xlApp xlCells row col i iPt)
  (vl-load-com)
  (setq xlApp   (vlax-get-or-create-object "Excel.Application")
            xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                          (vlax-invoke-method
                            (vlax-get-property xlApp "Workbooks")
                            "Add") "Sheets") "Item" 1) "Cells") row 0 col 1)
  (vla-put-visible xlApp :vlax-true)
  
  (while (setq ss (ssget '((0 . "*TEXT"))))      
      (setq ss (mapcar '(lambda (x) (list (vlax-get (vlax-ename->vla-object x) 'InsertionPoint)
 (vlax-ename->vla-object x))) 
      (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))    
      (while ss
(setq  ss (vl-sort ss '(lambda (x y) (> (cadr (car x)) (cadr (car y)))))
      ss1 (vl-remove-if-not '(lambda (x) (equal (cadr (caar ss)) (cadr (car x)) 0.2)) ss)
      ss1 (vl-sort ss1 '(lambda (x y) (< (caar x) (caar y))))
      ss (vl-remove-if '(lambda (x) (member x ss1)) ss)
)
(foreach z ss1
          (setq iPt (car z)
y (list (vla-get-TextString (last z))  (rtos (car iPt) 2 2)  (rtos (cadr iPt) 2 2) (rtos (caddr iPt) 2 2))
 ) 
          (if (> row 65536) (setq col 5))
          (setq i -1 row (1+ row))
          (mapcar '(lambda (x) (vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) x)) y)
)
      )
    )
  (mapcar 'vlax-release-object (list xlApp xlCells))
  (princ)
)

Tháng 10 20, 2014

Thì bạn yêu cầu quét 8 lần, quét mấy lần thì enter mấy lần. Hay bạn muốn quét luôn 32 text rồi làm 1 lúc, xem như quét 1 lần?

Tháng 10 21, 2014

Nếu bản vẽ thật của bạn mỗi nhóm 4 chữ đều có cái khung bao pline như bản vẽ mẫu thì có thể sửa lsp để nhấp vào khung đó, nó sẽ đưa ra excel thay vì quét chữ và enter.

Tháng 10 21, 2014

Cho mình tham gia tí,

có giải pháp nảo xuất các số gần đỉnh của từng ô sang écel không bạn

o-1 1.56 2.56 3.25

o-2 4.56 2.56 3.25

khị chọn các ô thuộc pline, lấy tên ô, xac định các số ở đỉnh xuất ra eccxel

http://www.cadviet.com/upfiles/3/114381_sn_excel.dwg

Tháng 10 21, 2014

Cho mình tham gia tí,

có giải pháp nảo xuất các số gần đỉnh của từng ô sang écel không bạn

o-1 1.56 2.56 3.25

o-2 4.56 2.56 3.25

khị chọn các ô thuộc pline, lấy tên ô, xac định các số ở đỉnh xuất ra eccxel

http://www.cadviet.com/upfiles/3/114381_sn_excel.dwg

Được, với đk các số đúng là gần đỉnh, chứ như bản vẽ bạn đưa thì số 1.60 và 12.40 không biết là gần cái đỉnh nào.

Đk thứ 2 là text cùng 1 loại canh lề.

Tháng 10 21, 2014

Ô hay, vậy thì có giải pháp rồi.

về nguyên tắc mình muốn tìm các số gần đỉnh của các đa giác ( nằm trong ngoài tùy ý ) của ô đó xuất ra hàng ngang theo tên ô, có thể các ô có cùng số tại điểm tiếp giáp.

xuất ra: o-1 102 3.2 150 2.66 250 ( và diện tích ô đó )

http://www.cadviet.com/upfiles/3/114381_sn_excel_1.dwg

Tháng 10 21, 2014

Bạn dùng cái này thử xem.

Chọn 1 khung pline rồi chọn cái tên khung (ô-..), chọn tới đâu xuất excel tới đó.

Phần diện tích k biết lấy đơn vị là gì.

(defun c:tta (/ ss ss1 y xlApp xlCells row col i iPt)
  (vl-load-com)      
  (setq xlApp   (vlax-get-or-create-object "Excel.Application")
            xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                          (vlax-invoke-method
                            (vlax-get-property xlApp "Workbooks")
                            "Add") "Sheets") "Item" 1) "Cells") row 0 col 1)
  (vla-put-visible xlApp :vlax-true)
 
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X" '((0 . "TEXT"))))))
sst (vl-remove-if-not '(lambda (x) (distof (vla-get-TextString (vlax-ename->vla-object x)))) ss)
sst (mapcar '(lambda (x) (list (vlax-get (vlax-ename->vla-object x) 'TextAlignmentPoint)
 (vla-get-TextString (vlax-ename->vla-object x)))) sst)
  )
  (prompt "\nChon khung pline:")
  (while (setq pl (ssget ":E:S" '((0 . "LWPOLYLINE"))))
    (mapcar '(lambda (x) (redraw x 4)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X")))))
    (setq pl (ssname pl 0)) (redraw pl 3)
    (setq oo (car (entsel "\nChon ten cua khung:")))  (redraw pl 4) (redraw oo 3)
    
    (setq  ssd (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= 10 (car x))) (entget pl))) 
 lst (list (vla-get-TextString (vlax-ename->vla-object oo)))
    )
    (foreach pt ssd
      (setq txt (car (vl-sort sst '(lambda (x y) (< (distance (car x) pt) (distance (car y) pt)))))
   lst (append lst (list (last txt))) 
      )
    )
    (setq lst (append lst (list (vla-get-Area (vlax-ename->vla-object pl))))
 i -1 row (1+ row))
    (mapcar '(lambda (x) (vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) x)) lst)
    (prompt "\nChon khung pline:")
  )
  (mapcar 'vlax-release-object (list xlApp xlCells))
  (mapcar '(lambda (x) (redraw x 4)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X")))))
  (redraw)
  (princ)
)

Tháng 10 21, 2014

À cái này hay quá. Cám ơn Bạn đã nhiệt tình giúp. diện tích lấy theo đơn vị m đi bạn. Số diện tich bạn giúp xuất ra ở cột số 9 trên eccxel giúp mình, nếu các số đỉnh không đủ thì kệ nó.

Có giải pháp nào mình chọn một lần hết các ô không bạn ?? Liisp Nhận biết đa giác đó, Xuất tên ô trong khung và số từng đỉnh ra hàng sang ecxel.

Mong bạn giúp

Tháng 10 21, 2014

Lisp #11 này rất ok rồi. Nhờ các bác sửa giúp mình thêm tính năng chia các giá trị text theo các layer khác nhau ra các cột khác nhau và vẫn theo thứ tự như vậy.

Như trong file cad mình gửi thì có 3 layer. Mình vẫn thao tác như cũ, nhưng text thuộc layer nào thì xuất kqua ra cùng lúc 3 cột khác nhau cho 3 layer. Cách xuất thì vẫn y như lisp TTY vậy.

Nếu bác làm dc vậy thì bác làm giúp mình cả với trường hợp lisp TTX trên tại #6 kia nữa với nha. Thanks bác nhiều ạ ^^

http://www.cadviet.com/upfiles/3/64997_tty_new.dwg

Cái này cũng gần giống cái trên.

(defun c:tty  (/ ss ss1 y xlApp xlCells row col i iPt)
  (vl-load-com)
  (setq xlApp   (vlax-get-or-create-object "Excel.Application")
            xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                          (vlax-invoke-method
                            (vlax-get-property xlApp "Workbooks")
                            "Add") "Sheets") "Item" 1) "Cells") row 0 col 1)
  (vla-put-visible xlApp :vlax-true)
  
  (while (setq ss (ssget '((0 . "*TEXT"))))      
      (setq ss (mapcar '(lambda (x) (list (vlax-get (vlax-ename->vla-object x) 'InsertionPoint)
 (vlax-ename->vla-object x))) 
      (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))    
      (while ss
(setq  ss (vl-sort ss '(lambda (x y) (> (cadr (car x)) (cadr (car y)))))
      ss1 (vl-remove-if-not '(lambda (x) (equal (cadr (caar ss)) (cadr (car x)) 0.2)) ss)
      ss1 (vl-sort ss1 '(lambda (x y) (< (caar x) (caar y))))
      ss (vl-remove-if '(lambda (x) (member x ss1)) ss)
)
(foreach z ss1
          (setq iPt (car z)
y (list (vla-get-TextString (last z))  (rtos (car iPt) 2 2)  (rtos (cadr iPt) 2 2) (rtos (caddr iPt) 2 2))
 ) 
          (if (> row 65536) (setq col 5))
          (setq i -1 row (1+ row))
          (mapcar '(lambda (x) (vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) x)) y)
)
      )
    )
  (mapcar 'vlax-release-object (list xlApp xlCells))
  (princ)
)

Tháng 10 23, 2014

Bạn dùng cái này. Lúc chạy lần đầu nó có hỏi chọn layer, bạn pick 3 cái text để lấy 3 layer.

(vl-load-com)
(defun batdau ()
  (defun dxf (id v) (cdr (assoc id (entget v))))
  (setq xlApp   (vlax-get-or-create-object "Excel.Application")
            xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                          (vlax-invoke-method
                            (vlax-get-property xlApp "Workbooks")
                            "Add") "Sheets") "Item" 1) "Cells"))
   (vla-put-visible xlApp :vlax-true)
  
   (if (not tlayer1)
    (progn (alert "Hay chon Layer")
      (setq tlayer1 (dxf 8 (car (entsel "\nChon text thuoc layer 1:")))
 tlayer2 (dxf 8 (car (entsel "\nChon text thuoc layer 2:")))
 tlayer3 (dxf 8 (car (entsel "\nChon text thuoc layer 3:")))))
  )
  (setq row1 0 row2 0 row3 0)
  (setq col1 1 col2 5 col3 9)
)
 
(defun ghi (tlayer row col dau / ss1 ss0 y i iPt)
    (setq ss1 (vl-remove-if-not '(lambda (x) (= (dxf 8 x) tlayer)) ss)
 ss1 (mapcar '(lambda (x) (list (vlax-get (vlax-ename->vla-object x) 'InsertionPoint)
 (vlax-ename->vla-object x))) ss1)
 cao (vla-get-Height (last (car ss1))))
    (while ss1
(setq  ss1 (vl-sort ss1 '(lambda (x y) (dau (cadr (car x)) (cadr (car y)))))
      ss0 (vl-remove-if-not '(lambda (x) (equal (cadr (caar ss1)) (cadr (car x)) cao)) ss1)
      ss0 (vl-sort ss0 '(lambda (x y) (< (caar x) (caar y))))
      ss1 (vl-remove-if '(lambda (x) (member x ss0)) ss1)
)
(foreach z ss0
          (setq iPt (car z)
y (list (vla-get-TextString (last z))  (rtos (car iPt) 2 2)  (rtos (cadr iPt) 2 2) (rtos (caddr iPt) 2 2))
 ) 
          (setq i -1 row (1+ row))
          (mapcar '(lambda (x) (vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) x)) y)
)
      )
  row
)
 
(defun c:ttx  (/ ss ss1 y xlApp xlCells row col i iPt)
  (batdau) (prompt "\nChon text")
  (if (setq ss (ssget '((0 . "*TEXT"))))
    (progn
      (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
      (setq row1 (ghi tlayer1 row1 col1 <))
      (setq row2 (ghi tlayer2 row2 col2 <))
      (setq row3 (ghi tlayer3 row3 col3 <))      
    )
  )
  (mapcar 'vlax-release-object (list xlApp xlCells))
  (princ)
)
 
(defun c:tty (/ ss xlApp xlCells row1 row2 row3)
  (batdau) (prompt "\nChon text")
  (while (setq ss (ssget '((0 . "TEXT"))))
    (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
    (setq row1 (ghi tlayer1 row1 col1 >))
    (setq row2 (ghi tlayer2 row2 col2 >))
    (setq row3 (ghi tlayer3 row3 col3 >))
  )
  (mapcar 'vlax-release-object (list xlApp xlCells))  
  (princ)
)

@tientracdia : cái này chỉ đỡ hơn ở chỗ không cần chọn text mà chỉ cần chọn khung pline, nhưng không quét và sắp xếp theo thứ tự mà bạn phải pick từng cái thôi, thứ tự do bạn chọn.

(defun c:tta (/ ss sst ssc ssd pl oo txt xlApp xlCells row col i lst area)
  (vl-load-com)
  (defun inside(pt l)
    (defun tgoc(a b c) (abs (- pi (abs (- (angle b c) (angle a b))))))
    (equal 6.28319 (apply '+ (mapcar '(lambda(x y) (tgoc x pt y)) l (append (cdr l) (list (car l))))) 0.001)
  )
  (setq xlApp   (vlax-get-or-create-object "Excel.Application")
            xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                          (vlax-invoke-method
                            (vlax-get-property xlApp "Workbooks")
                            "Add") "Sheets") "Item" 1) "Cells") row 0 col 1)
  (vla-put-visible xlApp :vlax-true)
 
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X" '((0 . "TEXT"))))))
sst (vl-remove-if-not '(lambda (x) (distof (vla-get-TextString (vlax-ename->vla-object x)))) ss)
ssc (vl-remove-if '(lambda (x) (member x sst)) ss)
sst (mapcar '(lambda (x) (list (vlax-get (vlax-ename->vla-object x) 'TextAlignmentPoint)
 (vla-get-TextString (vlax-ename->vla-object x)))) sst) 
  )
  (prompt "\nChon khung pline:")
  (while (setq pl (ssget ":E:S" '((0 . "LWPOLYLINE"))))
    (setq pl (ssname pl 0)) (redraw pl 3)    
    (setq ssd (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= 10 (car x))) (entget pl)))
 oo (vl-remove-if-not '(lambda (x) (inside (vlax-get (vlax-ename->vla-object x) 'TextAlignmentPoint) ssd)) ssc))
    (if oo
      (progn 
(setq oo (car oo)
     ssc (vl-remove oo ssc)
     lst (list (vla-get-TextString (vlax-ename->vla-object oo))))
        (foreach pt ssd
          (setq txt (car (vl-sort sst '(lambda (x y) (< (distance (car x) pt) (distance (car y) pt)))))
       lst (append lst (list (last txt))) 
          )
        )
        (setq area (rtos (* 0.000001 (vla-get-Area (vlax-ename->vla-object pl))) 2 2)
     i -1 row (1+ row))
        (mapcar '(lambda (x) (vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) x)) lst)
        (vlax-put-property xlCells "Item" row 9 area)
       )
    )
    (prompt "\nChon khung pline:")
  )
  (mapcar 'vlax-release-object (list xlApp xlCells))
  (mapcar '(lambda (x) (redraw x 4)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X")))))
  (redraw)
  (princ)
)

Tháng 10 23, 2014

Mình chạy lisp ttx tty với 3 layer thì ok. Nhưng thử thay đổi sang 2 layer, ko chọn layer thứ 3 thì lỗi vì lisp buộc phải chọn 3 text thuộc 3 layer khác nhau. Còn nếu có 4 hoặc nhiều layer hơn thì chưa có tùy chọn. Bác có thể sửa lisp sao cho có thể có tùy chọn số lượng layer được không (có thể lên tới 10 layer hoặc hơn nữa…). Cám ơn bác !

Tháng 10 23, 2014

Rất hay, xin cám ơn Bạn

Mình có ý muốn bạn giúp thêm, vì số lượng lớn, sau khi làm xong đợt 1 , muốn làm tiếp đợi 2, mình muốn ghi nối tiếp và file trước chứ không mổi lần mở book mới.

Mong bạn giúp thêm

Tháng 10 23, 2014

Cái này cũng gần giống cái trên.

(defun c:tty  (/ ss ss1 y xlApp xlCells row col i iPt)
  (vl-load-com)
  (setq xlApp   (vlax-get-or-create-object "Excel.Application")
            xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                          (vlax-invoke-method
                            (vlax-get-property xlApp "Workbooks")
                            "Add") "Sheets") "Item" 1) "Cells") row 0 col 1)
  (vla-put-visible xlApp :vlax-true)
  
  (while (setq ss (ssget '((0 . "*TEXT"))))      
      (setq ss (mapcar '(lambda (x) (list (vlax-get (vlax-ename->vla-object x) 'InsertionPoint)
 (vlax-ename->vla-object x))) 
      (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))))    
      (while ss
(setq  ss (vl-sort ss '(lambda (x y) (> (cadr (car x)) (cadr (car y)))))
      ss1 (vl-remove-if-not '(lambda (x) (equal (cadr (caar ss)) (cadr (car x)) 0.2)) ss)
      ss1 (vl-sort ss1 '(lambda (x y) (< (caar x) (caar y))))
      ss (vl-remove-if '(lambda (x) (member x ss1)) ss)
)
(foreach z ss1
          (setq iPt (car z)
y (list (vla-get-TextString (last z))  (rtos (car iPt) 2 2)  (rtos (cadr iPt) 2 2) (rtos (caddr iPt) 2 2))
 ) 
          (if (> row 65536) (setq col 5))
          (setq i -1 row (1+ row))
          (mapcar '(lambda (x) (vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) x)) y)
)
      )
    )
  (mapcar 'vlax-release-object (list xlApp xlCells))
  (princ)
)

Bạn Tot có thể chỉnh lại cho mình xuất theo hàng không và cột được không (Bên cad thế nào xuất qua excel thế nấy, muốn xuất bảng khối lượng trong cad qua excel)

Tháng 10 23, 2014

@huunhan : bạn thử cái này http://www.cadviet.com/forum/topic/99171-xuat-cad-sang-excel/

@tien: cứ để file excel mở song song với file cad, chừng nào không nhập nữa thì hãy save và tắt excel.

(defun c:tta (/ ss sst ssc ssd pl oo txt i lst area *error*)
  (vl-load-com)
  (defun inside(pt l)
    (defun tgoc(a b c) (abs (- pi (abs (- (angle b c) (angle a b))))))
    (equal 6.28319 (apply '+ (mapcar '(lambda(x y) (tgoc x pt y)) l (append (cdr l) (list (car l))))) 0.001)
  )
 
  (if (not xlApp)    
    (setq xlApp   (vlax-get-or-create-object "Excel.Application")
          xlCells (vlax-get-property
                      (vlax-get-property
                        (vlax-get-property
                          (vlax-invoke-method
                            (vlax-get-property xlApp "Workbooks")
                            "Add") "Sheets") "Item" 1) "Cells")
row 0 col 1
         xtmp (vla-put-visible xlApp :vlax-true)
    )
  )
 
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X" '((0 . "TEXT"))))))
sst (vl-remove-if-not '(lambda (x) (distof (vla-get-TextString (vlax-ename->vla-object x)))) ss)
ssc (vl-remove-if '(lambda (x) (member x sst)) ss)
sst (mapcar '(lambda (x) (list (vlax-get (vlax-ename->vla-object x) 'TextAlignmentPoint)
 (vla-get-TextString (vlax-ename->vla-object x)))) sst) 
  )
  (prompt "\nChon khung pline:")
  (while (setq pl (ssget ":E:S" '((0 . "LWPOLYLINE"))))
    (setq pl (ssname pl 0)) (redraw pl 3)    
    (setq ssd (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= 10 (car x))) (entget pl)))
 oo (vl-remove-if-not '(lambda (x) (inside (vlax-get (vlax-ename->vla-object x) 'TextAlignmentPoint) ssd)) ssc))
    (if oo
      (progn 
(setq oo (car oo)
     ssc (vl-remove oo ssc)
     lst (list (vla-get-TextString (vlax-ename->vla-object oo))))
        (foreach pt ssd
          (setq txt (car (vl-sort sst '(lambda (x y) (< (distance (car x) pt) (distance (car y) pt)))))
       lst (append lst (list (last txt))) 
          )
        )
        (setq area (rtos (* 0.000001 (vla-get-Area (vlax-ename->vla-object pl))) 2 2)
     i -1 row (1+ row))
        (mapcar '(lambda (x) (vlax-put-property xlCells "Item" row  (+ col (setq i (1+ i))) x)) lst)
        (vlax-put-property xlCells "Item" row 9 area)
       )
    )
    (prompt "\nChon khung pline:")
  )  
  (mapcar '(lambda (x) (redraw x 4)) (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget "X")))))
  (redraw)
  (princ)
)

@huaductiep: để lúc nào rảnh tôi sửa theo yêu cầu cuả bạn, lúc này hơi bị "ngán" cái đề tài này.

Đăng nhập

Nhờ sửa Lisp Copy Text Cad sang Excel

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

huaductiep 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

huaductiep 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

Tot77 508

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

huaductiep 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

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

Tot77 508

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

Tot77 508

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

huaductiep 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

Tot77 508

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

huaductiep 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

Tot77 508

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

Tot77 508

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

tientracdia 16

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

Tot77 508

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

tientracdia 16

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

Tot77 508

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

tientracdia 16

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

huaductiep 2