[CAD插件] 读取excel写入块属性

[复制链接]
查看723 | 回复0 | 2024-3-7 16:08:14 | 显示全部楼层 |阅读模式
(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)
)

CAD橱柜家具设计3群
回复

使用道具 举报

右侧快捷回复! 回复垃圾贴,封禁帐号!
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则