《读取excel写入块属性》

langjs · 发表于 2024-3-6 13:47:42

;;; ===============================================
;;; 《读取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)
)

清水白粥 · 发表于 2024-8-29 09:41:16

命令: AP APPLOAD 已成功加载 ATOE输出到EXcel.lsp。
命令: 输入中的点位置不正确
郎大师，这个问题怎么解决

weimeng555 · 发表于 2024-5-3 02:07:59

感谢大师分享，这个代码是类似attin的效果吗？

阿猪蛋 · 发表于 2024-9-9 09:52:59

很久没看到郎大师，感谢大师的分享！

lxl217114 · 发表于 2024-3-6 14:18:29

大佬连发二更，非常感谢。

panliang9 · 发表于 2024-3-6 19:49:00

看到是郎大师我很敏捷的就进来了！

22千里之外 · 发表于 2024-3-8 11:28:01

保存下了，感谢分享

czb203 · 发表于 2024-3-10 10:21:18

很久没看到郎大师，感谢大师的分享！

i小小白i · 发表于 2024-3-13 13:15:22

多谢分享，正需要！感谢感谢

wsj249201 · 发表于 2024-3-15 13:24:49

我试了一下，好像不行啊

yefei812678 · 发表于 2024-3-22 09:39:29

感谢分享感谢分享感谢分享

sosvery · 发表于 2024-4-20 19:58:11

多谢分享，正需要！感谢感谢

账号		自动登录	找回密码
密码			注册

[源码] 《读取excel写入块属性》

点评

评分

点评