[源码] 《读取excel写入块属性》
;;; ===============================================;;; 《读取excel写入块属性》
;;; 作者：langjs 命令:etoa
;;; ===============================================
(defun c:etoa (/ appsession box cells ent ent1 fil h i j lst lst1 lst2 maxpoint minpoint na name name0 name1 nub oldfil
p0 pmax pmin pt pt1 pt10 pt2 r snap ss str w x y
)
(defun wratt (ent nub str / box ent1 h i j pt pt1 pt10 pt2 w) ; 写属性块
(defun jspt (pt i j) ; pt相对坐标计算
(list (+ (car pt) i) (+ (cadr pt) j))
)
(defun sub (ent i str)
(subst
(cons i str)
(assoc i ent)
ent
)
)
(setq ent1 ent)
(while (= (cdr (assoc 0 (setq ent1 (entget (entnext (cdr (assoc -1 ent1))))))) "ATTRIB")
(if (= (cdr (assoc 2 ent1)) nub)
(progn
(setq pt10 (cdr (assoc 10 ent1)))
(setq h (cdr (assoc 40 ent1)))
(setq w 0.7)
(setq ent1 (sub ent1 41 w))
(setq ent1 (sub ent1 1 str))
(if (and
(setq box (textbox (cdr ent1)))
(= (cdr (assoc 72 ent1)) 0)
)
(progn
(setq pt1 (jspt pt10 (car (car box)) (* 0.5 (cadr (cadr box)))))
(setq pt2 (jspt pt10 (car (cadr box)) (* 0.5 (cadr (cadr box)))))
(entmod (sub ent1 1 ""))
(entmod ent)
(while (and
(ssget "F" (list pt1 pt2) '((0 . "INSERT,LINE")))
(> (car pt2) (car pt1))
)
(setq w (- w 0.01))
(setq ent1 (sub ent1 41 w))
(setq box (textbox (cdr ent1)))
(setq pt2 (jspt pt10 (car (cadr box)) (* 0.5 (cadr (cadr box)))))
)
)
)
(entmod ent1)
)
)
)
(entmod ent)
)
(defun rexcel (cells i j) ; 读取excel第i行第j列
(vlax-variant-value (vlax-variant-change-type (vlax-get-property cells 'item i j) 8))
)
(defun #err (s)
(setvar "nomutt" 0)
(setvar "osmode" snap)
(if name
(redraw name 4)
)
(setq *error* $orr)
)
(vl-load-com)
(setq $orr *error*)
(setq *error* #err)
(setvar "cmdecho" 0)
(setq snap (getvar "osmode"))
(if (null oldfil)
(setq oldfil (vl-filename-directory (findfile "acad.exe")))
)
(if (/= (substr oldfil (strlen oldfil)) "\\")
(setq oldfil (strcat oldfil "\\"))
)
(princ "\nEXCEL转属性")
(princ "\n选择EXCEL表:")
(setq fil (getfiled "选择EXCEL数据表" oldfil "xls;xlsx" 0))
(setq oldfil (vl-filename-directory fil))
(setq appsession (vlax-get-or-create-object "Excel.Application"))
(vlax-invoke-method (vlax-get-property appsession 'workbooks) 'open fil)
(vla-put-visible appsession 0)
(setq cells (vlax-get (vlax-get-property (vlax-get-property (vlax-get-object "Excel.Application") 'activeworkbook)
'activesheet
) "cells"
)
)
(setq j 1
lst '()
lst1 '()
)
(while (/= (setq str (rexcel cells 1 j))
""
)
(setq lst1 (cons str lst1))
(setq j (1+ j))
)
(setq lst1 (reverse lst1))
(setq i 2)
(while (/= (rexcel cells i 1) "")
(setq j 1
lst2 '()
)
(repeat (length lst1)
(setq str (rexcel cells i j))
(setq lst2 (cons str lst2))
(setq j (1+ j))
)
(setq lst2 (reverse lst2))
(setq lst (cons lst2 lst))
(setq i (1+ i))
)
(setq lst (reverse lst))
(setvar "nomutt" 1)
(setq ss (ssadd))
(if (> (length lst) 0)
(progn
(princ "\n选择属性块样式：")
(if (setq name (car (entsel)))
(progn
(redraw name 3)
(vla-getboundingbox (vlax-ename->vla-object name) 'minpoint 'maxpoint)
(setq pmax (vlax-safearray->list maxpoint)
pmin (vlax-safearray->list minpoint)
)
(setq x (- (car pmax) (car pmin))
y (- (cadr pmax) (cadr pmin))
)
(setq ent (entget name))
(setq na (cdr (assoc 1 ent)))
(setq p0 (cdr (assoc 10 ent)))
(princ "\n输入插入点：")
(if (setq pt (getpoint))
(progn
(setvar "osmode" 0)
(princ "\n指定排序方向：")
(if (setq pt1 (getpoint pt))
(progn
(setq r (/ (* 180.0 (angle pt pt1)) pi))
(cond
((< r 45)
(setq y 0)
)
((< r 135)
(setq x 0)
)
((< r 225)
(setq x (* -1 x)
y 0
)
)
((< r 315)
(setq x 0
y (* -1 y)
)
)
(t
(setq y 0)
)
)
(foreach lst2 lst
((if command-s
command-s
vl-cmdf
) "copy"
name ""
p0 pt
)
(setq name1 (entlast))
(setq ent (entget name1))
(setq ent1 ent)
(while (= (cdr (assoc 0 (setq ent1 (entget (entnext (cdr (assoc -1 ent1))))))) "ATTRIB")
(entmod (subst
(cons 1 "")
(assoc 1 ent1)
ent1
)
)
)
(entmod ent)
(setq ent (entget name1))
(setq i 0)
(repeat (length lst1)
(setq nub (nth i lst1))
(setq str (nth i lst2))
(wratt ent nub str)
(setq i (1+ i))
)
(setq pt (list (+ (car pt) x) (+ (cadr pt) y)))
)
)
)
)
)
(redraw name 4)
)
)
)
)
(setvar "nomutt" 0)
(setvar "osmode" snap)
(setq *error* $orr)
(princ)
)
页:
[1]