dcl1214 发表于 2024-9-1 19:53:58

从外部dwg中复制块定义到当前图纸中

(defun $COPY-BLK-FROM-DWG$
       (dwg B-NS lst / blkdbx blocks catch COPY fzjg n odbx)
          ;将外部dwg里面的块定义挖到当前图纸里面来，复制外部dwg里面的块定义
          ;DWG 图纸路径
          ;b-ns 如果指定了块名就复制，如果没有传入任何块名就将外部dwg里面的所有块定义都挖过来
          ;lst 预留参数
(DEFUN COPY (odbx blkdbx)
    (vl-catch-all-apply
      'vla-copyobjects
      (LIST
odbx
(vl-catch-all-apply
    'vlax-safearray-fill
    (LIST
      (vlax-make-safearray
      vlax-vbObject
      '(0 . 0)
      )
      (list blkdbx)
    )
)
(vla-get-blocks
    (vla-get-activedocument
      (vlax-get-acad-object)
    )
)
      )
    )
)
(if (AND B-NS (= (TYPE B-NS) 'str))
    (setq B-NS (list B-NS))
)
(if (AND DWG (findfile dwg))
    (progn
      (if (< (atoi (substr (getvar "ACADVER") 1 2)) 16)
(setq odbx (vlax-create-object "ObjectDBX.AxDbDocument"))
(setq odbx (vlax-create-object
         (strcat "ObjectDBX.AxDbDocument."
         (substr (getvar "ACADVER") 1 2)
         )
       )
)
      )
      (vl-catch-all-apply 'vla-open (LIST odbx dwg))
      (COND
((AND B-NS)
   (setq
   fzjg(MAPCAR
      (FUNCTION
      (LAMBDA (B-N / catch blkdbx)
          (if (setq
          catch
         (vl-catch-all-error-p
             (vl-catch-all-apply
         (function
         (lambda ()
             (set 'blkdbx
            (vla-item (vla-get-blocks odbx)
                B-N
            )
             )
         )
         )
             )
         )
      )
      ()
      (COPY odbx blkdbx)
          )
          (if
      (and B-N
         (null catch)
         (vla-item
             (vla-get-blocks
         (vla-get-activedocument
         (vlax-get-acad-object)
         )
             )
             B-N
         )
      )
       (list (CONS "块名" b-n) (cons "复制" "成功"))
       (list (CONS "块名" b-n) (cons "复制" "失败"))
          )
      )
      )
      B-NS
    )
   )
)
(T
   (SETQ BLOCKS (vla-get-blocks odbx))
   (VLAX-FOR ITEMBLOCKS
   (SETQ N (vla-get-objectname item))
   (setq n (vl-catch-all-apply
         'vla-get-effectivename
         (list item)
       )
   )
   (if (vl-catch-all-error-p n)
       (setq n (vl-catch-all-apply 'vla-get-name (list item)))
   )
   (if
       (and
         n
         (wcmatchn
      "[,`*Model_Space,`*Paper_Space,`*Paper_Space0,]"
         )
       )
      ()
      (progn
    (COPY odbx
          (vl-catch-all-apply
      'vla-item
      (LIST (vla-get-blocks odbx) N)
          )
    )
    (if (and n
       (setq catch (vl-catch-all-apply
               'vla-item
               (list
         (vla-get-blocks
             (vla-get-activedocument
               (vlax-get-acad-object)
             )
         )
         n
               )
             )
       )
       (NOT (vl-catch-all-error-p catch))
      )
      (set
      'fzjg
      (cons (list (CONS "块名" n) (cons "复制" "成功"))
      fzjg
      )
      )
      (set
      'fzjg
      (cons (list (CONS "块名" n) (cons "复制" "失败"))
      fzjg
      )
      )
    )
      )
   )
   )
)
      )
      (vl-catch-all-apply 'vlax-release-object (LIST odbx))
    )
)
fzjg
)

wharan 发表于 2024-9-1 20:59:37

应该是好代码。就是不知道调用格式是什么？
($COPY-BLK-FROM-DWG$ "c:\\log\\demo.dwg" "$titleblk$00000194" 12)不成功

dcl1214 发表于 2024-9-1 21:12:50

wharan 发表于 2024-9-1 20:59
应该是好代码。就是不知道调用格式是什么？
($COPY-BLK-FROM-DWG$ "c:\\log\\demo.dwg" "$titleblk$000001 ...

在原图纸中使用 vla-get-effectivename 查询一下

开心无惧 发表于 2024-9-2 09:32:50

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=191079&page=1&extra=#pid993285

你好 可以帮忙看看这个问题吗

chslwj521 发表于 2024-9-3 14:06:35

杜总威武，收藏走起，一直找不到
页: [1]
查看完整版本: 从外部dwg中复制块定义到当前图纸中