明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 371|回复: 2

急求优化自动图层转换工具,RMB开发

[复制链接]
发表于 2024-5-15 22:16 | 显示全部楼层 |阅读模式
本帖最后由 wushilin 于 2024-5-16 18:05 编辑

附件是之前明经大神创作的,原版本只能加载到32位CAD2006上,64位CAD2016加载不上去,求大神修改下能够加载到64位CAD2016,付费开发,价格合理联系QQ86875370

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2024-5-17 19:05 | 显示全部楼层
(defun xlr-autolayer ()
  (vl-load-com)
  ;; 图层初始化列表 内容:commands layers color linetype plottable
  (setq *doc (vla-get-activedocument (vlax-get-acad-object)))
  (setq *lays (vla-get-layers *doc))
  (setq        *laylst
         (list (list "DIMANGULAR" "PUB_DIM" 136 "continuous" T)
               (list "DIMALIGNED" "PUB_DIM" 136 "continuous" T)
               (list "DIMBASELINE" "PUB_DIM" 136 "continuous" T)
               (list "DIMCENTER" "PUB_DIM" 136 "continuous" T)
               (list "DIMCONTINUE" "PUB_DIM" 136 "continuous" T)
               (list "DIMDIAMETER" "PUB_DIM" 136 "continuous" T)
               (list "DIMLINEAR" "PUB_DIM" 136 "continuous" T)
               (list "DIMORDINATE" "PUB_DIM" 136 "continuous" T)
               (list "DIMRADIUS" "PUB_DIM" 136 "continuous" T)
               (list "QDIM" "PUB_DIM" 136 "continuous" T)
               (list "QLEADER" "PUB_DIM" 136 "continuous" T)
               (list "BHATCH" "PUB_HATCH" 8 "continuous" T)
               (list "HATCH" "PUB_HATCH" 8 "continuous" T)                                       
         )
  )
  (setq OldLayer nil)
  (setq *cmdlst (mapcar 'strcase (mapcar 'car *laylst)))
  (mapcar '(lambda (x) (vlr-command-reactor nil x))
          (list        '((:vlr-commandWillStart . xlr-start))
                '((:vlr-commandEnded . xlr-end))
                '((:vlr-commandCancelled . xlr-cancel))
          )
  )
  (vlr-editor-reactor
    nil
    '((:vlr-commandwillstart . xlr-edit))
  )
)
;;;----------------------------------------------------------------------------;;;
(defun xlr-edit        (CALL CALLBACK /)
  (foreach N *laylst
    (if        (= (strcase (car CALLBACK)) (strcase (car N)))
                                        ; 命令反应器返回信息如果与设置的命令相同.
      (progn                                ;建立图层

        (apply 'xsetlays (cdr N))
                                        ;(setvar "CLAYER" (cadr N));设为当前层.
      )
    )
  )
)
;;;----------------------------------------------------------------------------;;;
(defun xlr-start (calling-reactor xlr-startInfo /)
  (foreach N *laylst
    (if        (= (strcase (car xlr-startInfo)) (strcase (car N)))
                                        ; 命令反应器返回信息如果与设置的命令相同.
      (progn                                ;建立图层

        (apply 'xsetlays (cdr N))
                                        ;(setvar "CLAYER" (cadr N));设为当前层.
      )
    )
  )
)
;;;----------------------------------------------------------------------------;;;
(defun xlr-end (calling-reactor xlr-endInfo / cmd)
  (setq cmd (car xlr-endInfo))
  (if (member cmd *cmdlst)
    (if (/= oldlayer nil)
       (progn
           (setvar "CLAYER" OldLayer)
           (setq OldLayer nil)
       )
    )
  )
)
;;;----------------------------------------------------------------------------;;;
(defun xlr-cancel (calling-reactor xlr-cancelInfo / cmd)
  (setq cmd (car xlr-cancelInfo))
  (if (member cmd *cmdlst)
    (if (/= oldlayer nil)
       (progn
           (setvar "CLAYER" OldLayer)
           (setq OldLayer nil)
       )
    )
  )
)
;;;----------------------------------------------------------------------------;;;
;;;----------------------------------------------------------------------------;;;
(defun xsetlays        (LAY-NAM COLOR LTYPE plotk / LAYOBJ LTYPESOBJ)

  (if (tblobjname "layer" LAY-NAM)
    (progn
      (if (/= (strcase (getvar "CLAYER"))
              (strcase LAY-NAM)
          )
        (setq OldLayer (getvar "CLAYER"))
        (progn
          (if (= oldlayer nil)
            (setq OldLayer LAY-NAM)
          )
        )
      )
      (setvar "CLAYER" lay-nam)
    )
    (progn                                ;添加图层.
      (vl-catch-all-error-p
        (vl-catch-all-apply 'vla-add (list *lays LAY-NAM))
      )
      (setq LAYOBJ (vla-item *lays LAY-NAM))
      (if (not (tblobjname "ltype" LTYPE)) ;添加线型.
        (progn
          (setq LTYPESOBJ (vla-get-linetypes *doc))
          (vla-load LTYPESOBJ LTYPE (findfile "acad.lin"))
                                        ;>>> 要加强,在多个*.lin寻找
          (vlax-release-object LTYPESOBJ)
        )
      )                                        ;解冻(如冻结),解锁,设图层为当前,设图层颜色,可打印特性.
      (vla-put-layeron layobj :vlax-true)
      (vla-put-lock layobj :vlax-false)
      (if (= (strcase (getvar "CLAYER")) (strcase lay-nam)) ;解冻.
        (vla-put-freeze layobj :vlax-false)
      )
      (vla-put-color layobj color)
      (vla-put-linetype layobj LTYPE)
      (vla-put-plottable
        layobj
        (if plotk
          :vlax-true
          :vlax-false
        )
      )
    )
  )
)
(xlr-autolayer)                                ;加载启动!
(princ "\n ----命令图层反应器已加载----")
发表于 2024-5-19 22:30 | 显示全部楼层
简单说一下vba的功能是什么?
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-6-15 14:47 , Processed in 0.152732 second(s), 23 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表