Đến nội dung


Hình ảnh
- - - - -

Nhờ sửa Lisp Copy Text Cad sang Excel


  • Please log in to reply
26 replies to this topic

#21 Tot77

Tot77

    biết lệnh adcenter

  • Members
  • PipPipPipPipPipPipPip
  • 990 Bài viết
Điểm đánh giá: 498 (tốt)

Đã gửi 23 October 2014 - 10:02 AM

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

  • 2

#22 huaductiep

huaductiep

    biết vẽ rectang

  • Members
  • PipPip
  • 85 Bài viết
Điểm đánh giá: 2 (bình thường)

Đã gửi 23 October 2014 - 02:49 PM

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 !


  • 0

#23 tientracdia

tientracdia

    biết lệnh scale

  • Members
  • PipPipPip
  • 147 Bài viết
Điểm đánh giá: -11 (hơi kém)

Đã gửi 23 October 2014 - 04:53 PM

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


  • 0

#24 huunhantvxdts

huunhantvxdts

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 366 Bài viết
Điểm đánh giá: 53 (tàm tạm)

Đã gửi 23 October 2014 - 05:33 PM

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)


  • 0

#25 Tot77

Tot77

    biết lệnh adcenter

  • Members
  • PipPipPipPipPipPipPip
  • 990 Bài viết
Điểm đánh giá: 498 (tốt)

Đã gửi 23 October 2014 - 08:01 PM

@huunhan : bạn thử cái này http://www.cadviet.c...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.


  • 2

#26 huunhantvxdts

huunhantvxdts

    biết dimbaseline

  • Members
  • PipPipPipPipPip
  • 366 Bài viết
Điểm đánh giá: 53 (tàm tạm)

Đã gửi 23 October 2014 - 08:13 PM

@huunhan : bạn thử cái này http://www.cadviet.c...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.

 Cám ơn Ban Tot nhiều


  • 0

#27 buithengan1

buithengan1

    biết vẽ line

  • Members
  • PipPip
  • 22 Bài viết
Điểm đánh giá: -1 (bình thường)

Đã gửi 06 November 2014 - 04:16 PM

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

ban tot77 oi cái  lisp của bạn chỉ sử dụng được với text nằm ngang thôi còn với các text  khác 0 độ thì ko được bạn có thể sửa lại hộ mình được không cảm ơn bạn.


  • 0