社区 › 源码共享 › 分享几个VL程序

tukuitk 发表于 2007-1-6 11:18:00

分享几个VL程序

DisplayProperties;;; Copyright (C) 1997-2006 JTB World, All Rights Reserved

(vl-load-com)

; Get Model Space Background Color
(defun getMoBgColor()
(ole_color
    (vla-get-GraphicsWinModelBackgrndColor
      (vla-get-display (vla-get-preferences (vlax-get-acad-object)))))
)

; Get Layout Space Background Color
(defun getLaBgColor()
(ole_color
    (vla-get-GraphicsWinLayoutBackgrndColor
      (vla-get-display (vla-get-preferences (vlax-get-acad-object)))))
)

; Put Model Space Background Color
(defun putMoBgColor(bgc)
(vla-put-GraphicsWinModelBackgrndColor
    (vla-get-display (vla-get-preferences (vlax-get-acad-object)))
    bgc
)
)

; Put Layout Space Background Color
(defun putLaBgColor(bgc)
(vla-put-GraphicsWinLayoutBackgrndColor
    (vla-get-display (vla-get-preferences (vlax-get-acad-object)))
    bgc
)
)

(defun ole_color(olec)
(vlax-variant-value
    (vlax-variant-change-type olec vlax-vbDouble)
)
)

; Get the display of the Plot Setup dialog when a new layout is created.
(defun getLayoutShowPlotSetup()
(vla-get-LayoutShowPlotSetup
    (vla-get-display (vla-get-preferences (vlax-get-acad-object))))
)

; Put the display of the Plot Setup dialog when a new layout is created.
(defun putLayoutShowPlotSetup(state)
(vla-put-LayoutShowPlotSetup
    (vla-get-display (vla-get-preferences (vlax-get-acad-object))) state)
)

; Toggles the display of the Plot Setup dialog when a new layout is created.
(defun toggleLayoutShowPlotSetup()
(if (= (getLayoutShowPlotSetup) :vlax-true)
    (putLayoutShowPlotSetup :vlax-false)
    (putLayoutShowPlotSetup :vlax-true)
)
)

;;; Change all text styles on all objects to specified text style;;; (ax:ChangeTextStyleName "ISOCPEUR")(defun ax:ChangeTextStyleName (style / sset ename i)(vl-load-com)(setq i 0)(setq sset (ssget "X" '((-4 . "<OR") (0 . "MTEXT") (0 . "TEXT") (-4 . "OR>"))))(if sset    (repeat (sslength sset)      (setq ename (ssname sset i))      (setq i (1+ i))      (vla-put-stylename (vlax-ename->vla-object ename) style)    )))

Zoom extents in all viewports(defun c:zoome (/ oldcmdecho vplist curcvport nr vpss ms en x)
(setq oldcmdecho (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq vplist (mapcar 'car (vports)))
(setq curcvport (getvar "cvport"))
(if (= (getvar "tilemode") 0)
    (progn
      (if (= (setq ms (getvar "cvport")) 1)
      (command "._mspace")
      )
      (setq vpss (ssget "_x"
                        (list '(-4 . "<AND")
                              '(0 . "VIEWPORT")
                              (cons 410 (getvar "ctab"))
                              '(-4 . "<NOT")
                              '(69 . 1)
                              '(-4 . "NOT>")
                              '(-4 . "AND>")
                        )
               )
      )
      (setq nr 0)
      (if vpss                        ; in case there are no viewports
      (repeat (sslength vpss)
          (setq en (entget (ssname vpss nr)))
          (if (and (= 0 (logand 1 (cdr (assoc 90 en))))
                                        ; not perspective
                   (< 0 (cdr (assoc 68 en))) ; on and active
                   (/= 16384 (logand 16384 (cdr (assoc 90 en))))
                                        ; not locked
            )
            (progn
            (setvar "cvport" (cdr (assoc 69 en)))
            (command "._zoom" "_e")
            )
          )
          (setq nr (+ 1 nr))
      )
      )
      (if (= ms 1) (command "._pspace"))
    )
    (foreach x vplist
      (setvar "cvport" x)
      (command "._zoom" "_e")
    )
)
(setvar "cvport" curcvport)
(setvar "cmdecho" oldcmdecho)
(princ)
)

大西瓜 发表于 2024-4-27 21:37:38

虽然帖子有些久远了，感谢阁主无私奉献

l982414603 发表于 2020-7-12 09:46:35

是啥程序？请介绍一下。

xlh0 发表于 2007-1-15 11:40:00

谢谢分享！！！！

fly_902 发表于 2007-9-4 15:03:00

<p>不错, 谢谢楼主分享</p>

mingvictor 发表于 2007-10-7 20:06:00

谢谢楼主！

dym123456 发表于 2008-3-23 20:33:00

我试一下，不错, 谢谢楼主分享！！

zgssd 发表于 2008-9-21 11:02:00

是啥程序？请介绍一下。

chern0228 发表于 2008-10-11 17:02:00

<p>不错, 谢谢楼主分享</p>

lqss 发表于 2008-10-11 17:04:00

干什么用的程序啊？

waterchen 发表于 2009-6-26 10:22:00

<p>不错, 谢谢楼主分享</p>

明_明 发表于 2009-6-30 12:29:00

谢谢分享

查看完整版本: 分享几个VL程序