常用函数.lsp

自贡黄明儒

;;154.7 [功能] 复制非打开文件的块至本图
;;154.8 [功能] 复制非打开文件的特定块至本图
;;154.9 [功能] 复制特定文件的块至本图(不论打开或者非打开)

1. ;;154.7 [功能] 复制非打开文件的块至本图
   
2. ;;(Odbx-copyblocks 文件名)
   
3. ;;(Odbx-copyblocks "D:\\DrawingA.dwg"),之后输入命令i,就可以看到DrawingA的块均在本图中了
   
4. (defun Odbx-copyblocks (DwgName / DBXBLOCKS DBXDOC NUM)
   
5.   (setq        dbxDoc (vla-GetInterfaceObject
   
6.                  (vlax-get-acad-object)
   
7.                  (GetObjectDBXVer)
   
8.                )
   
9.   )
   
10.   (vla-open dbxDoc DwgName)                ;不能打开.dxf文件,返回nil
    
11.   (setq DBXBLOCKS (vla-get-blocks dbxDoc))
    
12.   (vlax-for BLK        DBXBLOCKS
    
13.     (if        (and (not (wcmatch (substr (vla-get-name BLK) 1 1) "`*"))
    
14.              (= (vla-get-isxref BLK) :vlax-false)
    
15.         )                                ;去除系统块、匿名块和参照类对象
    
16.       (setq namelst (append namelst (list (vla-get-name BLK))))
    
17.     )
    
18.   )
    
19.   (foreach name        namelst
    
20.     (setq num (vla-item DBXBLOCKS name))
    
21.     (vla-copyobjects
    
22.       dbxDoc
    
23.       (vlax-safearray-fill
    
24.         (vlax-make-safearray vlax-vbobject '(0 . 0))
    
25.         (list num)
    
26.       )
    
27.       (vla-get-modelspace
    
28.         (vla-get-activedocument (vlax-get-acad-object))
    
29.       )
    
30.     )
    
31.   )
    
32.   (if dbxDoc
    
33.     (vlax-release-object dbxDoc)
    
34.   )
    
35. )
    

;;154.7 [功能] 复制非打开文件的块至本图<br /> ;;(Odbx-copyblocks 文件名)<br /> ;;(Odbx-copyblocks "D:\\DrawingA.dwg"),之后输入命令i,就可以看到DrawingA的块均在本图中了<br /> (defun Odbx-copyblocks (DwgName / DBXBLOCKS DBXDOC NUM)<br />   (setq        dbxDoc (vla-GetInterfaceObject<br />                  (vlax-get-acad-object)<br />                  (GetObjectDBXVer)<br />                )<br />   )<br />   (vla-open dbxDoc DwgName)                ;不能打开.dxf文件,返回nil<br />   (setq DBXBLOCKS (vla-get-blocks dbxDoc))<br />   (vlax-for BLK        DBXBLOCKS<br />     (if        (and (not (wcmatch (substr (vla-get-name BLK) 1 1) "`*"))<br />              (= (vla-get-isxref BLK) :vlax-false)<br />         )                                ;去除系统块、匿名块和参照类对象<br />       (setq namelst (append namelst (list (vla-get-name BLK))))<br />     )<br />   )<br />   (foreach name        namelst<br />     (setq num (vla-item DBXBLOCKS name))<br />     (vla-copyobjects<br />       dbxDoc<br />       (vlax-safearray-fill<br />         (vlax-make-safearray vlax-vbobject '(0 . 0))<br />         (list num)<br />       )<br />       (vla-get-modelspace<br />         (vla-get-activedocument (vlax-get-acad-object))<br />       )<br />     )<br />   )<br />   (if dbxDoc<br />     (vlax-release-object dbxDoc)<br />   )<br /> )<br />

;;154.8 [功能] 复制非打开文件的特定块至本图
;;示例(CopyBlock "D:\\DrawingA.dwg" "ccd1"),之后输入命令i,就可以看到DrawingA的"ccd1"块在本图中了
;; COPYBLOCK.LSP  Copyright ?999  Tony Tanzillo
;;   http://www.caddzone.com
;;   tony.tanzillo@caddzone.com
(defun CopyBlock (DwgName BlkName / *ACAD* BLOCKS DBXDOC NUM)
  (setq *acad* (vlax-get-acad-object))
  (setq blocks (vla-get-blocks (vla-get-ActiveDocument *acad*)))
  (setq dbxDoc (vla-GetInterfaceObject *acad* (GetObjectDBXVer)))
  (vla-open dbxDoc DwgName)
  (setq num (vla-item (vla-get-blocks dbxDoc) BlkName))
  (vla-CopyObjects
    dbxDoc
    (vlax-safearray-fill
      (vlax-make-safearray
        vlax-vbObject
        '(0 . 0)
      )
      (list num)
    )
    blocks
  )
  (vlax-release-object dbxDoc)
  (vla-item blocks BlkName)
)
;;154.9 [功能] 复制特定文件的块至本图(不论打开或者非打开)
;;本程序将选择一个文件,然后将其下的块均拷贝到本图中,用命令i就可以插入这些块了
(defun B2CurDrawing (/ *ACAD* *DOC* *DOCS* FNAME FULLNAME LST)
  (defun Open-copyblocks (fname / BLOCKS DOC DOCBLOCKS NAMELST NUM)
    (setq blocks (vla-get-blocks *DOC*))
    (setq Doc (vla-item        *DOCS*
                        (strcat        (vl-filename-base fname)
                                (vl-filename-extension fname)
                        )
              )
    )
    (setq DocBLOCKS (vla-get-blocks Doc))
    (vlax-for BLK DocBLOCKS
      (if (and (not (wcmatch (substr (vla-get-name BLK) 1 1) "`*"))
               (= (vla-get-isxref BLK) :vlax-false)
          )                                ;去除系统块、匿名块和参照类对象
        (setq namelst (append namelst (list (vla-get-name BLK))))
      )
    )
    (foreach name namelst
      (setq num (vla-item DocBLOCKS name))
      (vla-CopyObjects
        Doc
        (vlax-safearray-fill
          (vlax-make-safearray
            vlax-vbObject
            '(0 . 0)
          )
          (list num)
        )
        blocks
      )
    )
    (vlax-release-object doc)
  )

  (setq        *ACAD* (vlax-get-acad-object)
        *DOC*  (vla-get-ActiveDocument *acad*)
        *DOCS* (vla-get-Documents *ACAD*)
  )
  (setq fullname (vla-get-fullname *DOC*))
  ;;打开文件列表
  (vlax-for doc        *DOCS*
    (setq
      lst (cons        (if (/= (setq fname (vla-get-fullname doc)) "")
                  fname
                  (vla-get-name doc)
                )
                lst
          )
    )
  )
  (setq        fname (getfiled        "选择DWG文件"
                        (strcat (vl-filename-directory fullname) "\\")
                        "DWG"
                        0
              )
  )
  (cond        ((and fname (member fname lst) (not (equal fullname fname)))
         (Open-copyblocks fname)
        )
        ((and fname (not (member fname lst)))
         (Odbx-copyblocks fname)
        )
        (T nil)
  )
  (princ)
)

qingbo9818

还有多少？

xiaxiang

为什么不在一楼更新呢？差点没找到。。。

hhhlike

学习一下

xiaxiang

没有问题的，在一楼更新附件，下过的就不会重复收币，小菜选择易就是最经典的例子

clh521

经典，经典

Atsai

建议楼主可在一楼统一更新，

这样小弟才比较不会有遗漏，赞啦！

namezg

支持楼主l希望楼主多发精品好帖.....

jh1005

很实用的函数，谢谢分享。

USER2128

精彩贴，差点被遗漏！谢谢大虾们！