(defun c:tbltoex ()
(pl:export-to-excel)
) ;_ end of defun

(defun pl:export-to-excel (/ ccells csheet dat excel i k newbook torel wbooks wsheets next cols)
(if (setq excel (vlax-get-or-create-object "Excel.Application"))
(progn
(setq wbooks (vlax-get-property excel 'workbooks)
newbook (vlax-invoke-method wbooks 'add 1)
wsheets (vlax-get-property newbook 'worksheets)
csheet (vlax-get-property newbook 'activesheet)
) ;_ end of setq
(while (setq dat (pl:get-tbl-data))
(if next
(setq torel (cons csheet torel)
;;; csheet (vlax-invoke-method wsheets 'add nil csheet) ;_ при использовании этой строки, при закрытии Экселя - ошибка
csheet (vlax-invoke-method wsheets 'add)
) ;_ end of setq
) ;_ end of if
(setq ccells (vlax-get-property csheet 'cells)
cols (vlax-get-property csheet 'columns)
i 0
) ;_ end of setq
(foreach y dat
(setq i (1+ i)
k 0
) ;_ end of setq
(foreach x y
(setq k (1+ k))
(pl:put-val-to-cell ccells i k x)
) ;_ end of foreach
) ;_ end of foreach
(vlax-invoke-method cols 'autofit)
(vlax-release-object cols)
(vlax-release-object ccells)
(setq next t)
) ;_ end of while
(if torel
(vlax-invoke-method (last torel) 'activate)
) ;_ end of if
(if (= (vlax-get-property excel 'visible) :vlax-false)
(vlax-put-property excel 'visible :vlax-true)
) ;_ end of if
(foreach x (cons csheet
(if torel
(append torel (list wsheets newbook wbooks excel))
(list wsheets newbook wbooks excel)
) ;_ end of if
) ;_ end of cons
(vlax-release-object x)
) ;_ end of foreach
) ;_ end of progn
(alert "Can not launch Excel!!")
) ;_ end of if
(princ)
) ;_ end of defun

(defun pl:put-val-to-cell (ccells x y val / tmp brd form)
(setq val (vl-string-trim " " val))
(vlax-put-property
(setq tmp (vlax-variant-value
(vlax-get-property
ccells
'item
(vlax-make-variant x vlax-vbinteger)
(vlax-make-variant y vlax-vbinteger)
) ;_ end of vlax-get-property
) ;_ end of vlax-variant-value
) ;_ end of setq
"Value2"
(vlax-make-variant val vlax-vbvariant)
) ;_ end of vlax-put-property
(setq brd (vlax-get-property tmp 'borders))
(vlax-put-property brd 'colorindex (vlax-make-variant -4105 3))
(if (= (type (setq form (pl:is-real-form val))) 'str)
(vlax-put-property
tmp
'numberformat
(vlax-make-variant (strcat "# ##0" form) 8)
) ;_ распознавание форматов
) ;_ end of if
(vlax-release-object brd)
(vlax-release-object tmp)
) ;_ end of defun

(defun pl:is-real-form (val)
(cond ((not (= (vl-string-trim "0123456789.," val) "")) nil)
((= (vl-string-trim "0123456789" val) "") "")
((list val)
) ;_ end of vl-remove-if-not
) ;_ end of length
) ;_ end of string
(mapcar (function
(lambda (b)
(if (or (= b 44) (= b 46))
46
48
) ;_ end of if
) ;_ end of lambda
) ;_ end of function
(vl-string->list (vl-string-left-trim "0123456789" val))
) ;_ end of mapcar
) ;_ end of vl-list->string
)
) ;_ end of cond
) ;_ end of defun

(defun pl:get-tbl-ents (/ _box)
(setq
_box
(vl-catch-all-apply
(function
(lambda (/ corn1 corn2)
(if
(and (setq corn1
(getpoint
"\nSelect LL Corner of Table : "
) ;_ end of getpoint
) ;_ end of setq
(setq corn2
(getcorner
corn1
"\nSelect UR Corner of Table : "
) ;_ end of getcorner
) ;_ end of setq
) ;_ end of and
(list corn1 corn2)
) ;_ end of if
) ;_ end of lambda
) ;_ end of function
nil
) ;_ end of vl-catch-all-apply
) ;_ end of setq
(if (cond ((not _box) (princ "\nNo selection") nil)
((vl-catch-all-error-p _box)
(princ (strcat "\n" (vl-catch-all-error-message _box)))
nil
)
(t
(setq _box (list (list (min (caar _box) (caadr _box))
(max (cadar _box) (cadadr _box))
) ;_ end of list
(list (max (caar _box) (caadr _box))
(min (cadar _box) (cadadr _box))
) ;_ end of list
) ;_ end of list
) ;_ end of setq
)
) ;_ end of cond
(list _box
(ssget "_C" (car _box) (cadr _box) '((0 . "LINE")))
(ssget "_C" (car _box) (cadr _box) '((0 . "LWPOLYLINE")))
(ssget "_C" (car _box) (cadr _box) '((0 . "TEXT")))
) ;_ end of list
) ;_ end of if
) ;_ end of defun

(defun pl:get-tbl-data (/ _sel _texts _lhrzn _lines _lvert _lwpl _modcol _modrow _mtx)
(if (setq _texts (last (setq _sel (pl:get-tbl-ents))))
(progn
(setq _lines (cadr _sel)
_lwpl (caddr _sel)
_sel (car _sel)
) ;_ end of setq
(if _lines
(setq _lines (mapcar 'pl:extr-pnt-from-line (pl:entlst-from-ss _lines)))
) ;_ end of if
(if _lwpl
(setq _lwpl (apply 'append
(mapcar 'pl:lwpl-to-segments (pl:entlst-from-ss _lwpl))
) ;_ end of apply
) ;_ end of setq
) ;_ end of if
(if
(and (setq _lines (append _lines _lwpl))
(setq _lines (vl-remove-if-not
(function
(lambda (x)
(pl:is-point-in-bbox (pl:get-cen-pnts-2d x) _sel)
) ;_ end of lambda
) ;_ end of function
_lines
) ;_ end of vl-remove-if-not
) ;_ end of setq
(setq _lines (mapcar (function
(lambda (x)
(pl:near-orto x 3)
) ;_ end of lambda
) ;_ end of function
_lines
) ;_ end of mapcar
) ;_ end of setq
(> (length
(setq _lvert (mapcar 'cdr
(vl-remove-if
(function
(lambda (x)
(or (not x)
(= (car x) 0)
) ;_ end of or
) ;_ end of lambda
) ;_ end of function
_lines
) ;_ end of vl-remove-if
) ;_ end of mapcar
) ;_ end of setq
) ;_ end of length
1
) ;_ end of >
(> (length
(setq _lhrzn (mapcar 'cdr
(vl-remove-if
(function
(lambda (x)
(or (not x)
(= (car x) 1)
) ;_ end of or
) ;_ end of lambda
) ;_ end of function
_lines
) ;_ end of vl-remove-if
) ;_ end of mapcar
) ;_ end of setq
) ;_ end of length
1
) ;_ end of >
) ;_ end of and
(progn
(setq _modcol (pl:get-len-perc _lvert 1.0)
_modrow (* 0.5
(apply 'min
(mapcar 'vla-get-height
(setq _texts (mapcar 'vlax-ename->vla-object
(pl:entlst-from-ss _texts)
) ;_ end of mapcar
) ;_ end of setq
) ;_ end of mapcar
) ;_ end of apply
) ;_ end of *
_lvert (pl:clr-near-doub (pl:sort ' (pl:clr-near-doub (pl:sort 'list tmp)) 45)
(vl-string-right-trim "-" tmp)
(strcat tmp " ")
) ;_ end of if
) ;_ end of lambda
) ;_ end of function
(pl:sort (function
(lambda (a b / tmp)
(setq tmp (angle (car a) (car b)))
(or (< 0 tmp 0.52359878)
( el (- (car tmp) mod)))
tmp
(cons el tmp)
) ;_ end of if
) ;_ end of progn
) ;_ end of if
) ;_ end of defun

(defun pl:get-len-perc (lst perc)
(* (abs (- (apply 'max lst) (apply 'min lst))) 0.01 perc)
) ;_ end of defun

(defun pl:extr-pnt-from-line (_line / _p1 _p2)
(setq _line (entget _line)
_p1 (cdr (assoc 10 _line))
_p2 (cdr (assoc 11 _line))
) ;_ end of setq
(list (list (car _p1) (cadr _p1))
(list (car _p2) (cadr _p2))
) ;_ end of list
) ;_ end of defun

(defun pl:extr-pnt-from-lwline (_dxf)
(mapcar 'cdr
(vl-remove-if-not
(function
(lambda (x)
(= 10 (car x))
) ;_ end of lambda
) ;_ end of function
_dxf
) ;_ end of vl-remove-if-not
) ;_ end of mapcar
) ;_ end of defun

(defun pl:lwpl-to-segments (_lwline / _vert)
(setq _lwline (entget _lwline)
_vert (pl:extr-pnt-from-lwline _lwline)
) ;_ end of setq
(mapcar 'list
(if (zerop (logand 1 (cdr (assoc 70 _lwline))))
(cdr _vert)
(cons (last _vert) _vert)
) ;_ end of if
_vert
) ;_ end of mapcar
) ;_ end of defun

(defun pl:near-orto (_lstpnt _delta / _ang _dir)
(setq _ang (rem (apply 'angle _lstpnt) pi)
_delta (rem (/ (* pi _delta) 180) (* pi 2))
_dir (cond ((>= (+ (/ pi 2) _delta) _ang (- (/ pi 2) _delta)) 1)
((or (>= _delta _ang 0) (>= pi _ang (- pi _delta))) 0)
(t nil)
) ;_ end of cond
) ;_ end of setq
(if _dir
(cons _dir
(/ (apply '+
(mapcar (if (= _dir 0)
'cadr
'car
) ;_ end of if
_lstpnt
) ;_ end of mapcar
) ;_ end of apply
2
) ;_ end of /
) ;_ end of cons
) ;_ end of if
) ;_ end of defun

(defun pl:sort (func lst)
(mapcar (function
(lambda (x)
(nth x lst)
) ;_ end of lambda
) ;_ end of function
(vl-sort-i lst func)
) ;_ end of mapcar
) ;_ end of defun

(defun pl:entlst-from-ss (ss)
(vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
) ;_ end of defun

(defun pl:get-bbox (obj / minpoint maxpoint)
(vla-getboundingbox obj 'minpoint 'maxpoint)
(mapcar 'vlax-safearray->list (list minpoint maxpoint))
) ;_ end of defun

(defun pl:is-point-in-bbox (point bbox)
(apply 'and
(mapcar (function
(lambda (x y)
(<= (apply 'min x) y (apply 'max x))
) ;_ end of lambda
) ;_ end of function
(apply 'mapcar (cons 'list bbox))
point
) ;_ end of mapcar
) ;_ end of apply
) ;_ end of defun

(defun pl:get-cen-pnts (pntlst / len)
(setq len (length pntlst))
(list (/ (apply '+ (mapcar 'car pntlst)) len)
(/ (apply '+ (mapcar 'cadr pntlst)) len)
(/ (apply '+ (mapcar 'caddr pntlst)) len)
) ;_ end of list
) ;_ end of defun

(defun pl:get-cen-pnts-2d (pntlst / len)
(setq len (length pntlst))
(list (/ (apply '+ (mapcar 'car pntlst)) len)
(/ (apply '+ (mapcar 'cadr pntlst)) len)
) ;_ end of list
) ;_ end of defun

(apply
(function
(lambda ()
(vl-load-com)
(princ
(strcat
"\nExport Autocad Drawn Table to Excel"
"\n©2014 "
"\n\"
"\ntype 'tbltoex' to execute."
) ;_ end of strcat
) ;_ end of princ
(princ)
) ;_ end of lambda
) ;_ end of function
nil
) ;_ end of apply
(c:tbltoex)

Advertisements