[原创]导入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

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

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

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

本帖最后由作者于 2007-5-11 11:56:18 编辑 全扔出来，呵呵。 可能还涉及到其它的一些函数，发现再添加吧。添加了对下一级组过滤器的处理。  更新一下，处理了子过滤器，并提供了过滤器查询函数。;;; 函数列表 ;;; GetAclyLayers  得到指定图层组过滤器中的层。 ;;; DeleteAllLayerFilters 删除所有图层特性过滤器。 ;;; DeleteAllAclyDictionary 删除所有图层组过滤器。;;; 函数列表 ;;; 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文档中的图层组过滤器。;;; 函数列表 ;;; EdataUpdate 更新对象数据 ;;; *break* 中断程序。

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

感谢版主程序，学习一下

页: [1]

明经CAD社区's Archiver

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