[原创]导入DBX文档中的图层组过滤器

lockmyeye · 发表于 2007-5-10 12:40:00

本帖最后由作者于 2007-5-10 12:44:18 编辑

图层组过滤器很适合在项目中使用。
但插入已经定义好过滤器的DWG文件时，不能插入组过滤器。
在网上只有删除组过滤器的，找不到创建组过滤器的代码。
So，写了下面的代码。

;;;==============================================================================
;;; 函数名： ImportDbxAclyDictionary
;;; 功能：导入DBX文档中的图层组过滤器。
;;; 作者：陈Q
;;; 日期： 2007-05-05
;;; 版本： 1.00
;;; 参数类型
;;; DbxDoc DBX文档对象。
;;; 返回值：
;;; 无
;;; 调试：
;;; (setq DbxDoc (OpenDbxDocument (findfile (LuGetDefine "模板文件"))))
;;; (ImportDbxLayers DbxDoc)
;;; (ImportDbxAclyDictionary DbxDoc)
;;; (CloseDbxDocFromument DbxDoc)
;;; 修改历史纪录
;;; 版本修改时间修改人修改内容
;;;==============================================================================
(defun ImportDbxAclyDictionary (DbxDoc / AssocLst ColFrom ColTo DbxDocTo DictName Edata ExDictFrom ExDictTo LayerLst Layers Types Values XrecName)
(setq DictName "ACLYDICTIONARY"
DbxDocTo (vla-get-activedocument (vlax-get-acad-object))
ExDictFrom (vla-getextensiondictionary (vla-get-layers DbxDoc))
ExDictTo (vla-getextensiondictionary (vla-get-layers DbxDocTo))
ColFrom (vl-catch-all-apply 'vla-item (list ExDictFrom DictName))
ColTo (vl-catch-all-apply 'vla-item (list ExDictTo DictName))
) ;_ End setq
;; DBX文档中含在对象时才处理。
(if (not (vl-catch-all-error-p ColFrom))
(progn
;; 读取图层数据。
(setq LayerLst nil)
(vlax-for ObjLayer (vla-get-layers DbxDocTo)
(setq LayerLst (cons (list (vla-get-name ObjLayer) (vlax-vla-object->ename ObjLayer)) LayerLst))
) ;_ End vlax-for
;; 当前文档没有该对象时，先创建。
(if (vl-catch-all-error-p ColTo)
(setq ColTo (vla-addobject ExDictTo DictName "AcDbDictionary"))
) ;_ End if
;; 复制过滤器
;; 调试 (setq FilterFrom (vla-item ColFrom 1))
(vlax-for FilterFrom ColFrom
(vla-getxrecorddata FilterFrom 'Types 'Values)
(setq Types (vlax-safearray->list Types)
Values (vlax-safearray->list Values)
AssocLst (mapcar 'cons Types Values)
XrecName (vlax-variant-value (cdr (assoc 300 AssocLst)))
Layers (vl-remove-if-not (function (lambda (_x) (= 330 (car _x)))) AssocLst)
Layers (mapcar (function
(lambda (_x)
(vla-get-name
(vla-objectidtoobject DbxDocTo (car (vlax-safearray->list (vlax-variant-value (cdr _x)))))
) ;_ End vla-get-name
) ;_ End lambda
) ;_ End function
Layers
) ;_ End mapcar
;; 创建对象。
Edata (entget (vlax-vla-object->ename (vla-addxrecord ColTo XrecName)))
Edata (append Edata
(list '(1 . "AcLyLayerGroup") '(90 . 1) (cons 300 XrecName))
(mapcar (function (lambda (_x)
(if (setq _x (cadr (assoc _x LayerLst)))
(cons 330 _x)
(*break* (strcat "缺省图层【" _x "】。"))
) ;_ End if
) ;_ End lambda
) ;_ End function
Layers
) ;_ End mapcar
) ;_ End append
) ;_ End setq
;; 更新对象。
(if (not (entmod Edata))
(*break* (strcat "不能更新对象数据【" (vl-princ-to-string Edata) "】。"))
) ;_ End if
) ;_ End vlax-for
) ;_ End progn
) ;_ End if
) ;_ End defun

;;;==============================================================================
;;; 函数名： ImportDbxAclyDictionary
;;; 功  能： 导入DBX文档中的图层组过滤器。
;;; 作  者： 陈Q
;;; 日  期： 2007-05-05
;;; 版  本： 1.00
;;; 参数     类型
;;;  DbxDoc DBX文档对象。
;;; 返回值：
;;;  无
;;; 调  试： 
;;; (setq DbxDoc (OpenDbxDocument (findfile (LuGetDefine "模板文件"))))
;;; (ImportDbxLayers DbxDoc)
;;; (ImportDbxAclyDictionary DbxDoc)
;;; (CloseDbxDocFromument DbxDoc)
;;; 修改历史纪录
;;; 版本 修改时间 修改人 修改内容
;;;==============================================================================
(defun ImportDbxAclyDictionary (DbxDoc / AssocLst ColFrom ColTo DbxDocTo DictName Edata ExDictFrom ExDictTo LayerLst Layers Types Values XrecName)
  (setq DictName   "ACLYDICTIONARY"
 DbxDocTo   (vla-get-activedocument (vlax-get-acad-object))
 ExDictFrom (vla-getextensiondictionary (vla-get-layers DbxDoc))
 ExDictTo   (vla-getextensiondictionary (vla-get-layers DbxDocTo))
 ColFrom    (vl-catch-all-apply 'vla-item (list ExDictFrom DictName))
 ColTo    (vl-catch-all-apply 'vla-item (list ExDictTo DictName))
  ) ;_ End setq
  ;; DBX文档中含在对象时才处理。
  (if (not (vl-catch-all-error-p ColFrom))
    (progn
      ;; 读取图层数据。
      (setq LayerLst nil)
      (vlax-for ObjLayer (vla-get-layers DbxDocTo)
 (setq LayerLst (cons (list (vla-get-name ObjLayer) (vlax-vla-object->ename ObjLayer)) LayerLst))
      ) ;_ End vlax-for
      ;; 当前文档没有该对象时，先创建。
      (if (vl-catch-all-error-p ColTo)
 (setq ColTo (vla-addobject ExDictTo DictName "AcDbDictionary"))
      ) ;_ End if
      ;; 复制过滤器
      ;; 调试 (setq FilterFrom (vla-item ColFrom 1))
      (vlax-for FilterFrom ColFrom
 (vla-getxrecorddata FilterFrom 'Types 'Values)
 (setq Types    (vlax-safearray->list Types)
       Values   (vlax-safearray->list Values)
       AssocLst (mapcar 'cons Types Values)
       XrecName (vlax-variant-value (cdr (assoc 300 AssocLst)))
       Layers   (vl-remove-if-not (function (lambda (_x) (= 330 (car _x)))) AssocLst)
       Layers   (mapcar (function
     (lambda (_x)
       (vla-get-name
         (vla-objectidtoobject DbxDocTo (car (vlax-safearray->list (vlax-variant-value (cdr _x)))))
       ) ;_ End vla-get-name
     ) ;_ End lambda
          ) ;_ End function
          Layers
         ) ;_ End mapcar
       ;; 创建对象。
       Edata    (entget (vlax-vla-object->ename (vla-addxrecord ColTo XrecName)))
       Edata    (append Edata
          (list '(1 . "AcLyLayerGroup") '(90 . 1) (cons 300 XrecName))
          (mapcar (function (lambda (_x)
         (if (setq _x (cadr (assoc _x LayerLst)))
           (cons 330 _x)
           (*break* (strcat "缺省图层【" _x "】。"))
         ) ;_ End if
       ) ;_ End lambda
           ) ;_ End function
           Layers
          ) ;_ End mapcar
         ) ;_ End append
 ) ;_ End setq
 ;; 更新对象。
 (if (not (entmod Edata))
   (*break* (strcat "不能更新对象数据【" (vl-princ-to-string Edata) "】。"))
 ) ;_ End if
      ) ;_ End vlax-for
    ) ;_ End progn
  ) ;_ End if
) ;_ End defun

龙龙仔 · 发表于 2007-5-10 17:06:00

把所有要用到的函數貼上,並寫完整點好嗎?謝謝!

lockmyeye · 发表于 2007-5-10 18:26:00

本帖最后由作者于 2007-5-11 11:56:18 编辑

全扔出来，呵呵。
可能还涉及到其它的一些函数，发现再添加吧。

添加了对下一级组过滤器的处理。

更新一下，处理了子过滤器，并提供了过滤器查询函数。[2007-05-11]

;;; 函数列表[CommonDictionary.lsp]
;;; GetAclyLayers 得到指定图层组过滤器中的层。
;;; DeleteAllLayerFilters 删除所有图层特性过滤器。
;;; DeleteAllAclyDictionary 删除所有图层组过滤器。

;;; 函数列表[CommonObjectDBX.LSP]
;;; DbxRegister   注册ObjectDBX
;;; DllRegister   以静默方式注册一个DLL文件
;;; DllUnRegister  以静默方式卸载一个DLL文件
;;; ProgId->ClassId  返回注册表中指定的ProgId项
;;; DbxGetTable   得到ObjectDBX打开文档中指定的符号表对象
;;; DbxGetTableList  得到ObjectDBX打开文档中指定的符号名称列表
;;; OpenDbxDocument  以DBX方式打开Dwg文件。
;;; CloseDbxDocument  关闭DBX文档。
;;; DbxCopyObjects   复制DBX中的对象到当前图形。
;;; ImportDbxLayers  导入DBX文档中的图层。
;;; ImportDbxBlocks  导入DBX文档中的图块。
;;; ImportDbxTextStyles  导入DBX文档中的文字样式。
;;; ImportDbxLayerFilters 导入DBX文档中的图层特性过滤器。
;;; ImportDbxAclyDictionary 导入DBX文档中的图层组过滤器。

;;; 函数列表[CommonFuntion.lsp]
;;; EdataUpdate 更新对象数据
;;; *break* 中断程序。

灬北方狼灬 · 发表于 2018-4-15 11:25:07

感谢版主程序，学习一下

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

[原创]导入DBX文档中的图层组过滤器

本帖子中包含更多资源

评分