Chuyển đến nội dung
Diễn đàn CADViet
  • Thông báo

    • Nguyen Hoanh

      CADViet đã hoàn tất nâng cấp   14/09/2017

      Chào các bạn, CADViet đã hoàn tất việc nâng cấp lên phiên bản mới. Tất cả các chức năng đã hoạt động theo kỳ vọng của ban quản trị. Nếu có vấn đề gì cần phản hồi, các bản post ở đây nhé: Trân trọng, Nguyễn Hoành.
thanhnv

Xin lisp xuất bảng tổng hợp khối lượng sang excel

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

Snowman    90

Xin giới thiệu với các bác đoạn lisp mà em mày mò mãi (với VBA thì vấn đề có vẻ đơn giản (các bác cao thủ nói vậy chứ em chưa thực hành VBA nhiều lắm) nhưng để làm "thuần lisp" thì phải ...tốn công fu hơn :leluoi:

Lệnh e2x: chọn các text sắp xếp theo dạng bảng (ko cần căn thẳng hàng cột)

Kết quả: file xuất ra dưới dạng "giả excel" (Lisp chỉ làm được đến thế này thôi, bạn fải thêm một công ...open & save as --> Thành excel xịn ngay)

(defun myerror (s)
 (cond
   ((= s "quit / exit abort") (princ))
   ((/= s "Function cancelled") (princ (strcat "\nError: " s)))
 )
 (setvar "cmdecho" CMD)		; Restore saved modes
 (setvar "osmode" OSM)
 (setq *error* OLDERR)			; Restore old *error* handler
 (princ)
)

;;;=========================================================================
(defun bocchu (ss1 c)
 (setq ob (entget (ssname ss1 c)))
 (setq ts (assoc 1 ob))
 (setq a (cdr ts))
)

(defun boc1chu (ob)
 (if (/= ob nil)
   (progn
     (setq ts (assoc 1 ob))
     (setq a (cdr ts))
   )
 )
)


(defun Txtnum (num)
 (if (> num 0)
   (strcat "+" (rtos num 2 0))
   (rtos num 2 0)
 )
)
;;;=================================
(defun Txtint (num)
 (rtos num 2 0)

)

(defun Txtreal (num) (rtos num 2 2))
(defun Txtreal1 (num) (rtos num 2 0))

(defun thaychu (Ob newstr / obtmp)
 (setq txtstr (assoc 1 Ob))
 (setq newstr (cons 1 newstr)
obtmp (entmod (subst newstr txtstr Ob))
)
 (entupd (cdr (assoc -1 obtmp)))
)
(defun chonchu (dongnhac)
 (prompt dongnhac)
 (ssget
   '((-4 . "<OR") (0 . "text") (0 . "mtext") (0 . "ATTRIB") (-4 . "OR>"))
 )
)

(defun chon1chu	(dongnhac / obj objtype)
 (if (setq obj (nentsel dongnhac))
   (setq obj (entget (car obj))
  objtype (cdr (assoc 0 obj))
  )
   )
 (if (member objtype '("ATTRIB" "MTEXT" "TEXT"))
   (setq obj obj)
   )
)


(defun chon (str) (ssget '((cons (0 str)))))
(defun bamchon (st) (entget (car (entsel st))))
(defun bocdt (ss1 c) (entget (ssname ss1 c)))


;;;====================================================================
;;; Ham kiem tra xem mot so co nam trong day so ko voi sai so cho san
(defun memberp (num listn tsaiso / cter ni ntest test)
 (setq	cter 0
test nil
 )
 (while (< cter (length listn))
   (setq ntest	 (nth cter listn)
  sstest (abs (- num ntest))
   )
   (if	(<= sstest tsaiso)
     (setq cter (length listn)
    test T
     )
     (setq cter (1+ cter))
   )
 )
 (if test
   (setq ntest ntest)
   (setq ntest nil)
 )
 (setq ntest ntest)
)

;;;=======================================================================
;;;;=============================================================
;;; Chep du lieu bang ra file xls (du lieu lon xon khong thang hang cot)
(defun C:e2x (/ Txtline txtfile nrow ncol Filedir count count1 Cpright)
 (setvar "cmdecho" 0)
 (setq OldLay (getvar "Clayer"))

 (Setq	Cpright
 "Copyright by NguyÔn Gia §¹t <Datnggia@gmail.com - 0915169886>"
 )
 (setq	sstab	(chonchu "\nChon bang du lieu ...")
sstmp	sstab
cter	0
nn	(sslength sstmp)
tabdata	'()
htext	0
 )

;;; loc ra bang du lieu
 (while (< cter nn)
   (setq objtxt  (entget (ssname sstmp cter))
  content (cdr (assoc 1 objtxt))
  htext	  (+ htext (cdr (assoc 40 objtxt)))
  objtype (cdr (assoc 0 objtxt))
   )
   (if	(= objtype "TEXT")
     (progn
(setq just (cdr (assoc 72 objtxt))
)
(if (= just 0)
  (setq idtxt (cdr (assoc 10 objtxt)))
  (setq idtxt (cdr (assoc 11 objtxt)))
)
     )
     (setq idtxt (cdr (assoc 10 objtxt)))
   )
   (setq
     objdata (list content idtxt)
     tabdata (append tabdata (list objdata))
     cter    (1+ cter)
   )
 )

;;; Tim so hang , so cot cua bang du lieu

 (setq	cter  0
saiso (* 5 (/ htext nn))
xlist '()
ylist '()
 )
 (repeat nn
   (setq objdata (nth cter tabdata)
  Pobj	  (car (cdr objdata))
  xobj	  (car Pobj)
  yobj	  (cadr Pobj)

  cter	  (1+ cter)

   )
   (if	(not (memberp yobj ylist (* saiso 0.1)))
     (setq ylist (append ylist (list yobj)))
   )
   (if	(not (memberp xobj xlist saiso))
     (setq xlist (append xlist (list xobj)))
   )
 )
 (setq
   ncol (length xlist)
   nrow (length ylist)
 )
;;; Sap xep toa do x, y theo thu tu
 (setq	xlist (vl-sort xlist '<)
ylist (vl-sort ylist '>)
 )

;;; Sap xep du lieu bang thanh hang, cot
 (setq	tabdata
 (vl-sort tabdata
	  (function (lambda (objdata1 objdata2)
		      (< (cadr (car (cdr objdata1)))
			 (cadr (car (cdr objdata2)))
		      )
		    )
	  )
 )
 )
;;; Chia bang du lieu thanh hang, cot
 (setq	txtfile	'()
ctrow 0


 )
 (repeat nrow
   (setq txtline '()
  yrow	  (nth ctrow ylist)
  ctrow	  (1+ ctrow)

   )

   (setq txtrow '()
  xlistrow '()
  cter 0
  )
   (repeat nn
     (setq txtobj (nth cter tabdata)
    xobj   (car (cadr txtobj))
    yobj   (cadr (cadr txtobj))
    cter (1+ cter)
    )
     (if (<= (abs (- yrow yobj)) (* 0.1 saiso))
(setq txtrow (append txtrow (list txtobj))
      xlistrow (append xlistrow (list xobj))
)
)
     )
   (setq	txtrow
 (vl-sort txtrow
	  (function (lambda (objdata1 objdata2)
		      (< (car (car (cdr objdata1)))
			 (car (car (cdr objdata2)))
		      )
		    )
	  )
 )
 )
   (setq ctcol	  0
  cter1 0)
   (repeat ncol
     (setq
xcol   (nth ctcol xlist)
txtobj (nth cter1 txtrow)
ctcol  (1+ ctcol)
cter1 (1+ cter1)
)
     (if (memberp xcol xlistrow saiso)
(setq content (strcat (car txtobj) "\t")
      )
(setq content (strcat " " "\t")
      cter1 (1- cter1))
)

     (setq txtline (append txtline (list content))
     )

   )
   (setq txtfile (append txtfile (list txtline)))
 )

;;; Chon file luu so lieu

 (Setq	FileDir	(getfiled "File luu so lieu:" "" "xls" 1)
 )


 (setq	cter   0
count  (length txtfile)
FileID (open FileDir "w")
 )
 (write-line "B¶ng d÷ liÖu trÝch xuÊt tõ AutoCAD" FileID)
				;(write-line "Stt\tTªn nót\tTo¹ ®é X\tTo¹ ®é Y" FileID)
 (while (< cter count)
   (setq Txtline (nth cter txtfile)
  cter	  (1+ cter)
  cter1	  0
  content ""
   )
   (repeat ncol
     (setq Content (strcat content (nth cter1 txtline))
    cter1   (1+ cter1)
     )
   )
   (setq txtline content)
   (write-line Txtline FileID)
 )
 (write-line Cpright FileID)

 (close FileID)
 (princ)
)

  • Vote tăng 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
ndtnv    397
Xin giới thiệu với các bác đoạn lisp mà em mày mò mãi (với VBA thì vấn đề có vẻ đơn giản (các bác cao thủ nói vậy chứ em chưa thực hành VBA nhiều lắm) nhưng để làm "thuần lisp" thì phải ...tốn công fu hơn :leluoi:

Lệnh e2x: chọn các text sắp xếp theo dạng bảng (ko cần căn thẳng hàng cột)

Kết quả: file xuất ra dưới dạng "giả excel" (Lisp chỉ làm được đến thế này thôi, bạn fải thêm một công ...open & save as --> Thành excel xịn ngay)

Mặc dù không dùng, nhưng xem sơ qua thì thấy Lisp này khá hay, viết ra chắc cũng khá công phu, nhưng có vài chỗ có thể rút gọn:

Để chọn 1 chữ, do không cần lấy điểm chọn thì chỉ cần

	(ssget  ":S" '((-4 . "")))

hoặc có thể thay

	(if test
	(setq ntest ntest)
	(setq ntest nil)
)
(setq ntest  ntest)

bằng

	(if test ntest nil)

Dùng 1 số hàm có sẵn của Lisp VD Thay cho

	(setq sstest (abs (- num ntest)))
(if (<= sstest tsaiso)   ...	)

	(if (equal  num ntest tsaiso )	...	)

 

Trong trường hợp 2 text khá dài có "Horizontal text justification type" khác nhau

thì (assoc 10) sẽ cho kết quả chính xác hơn là (assoc 11)

do đó nếu chỉ lấy tọa độ của text thì chỉ cần (assoc 10)

còn (assoc 11) dùng khi thay đổi vị trí text khi (assoc 72) hoặc (assoc 73) khác 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

nhờ các Bác giúp em với.

Em đang có vấn đề là:

Bản vẽ em có rất nhiều text em muốn xuất các text này sang Excel để sửa cho nhanh, sau đó nhập lại  vào cad các text mới này thay text cũ (các text vẫn đúng vị trí nhưng thay đổi giá trị) 

Chân thành Cảm ơn các Bác nhiều nha.

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

 

Mặc dù không dùng, nhưng xem sơ qua thì thấy Lisp này khá hay, viết ra chắc cũng khá công phu, nhưng có vài chỗ có thể rút gọn:

Để chọn 1 chữ, do không cần lấy điểm chọn thì chỉ cần

(ssget  ":S" '((-4 . "<OR") (0 . "text") (0 . "mtext") (0 . "ATTRIB") (-4 . "OR>")))
hoặc có thể thay

(if test
		(setq ntest ntest)
		(setq ntest nil)
	)
	(setq ntest  ntest)
bằng

(if test ntest nil)
Dùng 1 số hàm có sẵn của Lisp VD Thay cho

(setq sstest (abs (- num ntest)))
	(if (<= sstest tsaiso)   ...	)

(if (equal  num ntest tsaiso )	...	)
Trong trường hợp 2 text khá dài có "Horizontal text justification type" khác nhau

thì (assoc 10) sẽ cho kết quả chính xác hơn là (assoc 11)

do đó nếu chỉ lấy tọa độ của text thì chỉ cần (assoc 10)

còn (assoc 11) dùng khi thay đổi vị trí text khi (assoc 72) hoặc (assoc 73) khác 0.

bạn làm sao mà khi qua excel nó không bị lỗi phong

ví dụ: họ và tên   Cao Thị Là Uynh (cad) ----->Cao Th\U+1ECB Là Uưnh (excel )

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

Xin giới thiệu với các bác đoạn lisp mà em mày mò mãi (với VBA thì vấn đề có vẻ đơn giản (các bác cao thủ nói vậy chứ em chưa thực hành VBA nhiều lắm) nhưng để làm "thuần lisp" thì phải ...tốn công fu hơn leluoi.gif

Lệnh e2x: chọn các text sắp xếp theo dạng bảng (ko cần căn thẳng hàng cột)

Kết quả: file xuất ra dưới dạng "giả excel" (Lisp chỉ làm được đến thế này thôi, bạn fải thêm một công ...open & save as --> Thành excel xịn ngay)

 

(defun myerror (s)
(cond
((= s "quit / exit abort") (princ))
((/= s "Function cancelled") (princ (strcat "\nError: " s)))
)
(setvar "cmdecho" CMD) ; Restore saved modes
(setvar "osmode" OSM)
(setq *error* OLDERR) ; Restore old *error* handler
(princ)
)

;;;=========================================================================
(defun bocchu (ss1 c)
(setq ob (entget (ssname ss1 c)))
(setq ts (assoc 1 ob))
(setq a (cdr ts))
)

(defun boc1chu (ob)
(if (/= ob nil)
(progn
(setq ts (assoc 1 ob))
(setq a (cdr ts))
)
)
)


(defun Txtnum (num)
(if (> num 0)
(strcat "+" (rtos num 2 0))
(rtos num 2 0)
)
)
;;;=================================
(defun Txtint (num)
(rtos num 2 0)

)

(defun Txtreal (num) (rtos num 2 2))
(defun Txtreal1 (num) (rtos num 2 0))

(defun thaychu (Ob newstr / obtmp)
(setq txtstr (assoc 1 Ob))
(setq newstr (cons 1 newstr)
obtmp (entmod (subst newstr txtstr Ob))
)
(entupd (cdr (assoc -1 obtmp)))
)
(defun chonchu (dongnhac)
(prompt dongnhac)
(ssget
'((-4 . "<OR") (0 . "text") (0 . "mtext") (0 . "ATTRIB") (-4 . "OR>"))
)
)

(defun chon1chu (dongnhac / obj objtype)
(if (setq obj (nentsel dongnhac))
(setq obj (entget (car obj))
objtype (cdr (assoc 0 obj))
)
)
(if (member objtype '("ATTRIB" "MTEXT" "TEXT"))
(setq obj obj)
)
)


(defun chon (str) (ssget '((cons (0 str)))))
(defun bamchon (st) (entget (car (entsel st))))
(defun bocdt (ss1 c) (entget (ssname ss1 c)))


;;;====================================================================
;;; Ham kiem tra xem mot so co nam trong day so ko voi sai so cho san
(defun memberp (num listn tsaiso / cter ni ntest test)
(setq cter 0
test nil
)
(while (< cter (length listn))
(setq ntest (nth cter listn)
sstest (abs (- num ntest))
)
(if (<= sstest tsaiso)
(setq cter (length listn)
test T
)
(setq cter (1+ cter))
)
)
(if test
(setq ntest ntest)
(setq ntest nil)
)
(setq ntest ntest)
)

;;;=======================================================================
;;;;=============================================================
;;; Chep du lieu bang ra file xls (du lieu lon xon khong thang hang cot)
(defun C:e2x (/ Txtline txtfile nrow ncol Filedir count count1 Cpright)
(setvar "cmdecho" 0)
(setq OldLay (getvar "Clayer"))

(Setq Cpright
"Copyright by NguyÔn Gia §¹t <Datnggia@gmail.com - 0915169886>"
)
(setq sstab (chonchu "\nChon bang du lieu ...")
sstmp sstab
cter 0
nn (sslength sstmp)
tabdata '()
htext 0
)

;;; loc ra bang du lieu
(while (< cter nn)
(setq objtxt (entget (ssname sstmp cter))
content (cdr (assoc 1 objtxt))
htext (+ htext (cdr (assoc 40 objtxt)))
objtype (cdr (assoc 0 objtxt))
)
(if (= objtype "TEXT")
(progn
(setq just (cdr (assoc 72 objtxt))
)
(if (= just 0)
(setq idtxt (cdr (assoc 10 objtxt)))
(setq idtxt (cdr (assoc 11 objtxt)))
)
)
(setq idtxt (cdr (assoc 10 objtxt)))
)
(setq
objdata (list content idtxt)
tabdata (append tabdata (list objdata))
cter (1+ cter)
)
)

;;; Tim so hang , so cot cua bang du lieu

(setq cter 0
saiso (* 5 (/ htext nn))
xlist '()
ylist '()
)
(repeat nn
(setq objdata (nth cter tabdata)
Pobj (car (cdr objdata))
xobj (car Pobj)
yobj (cadr Pobj)

cter (1+ cter)

)
(if (not (memberp yobj ylist (* saiso 0.1)))
(setq ylist (append ylist (list yobj)))
)
(if (not (memberp xobj xlist saiso))
(setq xlist (append xlist (list xobj)))
)
)
(setq
ncol (length xlist)
nrow (length ylist)
)
;;; Sap xep toa do x, y theo thu tu
(setq xlist (vl-sort xlist '<)
ylist (vl-sort ylist '>)
)

;;; Sap xep du lieu bang thanh hang, cot
(setq tabdata
(vl-sort tabdata
(function (lambda (objdata1 objdata2)
(< (cadr (car (cdr objdata1)))
(cadr (car (cdr objdata2)))
)
)
)
)
)
;;; Chia bang du lieu thanh hang, cot
(setq txtfile '()
ctrow 0


)
(repeat nrow
(setq txtline '()
yrow (nth ctrow ylist)
ctrow (1+ ctrow)

)

(setq txtrow '()
xlistrow '()
cter 0
)
(repeat nn
(setq txtobj (nth cter tabdata)
xobj (car (cadr txtobj))
yobj (cadr (cadr txtobj))
cter (1+ cter)
)
(if (<= (abs (- yrow yobj)) (* 0.1 saiso))
(setq txtrow (append txtrow (list txtobj))
xlistrow (append xlistrow (list xobj))
)
)
)
(setq txtrow
(vl-sort txtrow
(function (lambda (objdata1 objdata2)
(< (car (car (cdr objdata1)))
(car (car (cdr objdata2)))
)
)
)
)
)
(setq ctcol 0
cter1 0)
(repeat ncol
(setq
xcol (nth ctcol xlist)
txtobj (nth cter1 txtrow)
ctcol (1+ ctcol)
cter1 (1+ cter1)
)
(if (memberp xcol xlistrow saiso)
(setq content (strcat (car txtobj) "\t")
)
(setq content (strcat " " "\t")
cter1 (1- cter1))
)

(setq txtline (append txtline (list content))
)

)
(setq txtfile (append txtfile (list txtline)))
)

;;; Chon file luu so lieu

(Setq FileDir (getfiled "File luu so lieu:" "" "xls" 1)
)


(setq cter 0
count (length txtfile)
FileID (open FileDir "w")
)
(write-line "B¶ng d÷ liÖu trÝch xuÊt tõ AutoCAD" FileID)
;(write-line "Stt\tTªn nót\tTo¹ ®é X\tTo¹ ®é Y" FileID)
(while (< cter count)
(setq Txtline (nth cter txtfile)
cter (1+ cter)
cter1 0
content ""
)
(repeat ncol
(setq Content (strcat content (nth cter1 txtline))
cter1 (1+ cter1)
)
)
(setq txtline content)
(write-line Txtline FileID)
)
(write-line Cpright FileID)

(close FileID)
(princ)
)

 

bác cho em hỏi với ạ : em chọn object rồi nhưng nó báo thế này là bị làm sao vậy bác " bad argument type: stringp nil "

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

Xin giới thiệu với các bác đoạn lisp mà em mày mò mãi (với VBA thì vấn đề có vẻ đơn giản (các bác cao thủ nói vậy chứ em chưa thực hành VBA nhiều lắm) nhưng để làm "thuần lisp" thì phải ...tốn công fu hơn leluoi.gif

Lệnh e2x: chọn các text sắp xếp theo dạng bảng (ko cần căn thẳng hàng cột)

Kết quả: file xuất ra dưới dạng "giả excel" (Lisp chỉ làm được đến thế này thôi, bạn fải thêm một công ...open & save as --> Thành excel xịn ngay)


 

Mình sử dụng lisp của bạn thấy rất hiệu quả. Xin cảm ơn bạn Snowman 

Nhờ bạn Snowman hoặc bạn nào biết lisp vui lòng sửa lại giúp mình file e2x.lsp chút xíu để công việc nhanh chóng hơn được không ạ.

Mình không biết về lisp nên nhờ bạn sửa lại để khi kết thúc thì sẽ mở excel và mở file vừa xuất luôn (hiện giờ chương trình chỉ lưu file lại, mình phải đến đường dẫn file xuất ra rồi mở lên để thấy kết quả xuất). Cảm ơn các bạn.

 

Trình tự mong muốn:

1. Gõ lệnh.

2. Chọn  các text sắp xếp theo dạng bảng (ko cần căn thẳng hàng cột)

3. Tự động mở chương trình excel và hiện kết quả là các text đã chọn ở dạng bảng (không cần lưu file)

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

http://www.cadviet.com/upfiles/5/144276_e2x_1.lsp

 

Nhờ quý anh quý chị nào biết giúp giùm em với ạ. Em muốn mở rộng lisp để sau khi hoàn tất thì mở chương trình excel và hiện ra kết quả chứ không cần phải đến đường dẫn đã lưu để mở file ạ. Em xin cảm ơn.

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

Xin giới thiệu với các bác đoạn lisp mà em mày mò mãi (với VBA thì vấn đề có vẻ đơn giản (các bác cao thủ nói vậy chứ em chưa thực hành VBA nhiều lắm) nhưng để làm "thuần lisp" thì phải ...tốn công fu hơn leluoi.gif

Lệnh e2x: chọn các text sắp xếp theo dạng bảng (ko cần căn thẳng hàng cột)

Kết quả: file xuất ra dưới dạng "giả excel" (Lisp chỉ làm được đến thế này thôi, bạn fải thêm một công ...open & save as --> Thành excel xịn ngay)

 

(defun myerror (s)
(cond
((= s "quit / exit abort") (princ))
((/= s "Function cancelled") (princ (strcat "\nError: " s)))
)
(setvar "cmdecho" CMD) ; Restore saved modes
(setvar "osmode" OSM)
(setq *error* OLDERR) ; Restore old *error* handler
(princ)
)

;;;=========================================================================
(defun bocchu (ss1 c)
(setq ob (entget (ssname ss1 c)))
(setq ts (assoc 1 ob))
(setq a (cdr ts))
)

(defun boc1chu (ob)
(if (/= ob nil)
(progn
(setq ts (assoc 1 ob))
(setq a (cdr ts))
)
)
)


(defun Txtnum (num)
(if (> num 0)
(strcat "+" (rtos num 2 0))
(rtos num 2 0)
)
)
;;;=================================
(defun Txtint (num)
(rtos num 2 0)

)

(defun Txtreal (num) (rtos num 2 2))
(defun Txtreal1 (num) (rtos num 2 0))

(defun thaychu (Ob newstr / obtmp)
(setq txtstr (assoc 1 Ob))
(setq newstr (cons 1 newstr)
obtmp (entmod (subst newstr txtstr Ob))
)
(entupd (cdr (assoc -1 obtmp)))
)
(defun chonchu (dongnhac)
(prompt dongnhac)
(ssget
'((-4 . "<OR") (0 . "text") (0 . "mtext") (0 . "ATTRIB") (-4 . "OR>"))
)
)

(defun chon1chu (dongnhac / obj objtype)
(if (setq obj (nentsel dongnhac))
(setq obj (entget (car obj))
objtype (cdr (assoc 0 obj))
)
)
(if (member objtype '("ATTRIB" "MTEXT" "TEXT"))
(setq obj obj)
)
)


(defun chon (str) (ssget '((cons (0 str)))))
(defun bamchon (st) (entget (car (entsel st))))
(defun bocdt (ss1 c) (entget (ssname ss1 c)))


;;;====================================================================
;;; Ham kiem tra xem mot so co nam trong day so ko voi sai so cho san
(defun memberp (num listn tsaiso / cter ni ntest test)
(setq cter 0
test nil
)
(while (< cter (length listn))
(setq ntest (nth cter listn)
sstest (abs (- num ntest))
)
(if (<= sstest tsaiso)
(setq cter (length listn)
test T
)
(setq cter (1+ cter))
)
)
(if test
(setq ntest ntest)
(setq ntest nil)
)
(setq ntest ntest)
)

;;;=======================================================================
;;;;=============================================================
;;; Chep du lieu bang ra file xls (du lieu lon xon khong thang hang cot)
(defun C:e2x (/ Txtline txtfile nrow ncol Filedir count count1 Cpright)
(setvar "cmdecho" 0)
(setq OldLay (getvar "Clayer"))

(Setq Cpright
"Copyright by NguyÔn Gia §¹t <Datnggia@gmail.com - 0915169886>"
)
(setq sstab (chonchu "\nChon bang du lieu ...")
sstmp sstab
cter 0
nn (sslength sstmp)
tabdata '()
htext 0
)

;;; loc ra bang du lieu
(while (< cter nn)
(setq objtxt (entget (ssname sstmp cter))
content (cdr (assoc 1 objtxt))
htext (+ htext (cdr (assoc 40 objtxt)))
objtype (cdr (assoc 0 objtxt))
)
(if (= objtype "TEXT")
(progn
(setq just (cdr (assoc 72 objtxt))
)
(if (= just 0)
(setq idtxt (cdr (assoc 10 objtxt)))
(setq idtxt (cdr (assoc 11 objtxt)))
)
)
(setq idtxt (cdr (assoc 10 objtxt)))
)
(setq
objdata (list content idtxt)
tabdata (append tabdata (list objdata))
cter (1+ cter)
)
)

;;; Tim so hang , so cot cua bang du lieu

(setq cter 0
saiso (* 5 (/ htext nn))
xlist '()
ylist '()
)
(repeat nn
(setq objdata (nth cter tabdata)
Pobj (car (cdr objdata))
xobj (car Pobj)
yobj (cadr Pobj)

cter (1+ cter)

)
(if (not (memberp yobj ylist (* saiso 0.1)))
(setq ylist (append ylist (list yobj)))
)
(if (not (memberp xobj xlist saiso))
(setq xlist (append xlist (list xobj)))
)
)
(setq
ncol (length xlist)
nrow (length ylist)
)
;;; Sap xep toa do x, y theo thu tu
(setq xlist (vl-sort xlist '<)
ylist (vl-sort ylist '>)
)

;;; Sap xep du lieu bang thanh hang, cot
(setq tabdata
(vl-sort tabdata
(function (lambda (objdata1 objdata2)
(< (cadr (car (cdr objdata1)))
(cadr (car (cdr objdata2)))
)
)
)
)
)
;;; Chia bang du lieu thanh hang, cot
(setq txtfile '()
ctrow 0


)
(repeat nrow
(setq txtline '()
yrow (nth ctrow ylist)
ctrow (1+ ctrow)

)

(setq txtrow '()
xlistrow '()
cter 0
)
(repeat nn
(setq txtobj (nth cter tabdata)
xobj (car (cadr txtobj))
yobj (cadr (cadr txtobj))
cter (1+ cter)
)
(if (<= (abs (- yrow yobj)) (* 0.1 saiso))
(setq txtrow (append txtrow (list txtobj))
xlistrow (append xlistrow (list xobj))
)
)
)
(setq txtrow
(vl-sort txtrow
(function (lambda (objdata1 objdata2)
(< (car (car (cdr objdata1)))
(car (car (cdr objdata2)))
)
)
)
)
)
(setq ctcol 0
cter1 0)
(repeat ncol
(setq
xcol (nth ctcol xlist)
txtobj (nth cter1 txtrow)
ctcol (1+ ctcol)
cter1 (1+ cter1)
)
(if (memberp xcol xlistrow saiso)
(setq content (strcat (car txtobj) "\t")
)
(setq content (strcat " " "\t")
cter1 (1- cter1))
)

(setq txtline (append txtline (list content))
)

)
(setq txtfile (append txtfile (list txtline)))
)

;;; Chon file luu so lieu

(Setq FileDir (getfiled "File luu so lieu:" "" "xls" 1)
)


(setq cter 0
count (length txtfile)
FileID (open FileDir "w")
)
(write-line "B¶ng d÷ liÖu trÝch xuÊt tõ AutoCAD" FileID)
;(write-line "Stt\tTªn nót\tTo¹ ®é X\tTo¹ ®é Y" FileID)
(while (< cter count)
(setq Txtline (nth cter txtfile)
cter (1+ cter)
cter1 0
content ""
)
(repeat ncol
(setq Content (strcat content (nth cter1 txtline))
cter1 (1+ cter1)
)
)
(setq txtline content)
(write-line Txtline FileID)
)
(write-line Cpright FileID)

(close FileID)
(princ)
)

Mình hỏi một chút là nếu tất cả các text  cùng chiều (cùng nghiêng, hoặc cùng đứng thì ok) nhưng nếu không đồng nhất thì nó sẽ không xuất ra được file cho dù nó báo chọn được đối tượng

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

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay


×