视口的图层解冻的VLA方法

st788796 · 发表于 2013-10-7 12:20:47

翔版主还没有整出来？

炫翔 · 发表于 2013-10-7 16:14:30

st788796 发表于 2013-10-7 12:20
翔版主还没有整出来？

惭愧，没有呢！本来是测试一实例用的，
花了几天时间研究，整的晕乎乎的，
打算放弃了！

eachy · 发表于 2013-10-7 16:49:35

炫翔发表于 2013-10-7 16:14
惭愧，没有呢！本来是测试一实例用的，
花了几天时间研究，整的晕乎乎的，
打算放弃了！

不会吧, 半成品

(defun CopyForViewport (OldVp lyrlst / properties pSp nVp xd xt)
;|(defun Position (index lst / i l)
(setq i 0)
(foreach x lst
(if (= x index)
(setq l (cons i l))
)
(setq i (1+ i))
)
(reverse l)
)|;
(setq properties
'("Center" "CustomScale" "Direction"
"DisplayLocked" "EntityTransparency"
"Height" "GridOn" "Layer"
"LensLength" "Linetype" "LinetypeScale"
"Lineweight" "Material" "PlotStyleName"
"SnapBasePoint" "SnapOn" "SnapRotationAngle"
"StandardScale" "StandardScale2" "Target"
"TrueColor" "TwistAngle" "UCSIconAtOrigin"
"UCSIconOn" "Visible" "VisualStyle"
"Width"
)
)
(mapcar '(lambda (x)
(set (read x) (vlax-get-property oldvp x))
)
properties
)
(setq pSp (vla-get-PaperSpace
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
nVp (vla-AddPViewport
pSp
center
width
height
)
)
(vla-getxdata oldvp "ACAD" 'xt 'xd)
(mapcar '(lambda (x)
(vl-catch-all-apply
'vlax-put-property
(list nVp x (eval (read x)))
)
)
properties
)
;|(mapcar '(lambda (x) (set (read x) nil)) properties)
(setq xt (safearray-value xt)
xd (safearray-value xd)
i (vl-position 1003 xt)
)
(mapcar '(lambda (x y)
(cons x (variant-value y))
)
xt
xd
)|;
(vla-setxdata nVp xt xd)
(vla-display nVp :vlax-false)
(vla-display nVp :vlax-true)
nVp
)

(defun CopyForViewport (OldVp lyrlst / properties pSp nVp xd xt) 
  ;|(defun Position (index lst / i l) 
    (setq i 0) 
    (foreach x lst 
      (if (= x index) 
    (setq l (cons i l)) 
      ) 
      (setq i (1+ i)) 
    ) 
    (reverse l) 
  )|;    
  (setq    properties 
     '("Center"          "CustomScale"     "Direction" 
       "DisplayLocked"    "EntityTransparency" 
       "Height"          "GridOn"         "Layer" 
       "LensLength"          "Linetype"     "LinetypeScale" 
       "Lineweight"          "Material"     "PlotStyleName" 
       "SnapBasePoint"    "SnapOn"         "SnapRotationAngle" 
       "StandardScale"    "StandardScale2"     "Target" 
       "TrueColor"          "TwistAngle"     "UCSIconAtOrigin" 
       "UCSIconOn"          "Visible"         "VisualStyle" 
       "Width" 
      ) 
  ) 
  (mapcar '(lambda (x) 
         (set (read x) (vlax-get-property oldvp x)) 
       ) 
      properties 
  ) 
  (setq    pSp (vla-get-PaperSpace 
          (vla-get-ActiveDocument 
        (vlax-get-acad-object) 
          ) 
        ) 
    nVp (vla-AddPViewport 
          pSp 
          center 
          width 
          height 
        ) 
  ) 
  (vla-getxdata oldvp "ACAD" 'xt 'xd) 
  (mapcar '(lambda (x) 
         (vl-catch-all-apply 
           'vlax-put-property 
           (list nVp x (eval (read x))) 
         ) 
       ) 
      properties 
  ) 
  ;|(mapcar '(lambda (x) (set (read x) nil)) properties) 
  (setq    xt (safearray-value xt) 
    xd (safearray-value xd) 
    i (vl-position 1003 xt) 
  ) 
  (mapcar '(lambda (x y) 
         (cons x (variant-value y)) 
       ) 
      xt 
      xd 
  )|; 
  (vla-setxdata nVp xt xd) 
   
  (vla-display nVp :vlax-false) 
  (vla-display nVp :vlax-true) 
  nVp 
)

eachy · 发表于 2013-10-8 08:03:36

把上面的函数完善了, 翔版测试下, 这样解冻尚未考虑视口的图层替代、视口裁减，仅作为 Lisp 应用探讨

;;Author: eachy From www.xdcad.net 2013.10.8
(defun Vp:GetFrzLayer (VpObj / xt xd lyrlst)
(vla-getxdata VpObj "ACAD" 'xt 'xd)
(mapcar '(lambda (a b)
(if (= a 1003)
(setq lyrlst (cons (variant-value y) lyrlst))
)
)
(safearray-value xt)
(safearray-value xd)
)
lyrlst
)
(defun Vp:FrzLayer (VpObj lyrlst / xt xd flyr)
(vla-getxdata VpObj "ACAD" 'xt 'xd)
(setq flyr (mapcar '(lambda (lyr)
(list (vlax-make-variant
1003
vlax-vbinteger
)
(vlax-make-variant lyr vlax-vbString)
)
)
lyrlst
)
xt (reverse (safearray-value xt))
xd (reverse (safearray-value xd))
)
(vla-setxdata
VpObj
"ACAD"
(vlax-make-variant
(reverse (append (list (car xt) (cadr xt))
(mapcar 'car flyr)
(list (cdddr xt))
)
)
)
(vlax-make-variant
(reverse (append (list (car xd)
(cadr xd)
(mapcar 'cadr flyr)
(list (cdddr xd))
)
)
)
)
)
)
(defun Vp:ThwLayer (VpObj lyrlst / properties pSp nVp oldFrzlyr)
(setq properties
'("Center" "CustomScale" "Direction"
"DisplayLocked" "EntityTransparency"
"Height" "GridOn" "Layer"
"LensLength" "Linetype" "LinetypeScale"
"Lineweight" "Material" "PlotStyleName"
"SnapBasePoint" "SnapOn" "SnapRotationAngle"
"StandardScale" "StandardScale2" "Target"
"TrueColor" "TwistAngle" "UCSIconAtOrigin"
"UCSIconOn" "Visible" "VisualStyle"
"Width"
)
)
(mapcar '(lambda (x)
(set (read x) (vlax-get-property oldvp x))
)
properties
)
(setq pSp (vla-get-PaperSpace
(vla-get-ActiveDocument
(vlax-get-acad-object)
)
)
nVp (vla-AddPViewport
pSp
center
width
height
)
)
(setq oldFrzlyr (Vp:GetFrzlayer VpObj))
(mapcar '(lambda (x) (vl-remove x oldFrzlyr)) lyrlst)
(mapcar '(lambda (x)
(vl-catch-all-apply
'vlax-put-property
(list nVp x (eval (read x)))
)
)
properties
)
(if oldFrzlyr
(Vp:Frzlayer nVp oldFrzlyr)
)
(vla-display nVp :vlax-false)
(vla-display nVp :vlax-true)
;;nVp
)

;;Author: eachy From www.xdcad.net 2013.10.8 
(defun Vp:GetFrzLayer (VpObj / xt xd lyrlst) 
  (vla-getxdata VpObj "ACAD" 'xt 'xd) 
  (mapcar '(lambda (a b) 
             (if (= a 1003) 
               (setq lyrlst (cons (variant-value y) lyrlst)) 
             ) 
           ) 
          (safearray-value xt) 
          (safearray-value xd) 
  ) 
  lyrlst 
) 
(defun Vp:FrzLayer (VpObj lyrlst / xt xd flyr) 
  (vla-getxdata VpObj "ACAD" 'xt 'xd) 
  (setq        flyr (mapcar '(lambda (lyr) 
                        (list (vlax-make-variant 
                                1003 
                                vlax-vbinteger 
                              ) 
                              (vlax-make-variant lyr vlax-vbString) 
                        ) 
                      ) 
                     lyrlst 
             ) 
        xt   (reverse (safearray-value xt)) 
        xd   (reverse (safearray-value xd)) 
  ) 
  (vla-setxdata 
    VpObj 
    "ACAD" 
    (vlax-make-variant 
      (reverse (append (list (car xt) (cadr xt)) 
                       (mapcar 'car flyr) 
                       (list (cdddr xt)) 
               ) 
      ) 
    ) 
    (vlax-make-variant 
      (reverse (append (list (car xd) 
                             (cadr xd) 
                             (mapcar 'cadr flyr) 
                             (list (cdddr xd)) 
                       ) 
               ) 
      ) 
    ) 
  ) 
) 
(defun Vp:ThwLayer (VpObj lyrlst / properties pSp nVp oldFrzlyr) 
  (setq        properties 
         '("Center"              "CustomScale"         "Direction" 
           "DisplayLocked"    "EntityTransparency" 
           "Height"              "GridOn"                 "Layer" 
           "LensLength"              "Linetype"         "LinetypeScale" 
           "Lineweight"              "Material"         "PlotStyleName" 
           "SnapBasePoint"    "SnapOn"                 "SnapRotationAngle" 
           "StandardScale"    "StandardScale2"         "Target" 
           "TrueColor"              "TwistAngle"         "UCSIconAtOrigin" 
           "UCSIconOn"              "Visible"                 "VisualStyle" 
           "Width" 
          ) 
  ) 
  (mapcar '(lambda (x) 
             (set (read x) (vlax-get-property oldvp x)) 
           ) 
          properties 
  ) 
  (setq        pSp (vla-get-PaperSpace 
              (vla-get-ActiveDocument 
                (vlax-get-acad-object) 
              ) 
            ) 
        nVp (vla-AddPViewport 
              pSp 
              center 
              width 
              height 
            ) 
  ) 
  (setq oldFrzlyr (Vp:GetFrzlayer VpObj)) 
  (mapcar '(lambda (x) (vl-remove x oldFrzlyr)) lyrlst) 
  (mapcar '(lambda (x) 
             (vl-catch-all-apply 
               'vlax-put-property 
               (list nVp x (eval (read x))) 
             ) 
           ) 
          properties 
  ) 
  (if oldFrzlyr 
    (Vp:Frzlayer nVp oldFrzlyr) 
  ) 
  (vla-display nVp :vlax-false) 
  (vla-display nVp :vlax-true) 
  ;;nVp 
)

st788796 · 发表于 2013-10-8 13:02:41

本帖最后由 st788796 于 2013-10-8 13:13 编辑

测试有问题，setxdata 参数是 safearray 不是 variant，不能用vlax-make-variant
(vlax-safearray-fill (vlax-make-safearry vlax-vbinteger (cons 0 (1- (length xt)))) xt)
(vlax-safearray-fill (vlax-make-safearray vlax-vbvariant (cons 0 (1- (length xd)))) xd)

kcad2010 · 发表于 2013-10-29 11:58:03

提示: 作者被禁止或删除内容自动屏蔽

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

kcad2010 kcad2010 当前离线 UID 677304 积分 391 精华贡献威望活跃度 D豆在线时间小时注册时间 2013-6-7 最后登录 1970-1-1 窥视卡雷达卡已领礼包: 182个财富等级: 日进斗金	发表于 2013-10-29 11:58:03 \| 显示全部楼层提示: 作者被禁止或删除内容自动屏蔽
	论坛插件加载方法发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
	回复支持反对使用道具举报

[研讨] 视口的图层解冻的VLA方法

点评

点评

评分

评分