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

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

(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 ITEM BLOCKS
(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
(wcmatch n
"[,`*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
)

(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 ITEM  BLOCKS 
     (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 
         (wcmatch  n 
      "[,`*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?mo ... mp;extra=#pid993285

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

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

杜总威武，收藏走起，一直找不到

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

[源码] 从外部dwg中复制块定义到当前图纸中