[求助]：有人知道Excel中的Color和ColorIndex同AutoCAD的ACI/TrueColor之间的转换关系

mmmm · 发表于 2003-8-26 11:06:51

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

有人知道Excel中的Color和ColorIndex同AutoCAD的ACI/TrueColor之间的转换关系吗？

eachy · 发表于 2003-8-26 12:38:14

DSX 网站有个程序，改屏幕颜色，里面有对应表。

e2002 · 发表于 2003-8-26 12:47:00

明经那里有

mmmm · 发表于 2003-8-27 09:20:08

都没有找到，请提供具体链接地址，谢谢

eachy · 发表于 2003-8-27 22:57:35

最初由 mmmm 发布
[B]都没有找到，请提供具体链接地址，谢谢 [/B]

<table border="1" cellpadding="0" cellspacing="0" style="border-collapse: collapse" bordercolor="#111111" width="700" id="AutoNumber1" height="498">
<tr>
<td width="100%" height="489">
<iframe name="I1" width="100%" height="100%" src="http://www.jtbworld.com/?/lisp/DisplayColorProperties.htm">
浏览器不支持嵌入式框架或配置为不显示嵌入式框架
</iframe>
</td>
</tr>
</table>

复制代码

<table border="1" cellpadding="0" cellspacing="0" style="border-collapse: collapse" bordercolor="#111111" width="700" id="AutoNumber1" height="498">
<tr>
<td width="100%" height="489">
<iframe name="I1" width="100%" height="100%" src="http://www.menziengineering.ch/Downloads/Download.htm#13">
浏览器不支持嵌入式框架或配置为不显示嵌入式框架
</iframe>
</td>
</tr>
</table>

复制代码

efan2000 · 发表于 2003-9-25 20:12:00

重新将代码整理在下面：

[FONT=courier new]
;;; DisplayColorProperties.LSP
;;; Miscellaneous commands related to Colors on the Display tab on the Options dialog
;;; By Jimmy Bergmark
;;; Website: [url]www.jtbworld.com[/url] / [url]http://jtbworld.vze.com[/url]
;;; E-mail: [email]info@jtbworld.com[/email] / [email]jtbworld@hotmail.com[/email]
;;; 2000-03-29 - First release
;;; 2003-03-07 - Now for AutoCAD 2004
;;; 2003-05-14 - Added ACI to RGB conversion
;;; Tested on AutoCAD 2000, 2000i, 2002 and 2004
;;; Some bugs exist with the conversions of colors from RGB to ACI.
(vl-load-com)
(setq pref (vla-get-preferences (vlax-get-acad-object)))
(setq display (vla-get-display pref))
;;; Set the ModelColor using the color dialog box
(defun c:SetModelColor(/ col oldcol)
(setq oldcol (getGraphicsWinModelBackgrndColor))
(if (= oldcol nil) (setq oldcol 0))
(if (= oldcol 0) (setq oldcol 1))
(setq col (acad_colordlg oldcol nil))
(if (and (= oldcol 7) (= col 7)) (setq col 0))
(if (/= col nil) (putGraphicsWinModelBackgrndColor col))
(princ)
)
(defun c:SetModelColor2004(/ col oldcol)
(setq oldcol (getGraphicsWinModelBackgrndColor2004))
(if (= oldcol nil) (setq oldcol 0))
(if (= oldcol 0) (setq oldcol 1))
(setq col (acad_colordlg oldcol nil))
(if (and (= oldcol 7) (= col 7)) (setq col 0))
(if (/= col nil) (putGraphicsWinModelBackgrndColor col))
(princ)
)
;;; Set the LayoutColor using the color dialog box
(defun c:SetLayoutColor(/ col oldcol)
(setq oldcol (getGraphicsWinLayoutBackgrndColor))
(if (= oldcol nil) (setq oldcol 0))
(if (= oldcol 0) (setq oldcol 1))
(setq col (acad_colordlg oldcol nil))
(if (and (= oldcol 7) (= col 7)) (setq col 0))
(if (/= col nil) (putGraphicsWinLayoutBackgrndColor col))
(princ)
)
(defun getGraphicsWinModelBackgrndColor()
(OLE_color->ACI_color
(vla-get-GraphicsWinModelBackgrndColor
(vla-get-display (vla-get-preferences (vlax-get-acad-object)))))
)
(defun getGraphicsWinModelBackgrndColor2004 ()
(OLE_colorToACI
(vlax-variant-value
(vlax-variant-change-type
(vla-get-GraphicsWinModelBackgrndColor
(vla-get-display
(vla-get-preferences (vlax-get-acad-object))
)
)
vlax-vbLong
)
)
)
)
(defun putGraphicsWinModelBackgrndColor(col)
(vla-put-GraphicsWinModelBackgrndColor
(vla-get-display (vla-get-preferences (vlax-get-acad-object)))
(ACI_color->OLE_color col)
)
)
(defun getGraphicsWinLayoutBackgrndColor()
(OLE_color->ACI_color
(vla-get-GraphicsWinLayoutBackgrndColor
(vla-get-display (vla-get-preferences (vlax-get-acad-object)))))
)
(defun putGraphicsWinLayoutBackgrndColor(col)
(vla-put-GraphicsWinLayoutBackgrndColor
(vla-get-display (vla-get-preferences (vlax-get-acad-object)))
(ACI_color->OLE_color col)
)
)
(defun getModelCrosshairColor()
(OLE_color->ACI_color
(vla-get-ModelCrosshairColor
(vla-get-display (vla-get-preferences (vlax-get-acad-object)))))
)
(defun putModelCrosshairColor(col)
(vla-put-ModelCrosshairColor
(vla-get-display (vla-get-preferences (vlax-get-acad-object)))
(ACI_color->OLE_color col)
)
)
(defun getLayoutCrosshairColor()
(OLE_color->ACI_color
(vla-get-LayoutCrosshairColor
(vla-get-display (vla-get-preferences (vlax-get-acad-object)))))
)
(defun putLayoutCrosshairColor(col)
(vla-put-LayoutCrosshairColor
(vla-get-display (vla-get-preferences (vlax-get-acad-object)))
(ACI_color->OLE_color col)
)
)
(defun getTextWinBackgrndColor()
(OLE_color->ACI_color
(vla-get-TextWinBackgrndColor
(vla-get-display (vla-get-preferences (vlax-get-acad-object)))))
)
(defun putTextWinBackgrndColor(col)
(vla-put-TextWinBackgrndColor
(vla-get-display (vla-get-preferences (vlax-get-acad-object)))
(ACI_color->OLE_color col)
)
)
(defun getTextWinTextColor()
(OLE_color->ACI_color
(vla-get-TextWinTextColor
(vla-get-display (vla-get-preferences (vlax-get-acad-object)))))
)
(defun putTextWinTextColor(col)
(vla-put-TextWinTextColor
(vla-get-display (vla-get-preferences (vlax-get-acad-object)))
(ACI_color->OLE_color col)
)
)
(defun getAutoTrackingVecColor()
(OLE_color->ACI_color
(vla-get-AutoTrackingVecColor
display))
)
(defun putAutoTrackingVecColor(col)
(vla-put-AutoTrackingVecColor
display
(ACI_color->OLE_color col)
)
)
(defun OLE_color->ACI_color (olec)
(vl-position
(boole 1
(vlax-variant-value
(vlax-variant-change-type olec vlax-vbLong)
)
16777215
)
OLE_COLOR_LIST
)
)
(defun ACI_color->OLE_color (aci)
; black is 0
; white is 7
(if (and (>= aci 0) (<= 255))
(setq aci (nth aci OLE_COLOR_LIST)
)
)
)
(setq OLE_COLOR_LIST
'(0 255 65535 65280 16776960
16711680 16711935 16777215 8421504 12632256
255 8421631 166 5460902 128
4210816 76 2500172 38 1250086
16639 8429567 10662 5466278 8320
4214912 4940 2502732 2598 1251366
33023 8437759 21414 5471398 16512
4219008 9804 2505036 4902 1252646
49151 8445951 31910 5476774 24704
4223104 14668 2507596 7462 1253670
65535 8454143 42662 5482150 32896
4227200 19532 2509900 9766 1254950
65471 8454111 42620 5482129 32864
4227184 19513 2509891 9757 1254945
65408 8454079 42579 5482108 32832
4227168 19494 2509881 9747 1254941
65344 8454047 42537 5482088 32800
4227152 19475 2509872 9738 1254936
65280 8454016 42496 5482067 32768
4227136 19456 2509862 9728 1254931
4259584 10485632 2729472 6858323 2129920
5275712 1264640 3165222 665088 1582611
8453888 12582784 5481984 8169043 4227072
6324288 2509824 3755046 1254912 1910291
12582656 14679936 8168960 9545299 6324224
7372864 3755008 4410406 1910272 2172435
16776960 16777088 10921472 10921555 8421376
8421440 5000192 5000230 2500096 2500115
16760576 16768896 10910720 10916179 8413184
8417344 4995328 4997926 2497792 2498835
16744448 16760704 10900224 10910803 8404992
8413248 4990464 4995366 2495232 2497811
16728064 16752512 10889472 10905683 8396800
8409152 4985600 4993062 2492928 2496531
16711680 16744576 10878976 10900307 8388608
8405056 4980736 4990502 2490368 2495251
16711744 16744607 10879017 10900328 8388640
8405072 4980755 4990512 2490378 2495256
16711808 16744639 10879059 10900348 8388672
8405088 4980774 4990521 2490387 2495261
16711871 16744671 10879100 10900369 8388704
8405104 4980793 4990531 2490397 2495265
16711935 16744703 10879142 10900390 8388736
8405120 4980812 4990540 2490406 2495270
12517631 14647551 8126630 9524134 6291584
7356544 3735628 4400716 1900582 2167590
8388863 12550399 5439654 8147878 4194432
6307968 2490444 3745356 1245222 1905446
4194559 10453247 2687142 6837158 2097280
5259392 1245260 3155532 655398 1577766
5526612 5987163 10000536 12303291 14540253
16777215
)
)
;;; Only for AutoCAD 2004
(defun RGBtoACI (RGB-codes)
(vl-load-com)
(setq ColorObj (vla-GetInterfaceObject
(vlax-get-acad-object)
"AutoCAD.AcCmColor.16"
)
)
(vla-setRGB ColorObj (car RGB-codes) (cadr RGB-codes) (caddr RGB-codes))
; alternatively done as below
; (vlax-invoke-method ColorObj 'setRGB (car RGB-codes) (cadr RGB-codes) (caddr RGB-codes))
(vla-get-ColorIndex ColorObj)
)
(defun RGBtoOLE_color2 (RGB-codes)
(+ (* (car RGB-codes) 65536)
(* (cadr RGB-codes) 256)
(caddr RGB-codes)
)
)
(defun OLEtoRGB_color2 (OLE_color / a b c)
(setq a (fix (/ OLE_color 65536.0)))
(setq b (fix (/ (- OLE_color (* a 65536)) 256.0)))
(setq c (- OLE_color (* a 65536) (* b 256)))
(list a b c)
)
;; Convert TrueColor into a list of RGB
(defun OLEtoRGB_color (OLE_color / r g b)
(setq r (lsh OLE_color -16))
(setq g (lsh (lsh OLE_color 16) -24))
(setq b (lsh (lsh OLE_color 24) -24))
(list r g b)
)
;; Convert a list of RGB to TrueColor
;;; (RGBtoOLE_color '(118 118 118))
(defun RGBtoOLE_color (RGB-codes)
(setq r (lsh (car RGB-codes) 16))
(setq g (lsh (cadr RGB-codes) 8))
(setq b (caddr RGB-codes))
(+ (+ r g) b)
)
; For AutoCAD 2004
; (OLE_colorToACI 5987163) returns 251
(defun OLE_colorToACI (OLE_color)
(RGBtoACI (OLEtoRGB_color OLE_color))
)
(defun C:getColor(/)
(setq ename (car (entsel "\nPick an object with true color:")))
(setq edata (entget ename))
;; we have a true color.
(setq tcol (cdr (assoc 420 edata)))
(princ "\n true color = ")(princ tcol)
;; convert it to a list of RGB.
(setq rgb (OLEtoRGB_color tcol))
(princ "\n rgb = ")(princ rgb)
(princ)
)
(defun C:setColor(/)
(setq ename (car (entsel "\nPick an object to set a true color:")))
(setq edata (entget ename))
;; set a true color from a list of rgb values.(R=10 G=100 B=200)
(setq rgb (list 10 100 200))
(setq tcol (RGBtoOLE_color rgb))
;; and set it.
(setq edata (subst (cons 420 tcol) (assoc 420 edata) edata))
(entmod edata)
(princ "\n rgb = ")(princ rgb)
(princ "\n true color = ")(princ tcol)
(princ)
)
;;; (ACItoRGB 123)
(defun ACItoRGB (aci)
(if (and (>= aci 0) (<= 255))
(nth aci RGB_list)
)
)
(setq RGB_list '(
(0 0 0)
(255 0 0)
(255 255 0)
(0 255 0)
(0 255 255)
(0 0 255)
(255 0 255)
(255 255 255)
(128 128 128)
(192 192 192)
(255 0 0)
(255 127 127)
(165 0 0)
(165 82 82)
(127 0 0)
(127 63 63)
(76 0 0)
(76 38 38)
(38 0 0)
(38 19 19)
(255 63 0)
(255 159 127)
(165 41 0)
(165 103 82)
(127 31 0)
(127 79 63)
(76 19 0)
(76 47 38)
(38 9 0)
(38 23 19)
(255 127 0)
(255 191 127)
(165 82 0)
(165 124 82)
(127 63 0)
(127 95 63)
(76 38 0)
(76 57 38)
(38 19 0)
(38 28 19)
(255 191 0)
(255 223 127)
(165 124 0)
(165 145 82)
(127 95 0)
(127 111 63)
(76 57 0)
(76 66 38)
(38 28 0)
(38 33 19)
(255 255 0)
(255 255 127)
(165 165 0)
(165 165 82)
(127 127 0)
(127 127 63)
(76 76 0)
(76 76 38)
(38 38 0)
(38 38 19)
(191 255 0)
(223 255 127)
(124 165 0)
(145 165 82)
(95 127 0)
(111 127 63)
(57 76 0)
(66 76 38)
(28 38 0)
(33 38 19)
(127 255 0)
(191 255 127)
(82 165 0)
(124 165 82)
(63 127 0)
(95 127 63)
(38 76 0)
(57 76 38)
(19 38 0)
(28 38 19)
(63 255 0)
(159 255 127)
(41 165 0)
(103 165 82)
(31 127 0)
(79 127 63)
(19 76 0)
(47 76 38)
(9 38 0)
(23 38 19)
(0 255 0)
(127 255 127)
(0 165 0)
(82 165 82)
(0 127 0)
(63 127 63)
(0 76 0)
(38 76 38)
(0 38 0)
(19 38 19)
(0 255 63)
(127 255 159)
(0 165 41)
(82 165 103)
(0 127 31)
(63 127 79)
(0 76 19)
(38 76 47)
(0 38 9)
(19 38 23)
(0 255 127)
(127 255 191)
(0 165 82)
(82 165 124)
(0 127 63)
(63 127 95)
(0 76 38)
(38 76 57)
(0 38 19)
(19 38 28)
(0 255 191)
(127 255 223)
(0 165 124)
(82 165 145)
(0 127 95)
(63 127 111)
(0 76 57)
(38 76 66)
(0 38 28)
(19 38 33)
(0 255 255)
(127 255 255)
(0 165 165)
(82 165 165)
(0 127 127)
(63 127 127)
(0 76 76)
(38 76 76)
(0 38 38)
(19 38 38)
(0 191 255)
(127 223 255)
(0 124 165)
(82 145 165)
(0 95 127)
(63 111 127)
(0 57 76)
(38 66 76)
(0 28 38)
(19 33 38)
(0 127 255)
(127 191 255)
(0 82 165)
(82 124 165)
(0 63 127)
(63 95 127)
(0 38 76)
(38 57 76)
(0 19 38)
(19 28 38)
(0 63 255)
(127 159 255)
(0 41 165)
(82 103 165)
(0 31 127)
(63 79 127)
(0 19 76)
(38 47 76)
(0 9 38)
(19 23 38)
(0 0 255)
(127 127 255)
(0 0 165)
(82 82 165)
(0 0 127)
(63 63 127)
(0 0 76)
(38 38 76)
(0 0 38)
(19 19 38)
(63 0 255)
(159 127 255)
(41 0 165)
(103 82 165)
(31 0 127)
(79 63 127)
(19 0 76)
(47 38 76)
(9 0 38)
(23 19 38)
(127 0 255)
(191 127 255)
(82 0 165)
(124 82 165)
(63 0 127)
(95 63 127)
(38 0 76)
(57 38 76)
(19 0 38)
(28 19 38)
(191 0 255)
(223 127 255)
(124 0 165)
(145 82 165)
(95 0 127)
(111 63 127)
(57 0 76)
(66 38 76)
(28 0 38)
(33 19 38)
(255 0 255)
(255 127 255)
(165 0 165)
(165 82 165)
(127 0 127)
(127 63 127)
(76 0 76)
(76 38 76)
(38 0 38)
(38 19 38)
(255 0 191)
(255 127 223)
(165 0 124)
(165 82 145)
(127 0 95)
(127 63 111)
(76 0 57)
(76 38 66)
(38 0 28)
(38 19 33)
(255 0 127)
(255 127 191)
(165 0 82)
(165 82 124)
(127 0 63)
(127 63 95)
(76 0 38)
(76 38 57)
(38 0 19)
(38 19 28)
(255 0 63)
(255 127 159)
(165 0 41)
(165 82 103)
(127 0 31)
(127 63 79)
(76 0 19)
(76 38 47)
(38 0 9)
(38 19 23)
(0 0 0)
(51 51 51)
(102 102 102)
(153 153 153)
(204 204 204)
(255 255 255)
)
)
;;; Examples
;;;
;;; (RGBtoACI '(91 91 91)) returns 251
;;; (RGBtoACI '(118 118 118)) returns 8
;;; (RGBtoOLE_color '(118 118 118)) gives OLE_color=7763574
;;; (OLEtoRGB_color 7763574) gives (118 118 118)
;;; (RGBtoOLE_color '(91 91 91)) gives OLE_color=5987163
;;; (OLEtoRGB_color 5987163) gives (91 91 91)
;;; (RGBtoACI '(101 101 101)) returns 8
;;; (OLEtoRGB_color 6645093) returns (101 101 101)
;;; (ACItoRGB 123)
;;; Missing is conversion from ACI to RGB or ACI to OLE_color
[/FONT]

[FONT=courier new] 
;;; DisplayColorProperties.LSP 
;;; Miscellaneous commands related to Colors on the Display tab on the Options dialog 
;;; By Jimmy Bergmark 
;;; Copyright (C) 1997-2003 JTB World, All Rights Reserved 
;;; Website: [url]www.jtbworld.com[/url] / [url]http://jtbworld.vze.com[/url] 
;;; E-mail: [email]info@jtbworld.com[/email] / [email]jtbworld@hotmail.com[/email] 
;;; 2000-03-29 - First release 
;;; 2003-03-07 - Now for AutoCAD 2004 
;;; 2003-05-14 - Added ACI to RGB conversion 
;;; Tested on AutoCAD 2000, 2000i, 2002 and 2004 
;;; Some bugs exist with the conversions of colors from RGB to ACI. 
 
(vl-load-com) 
 
(setq pref (vla-get-preferences (vlax-get-acad-object))) 
 
(setq display (vla-get-display pref)) 
 
;;; Set the ModelColor using the color dialog box 
(defun c:SetModelColor(/ col oldcol) 
  (setq oldcol (getGraphicsWinModelBackgrndColor)) 
  (if (= oldcol nil) (setq oldcol 0)) 
  (if (= oldcol 0) (setq oldcol 1)) 
  (setq col (acad_colordlg oldcol nil)) 
  (if (and (= oldcol 7) (= col 7)) (setq col 0)) 
  (if (/= col nil) (putGraphicsWinModelBackgrndColor col)) 
  (princ) 
) 
(defun c:SetModelColor2004(/ col oldcol) 
  (setq oldcol (getGraphicsWinModelBackgrndColor2004)) 
  (if (= oldcol nil) (setq oldcol 0)) 
  (if (= oldcol 0) (setq oldcol 1)) 
  (setq col (acad_colordlg oldcol nil)) 
  (if (and (= oldcol 7) (= col 7)) (setq col 0)) 
  (if (/= col nil) (putGraphicsWinModelBackgrndColor col)) 
  (princ) 
) 
 
;;; Set the LayoutColor using the color dialog box 
(defun c:SetLayoutColor(/ col oldcol) 
  (setq oldcol (getGraphicsWinLayoutBackgrndColor)) 
  (if (= oldcol nil) (setq oldcol 0)) 
  (if (= oldcol 0) (setq oldcol 1)) 
  (setq col (acad_colordlg oldcol nil)) 
  (if (and (= oldcol 7) (= col 7)) (setq col 0)) 
  (if (/= col nil) (putGraphicsWinLayoutBackgrndColor col)) 
  (princ) 
) 
 
(defun getGraphicsWinModelBackgrndColor() 
  (OLE_color->ACI_color 
    (vla-get-GraphicsWinModelBackgrndColor 
      (vla-get-display (vla-get-preferences (vlax-get-acad-object))))) 
) 
 
(defun getGraphicsWinModelBackgrndColor2004 () 
  (OLE_colorToACI 
    (vlax-variant-value 
      (vlax-variant-change-type 
        (vla-get-GraphicsWinModelBackgrndColor 
          (vla-get-display 
            (vla-get-preferences (vlax-get-acad-object)) 
          ) 
        ) 
        vlax-vbLong 
      ) 
    ) 
  ) 
) 
 
(defun putGraphicsWinModelBackgrndColor(col) 
  (vla-put-GraphicsWinModelBackgrndColor 
    (vla-get-display (vla-get-preferences (vlax-get-acad-object))) 
    (ACI_color->OLE_color col) 
  ) 
) 
 
(defun getGraphicsWinLayoutBackgrndColor() 
  (OLE_color->ACI_color 
    (vla-get-GraphicsWinLayoutBackgrndColor 
      (vla-get-display (vla-get-preferences (vlax-get-acad-object))))) 
) 
 
(defun putGraphicsWinLayoutBackgrndColor(col) 
  (vla-put-GraphicsWinLayoutBackgrndColor 
    (vla-get-display (vla-get-preferences (vlax-get-acad-object))) 
    (ACI_color->OLE_color col) 
  ) 
) 
 
(defun getModelCrosshairColor() 
  (OLE_color->ACI_color 
    (vla-get-ModelCrosshairColor 
      (vla-get-display (vla-get-preferences (vlax-get-acad-object))))) 
) 
 
(defun putModelCrosshairColor(col) 
  (vla-put-ModelCrosshairColor 
    (vla-get-display (vla-get-preferences (vlax-get-acad-object))) 
    (ACI_color->OLE_color col) 
  ) 
) 
 
(defun getLayoutCrosshairColor() 
  (OLE_color->ACI_color 
    (vla-get-LayoutCrosshairColor 
      (vla-get-display (vla-get-preferences (vlax-get-acad-object))))) 
) 
 
(defun putLayoutCrosshairColor(col) 
  (vla-put-LayoutCrosshairColor 
    (vla-get-display (vla-get-preferences (vlax-get-acad-object))) 
    (ACI_color->OLE_color col) 
  ) 
) 
 
(defun getTextWinBackgrndColor() 
  (OLE_color->ACI_color 
    (vla-get-TextWinBackgrndColor 
      (vla-get-display (vla-get-preferences (vlax-get-acad-object))))) 
) 
 
(defun putTextWinBackgrndColor(col) 
  (vla-put-TextWinBackgrndColor 
    (vla-get-display (vla-get-preferences (vlax-get-acad-object))) 
    (ACI_color->OLE_color col) 
  ) 
) 
 
(defun getTextWinTextColor() 
  (OLE_color->ACI_color 
    (vla-get-TextWinTextColor 
      (vla-get-display (vla-get-preferences (vlax-get-acad-object))))) 
) 
 
(defun putTextWinTextColor(col) 
  (vla-put-TextWinTextColor 
    (vla-get-display (vla-get-preferences (vlax-get-acad-object))) 
    (ACI_color->OLE_color col) 
  ) 
) 
 
(defun getAutoTrackingVecColor() 
  (OLE_color->ACI_color 
    (vla-get-AutoTrackingVecColor 
      display)) 
) 
 
(defun putAutoTrackingVecColor(col) 
  (vla-put-AutoTrackingVecColor 
    display 
    (ACI_color->OLE_color col) 
  ) 
) 
 
(defun OLE_color->ACI_color (olec) 
  (vl-position 
    (boole 1 
           (vlax-variant-value 
             (vlax-variant-change-type olec vlax-vbLong) 
           ) 
           16777215 
    ) 
    OLE_COLOR_LIST 
  ) 
) 
 
 
(defun ACI_color->OLE_color (aci) 
  ; black is 0 
  ; white is 7 
  (if (and (>= aci 0) (<= 255)) 
    (setq aci (nth aci OLE_COLOR_LIST) 
    ) 
  ) 
) 
 
(setq OLE_COLOR_LIST 
       '(0          255        65535      65280      16776960 
         16711680   16711935   16777215   8421504    12632256 
         255        8421631    166        5460902    128 
         4210816    76         2500172    38         1250086 
         16639      8429567    10662      5466278    8320 
         4214912    4940       2502732    2598       1251366 
         33023      8437759    21414      5471398    16512 
         4219008    9804       2505036    4902       1252646 
         49151      8445951    31910      5476774    24704 
         4223104    14668      2507596    7462       1253670 
         65535      8454143    42662      5482150    32896 
         4227200    19532      2509900    9766       1254950 
         65471      8454111    42620      5482129    32864 
         4227184    19513      2509891    9757       1254945 
         65408      8454079    42579      5482108    32832 
         4227168    19494      2509881    9747       1254941 
         65344      8454047    42537      5482088    32800 
         4227152    19475      2509872    9738       1254936 
         65280      8454016    42496      5482067    32768 
         4227136    19456      2509862    9728       1254931 
         4259584    10485632   2729472    6858323    2129920 
         5275712    1264640    3165222    665088     1582611 
         8453888    12582784   5481984    8169043    4227072 
         6324288    2509824    3755046    1254912    1910291 
         12582656   14679936   8168960    9545299    6324224 
         7372864    3755008    4410406    1910272    2172435 
         16776960   16777088   10921472   10921555   8421376 
         8421440    5000192    5000230    2500096    2500115 
         16760576   16768896   10910720   10916179   8413184 
         8417344    4995328    4997926    2497792    2498835 
         16744448   16760704   10900224   10910803   8404992 
         8413248    4990464    4995366    2495232    2497811 
         16728064   16752512   10889472   10905683   8396800 
         8409152    4985600    4993062    2492928    2496531 
         16711680   16744576   10878976   10900307   8388608 
         8405056    4980736    4990502    2490368    2495251 
         16711744   16744607   10879017   10900328   8388640 
         8405072    4980755    4990512    2490378    2495256 
         16711808   16744639   10879059   10900348   8388672 
         8405088    4980774    4990521    2490387    2495261 
         16711871   16744671   10879100   10900369   8388704 
         8405104    4980793    4990531    2490397    2495265 
         16711935   16744703   10879142   10900390   8388736 
         8405120    4980812    4990540    2490406    2495270 
         12517631   14647551   8126630    9524134    6291584 
         7356544    3735628    4400716    1900582    2167590 
         8388863    12550399   5439654    8147878    4194432 
         6307968    2490444    3745356    1245222    1905446 
         4194559    10453247   2687142    6837158    2097280 
         5259392    1245260    3155532    655398     1577766 
         5526612    5987163    10000536   12303291   14540253 
         16777215 
        ) 
) 
 
 ;;; Only for AutoCAD 2004 
 (defun RGBtoACI (RGB-codes) 
   (vl-load-com) 
   (setq ColorObj (vla-GetInterfaceObject 
      (vlax-get-acad-object) 
      "AutoCAD.AcCmColor.16" 
    ) 
   ) 
   (vla-setRGB ColorObj (car RGB-codes) (cadr RGB-codes) (caddr RGB-codes)) 
   ; alternatively done as below 
   ; (vlax-invoke-method  ColorObj 'setRGB (car RGB-codes) (cadr RGB-codes) (caddr RGB-codes)) 
   (vla-get-ColorIndex ColorObj) 
 ) 
 
 (defun RGBtoOLE_color2 (RGB-codes) 
   (+ (* (car RGB-codes) 65536) 
      (* (cadr RGB-codes) 256) 
      (caddr RGB-codes) 
   ) 
 ) 
 
(defun OLEtoRGB_color2 (OLE_color / a b c) 
   (setq a (fix (/ OLE_color 65536.0))) 
   (setq b (fix (/ (- OLE_color (* a 65536)) 256.0))) 
   (setq c (- OLE_color (* a 65536) (* b 256))) 
   (list a b c) 
 ) 
 
;; Convert TrueColor into a list of RGB 
(defun OLEtoRGB_color (OLE_color / r g b) 
  (setq r (lsh OLE_color -16)) 
  (setq g (lsh (lsh OLE_color 16) -24)) 
  (setq b (lsh (lsh OLE_color 24) -24)) 
  (list r g b) 
) 
 
;; Convert a list of RGB to TrueColor 
;;; (RGBtoOLE_color '(118 118 118)) 
(defun RGBtoOLE_color (RGB-codes) 
  (setq r (lsh (car RGB-codes) 16)) 
  (setq g (lsh (cadr RGB-codes) 8)) 
  (setq b (caddr RGB-codes)) 
  (+ (+ r g) b) 
) 
 
; For AutoCAD 2004 
; (OLE_colorToACI 5987163) returns 251 
(defun OLE_colorToACI (OLE_color) 
  (RGBtoACI (OLEtoRGB_color OLE_color)) 
) 
 
(defun C:getColor(/) 
  (setq ename (car (entsel "\nPick an object with true color:"))) 
  (setq edata (entget ename)) 
  ;; we have a true color. 
  (setq tcol (cdr (assoc 420 edata))) 
  (princ "\n true color = ")(princ tcol) 
  ;; convert it to a list of RGB. 
  (setq rgb (OLEtoRGB_color tcol)) 
  (princ "\n rgb = ")(princ rgb) 
  (princ) 
) 
 
(defun C:setColor(/) 
  (setq ename (car (entsel "\nPick an object to set a true color:"))) 
  (setq edata (entget ename)) 
  ;; set a true color from a list of rgb values.(R=10 G=100 B=200) 
  (setq rgb (list 10 100 200)) 
  (setq tcol (RGBtoOLE_color rgb)) 
  ;; and set it.   
  (setq edata (subst (cons 420 tcol) (assoc 420 edata) edata)) 
  (entmod edata) 
  (princ "\n rgb = ")(princ rgb) 
  (princ "\n true color = ")(princ tcol) 
  (princ) 
) 
 
 
;;; (ACItoRGB 123) 
(defun ACItoRGB (aci) 
  (if (and (>= aci 0) (<= 255)) 
    (nth aci RGB_list) 
  ) 
) 
 
(setq RGB_list '( 
                 (0 0 0) 
                 (255 0 0) 
                 (255 255 0) 
                 (0 255 0) 
                 (0 255 255) 
                 (0 0 255) 
                 (255 0 255) 
                 (255 255 255) 
                 (128 128 128) 
                 (192 192 192) 
                 (255 0 0) 
                 (255 127 127) 
                 (165 0 0) 
                 (165 82 82) 
                 (127 0 0) 
                 (127 63 63) 
                 (76 0 0) 
                 (76 38 38) 
                 (38 0 0) 
                 (38 19 19) 
                 (255 63 0) 
                 (255 159 127) 
                 (165 41 0) 
                 (165 103 82) 
                 (127 31 0) 
                 (127 79 63) 
                 (76 19 0) 
                 (76 47 38) 
                 (38 9 0) 
                 (38 23 19) 
                 (255 127 0) 
                 (255 191 127) 
                 (165 82 0) 
                 (165 124 82) 
                 (127 63 0) 
                 (127 95 63) 
                 (76 38 0) 
                 (76 57 38) 
                 (38 19 0) 
                 (38 28 19) 
                 (255 191 0) 
                 (255 223 127) 
                 (165 124 0) 
                 (165 145 82) 
                 (127 95 0) 
                 (127 111 63) 
                 (76 57 0) 
                 (76 66 38) 
                 (38 28 0) 
                 (38 33 19) 
                 (255 255 0) 
                 (255 255 127) 
                 (165 165 0) 
                 (165 165 82) 
                 (127 127 0) 
                 (127 127 63) 
                 (76 76 0) 
                 (76 76 38) 
                 (38 38 0) 
                 (38 38 19) 
                 (191 255 0) 
                 (223 255 127) 
                 (124 165 0) 
                 (145 165 82) 
                 (95 127 0) 
                 (111 127 63) 
                 (57 76 0) 
                 (66 76 38) 
                 (28 38 0) 
                 (33 38 19) 
                 (127 255 0) 
                 (191 255 127) 
                 (82 165 0) 
                 (124 165 82) 
                 (63 127 0) 
                 (95 127 63) 
                 (38 76 0) 
                 (57 76 38) 
                 (19 38 0) 
                 (28 38 19) 
                 (63 255 0) 
                 (159 255 127) 
                 (41 165 0) 
                 (103 165 82) 
                 (31 127 0) 
                 (79 127 63) 
                 (19 76 0) 
                 (47 76 38) 
                 (9 38 0) 
                 (23 38 19) 
                 (0 255 0) 
                 (127 255 127) 
                 (0 165 0) 
                 (82 165 82) 
                 (0 127 0) 
                 (63 127 63) 
                 (0 76 0) 
                 (38 76 38) 
                 (0 38 0) 
                 (19 38 19) 
                 (0 255 63) 
                 (127 255 159) 
                 (0 165 41) 
                 (82 165 103) 
                 (0 127 31) 
                 (63 127 79) 
                 (0 76 19) 
                 (38 76 47) 
                 (0 38 9) 
                 (19 38 23) 
                 (0 255 127) 
                 (127 255 191) 
                 (0 165 82) 
                 (82 165 124) 
                 (0 127 63) 
                 (63 127 95) 
                 (0 76 38) 
                 (38 76 57) 
                 (0 38 19) 
                 (19 38 28) 
                 (0 255 191) 
                 (127 255 223) 
                 (0 165 124) 
                 (82 165 145) 
                 (0 127 95) 
                 (63 127 111) 
                 (0 76 57) 
                 (38 76 66) 
                 (0 38 28) 
                 (19 38 33) 
                 (0 255 255) 
                 (127 255 255) 
                 (0 165 165) 
                 (82 165 165) 
                 (0 127 127) 
                 (63 127 127) 
                 (0 76 76) 
                 (38 76 76) 
                 (0 38 38) 
                 (19 38 38) 
                 (0 191 255) 
                 (127 223 255) 
                 (0 124 165) 
                 (82 145 165) 
                 (0 95 127) 
                 (63 111 127) 
                 (0 57 76) 
                 (38 66 76) 
                 (0 28 38) 
                 (19 33 38) 
                 (0 127 255) 
                 (127 191 255) 
                 (0 82 165) 
                 (82 124 165) 
                 (0 63 127) 
                 (63 95 127) 
                 (0 38 76) 
                 (38 57 76) 
                 (0 19 38) 
                 (19 28 38) 
                 (0 63 255) 
                 (127 159 255) 
                 (0 41 165) 
                 (82 103 165) 
                 (0 31 127) 
                 (63 79 127) 
                 (0 19 76) 
                 (38 47 76) 
                 (0 9 38) 
                 (19 23 38) 
                 (0 0 255) 
                 (127 127 255) 
                 (0 0 165) 
                 (82 82 165) 
                 (0 0 127) 
                 (63 63 127) 
                 (0 0 76) 
                 (38 38 76) 
                 (0 0 38) 
                 (19 19 38) 
                 (63 0 255) 
                 (159 127 255) 
                 (41 0 165) 
                 (103 82 165) 
                 (31 0 127) 
                 (79 63 127) 
                 (19 0 76) 
                 (47 38 76) 
                 (9 0 38) 
                 (23 19 38) 
                 (127 0 255) 
                 (191 127 255) 
                 (82 0 165) 
                 (124 82 165) 
                 (63 0 127) 
                 (95 63 127) 
                 (38 0 76) 
                 (57 38 76) 
                 (19 0 38) 
                 (28 19 38) 
                 (191 0 255) 
                 (223 127 255) 
                 (124 0 165) 
                 (145 82 165) 
                 (95 0 127) 
                 (111 63 127) 
                 (57 0 76) 
                 (66 38 76) 
                 (28 0 38) 
                 (33 19 38) 
                 (255 0 255) 
                 (255 127 255) 
                 (165 0 165) 
                 (165 82 165) 
                 (127 0 127) 
                 (127 63 127) 
                 (76 0 76) 
                 (76 38 76) 
                 (38 0 38) 
                 (38 19 38) 
                 (255 0 191) 
                 (255 127 223) 
                 (165 0 124) 
                 (165 82 145) 
                 (127 0 95) 
                 (127 63 111) 
                 (76 0 57) 
                 (76 38 66) 
                 (38 0 28) 
                 (38 19 33) 
                 (255 0 127) 
                 (255 127 191) 
                 (165 0 82) 
                 (165 82 124) 
                 (127 0 63) 
                 (127 63 95) 
                 (76 0 38) 
                 (76 38 57) 
                 (38 0 19) 
                 (38 19 28) 
                 (255 0 63) 
                 (255 127 159) 
                 (165 0 41) 
                 (165 82 103) 
                 (127 0 31) 
                 (127 63 79) 
                 (76 0 19) 
                 (76 38 47) 
                 (38 0 9) 
                 (38 19 23) 
                 (0 0 0) 
                 (51 51 51) 
                 (102 102 102) 
                 (153 153 153) 
                 (204 204 204) 
                 (255 255 255) 
                ) 
) 
 
;;; Examples 
;;; 
;;; (RGBtoACI '(91 91 91)) returns 251 
;;; (RGBtoACI '(118 118 118)) returns 8 
;;; (RGBtoOLE_color '(118 118 118)) gives OLE_color=7763574 
;;; (OLEtoRGB_color 7763574) gives (118 118 118) 
;;; (RGBtoOLE_color '(91 91 91)) gives OLE_color=5987163 
;;; (OLEtoRGB_color 5987163) gives (91 91 91) 
;;; (RGBtoACI '(101 101 101)) returns 8 
;;; (OLEtoRGB_color 6645093) returns (101 101 101) 
;;; (ACItoRGB 123) 
 
;;; Missing is conversion from ACI to RGB or ACI to OLE_color 
  [/FONT]

[FONT=courier new]
VxOleToAciCol - Converts a OLE- to a ACI-Colornumber
;
; -- Function VxOleToAciCol
; Converts a OLE- to a ACI-Colornumber
; Copyright:
; ?000 Jimmy Bergmark
; Arguments [Typ]:
; OleCol = OLE-Colornumber [INT]
; Return [Typ]:
; > ACI-Colornumber [INT]
; Notes:
; Thanx Jimmy B. for his excellent color converter.
;
(defun VxOleToAciCol (OleCol)
(vl-position
(boole
1
(vlax-variant-value (vlax-variant-change-type OleCol vlax-vbLong))
16777215
)
'(0 255 65535 65280 16776960
16711680 16711935 16777215 8421504 12632256
255 8421631 166 5460902 128
4210816 76 2500172 38 1250086
16639 8429567 10662 5466278 8320
4214912 4940 2502732 2598 1251366
33023 8437759 21414 5471398 16512
4219008 9804 2505036 4902 1252646
49151 8445951 31910 5476774 24704
4223104 14668 2507596 7462 1253670
65535 8454143 42662 5482150 32896
4227200 19532 2509900 9766 1254950
65471 8454111 42620 5482129 32864
4227184 19513 2509891 9757 1254945
65408 8454079 42579 5482108 32832
4227168 19494 2509881 9747 1254941
65344 8454047 42537 5482088 32800
4227152 19475 2509872 9738 1254936
65280 8454016 42496 5482067 32768
4227136 19456 2509862 9728 1254931
4259584 10485632 2729472 6858323 2129920
5275712 1264640 3165222 665088 1582611
8453888 12582784 5481984 8169043 4227072
6324288 2509824 3755046 1254912 1910291
12582656 14679936 8168960 9545299 6324224
7372864 3755008 4410406 1910272 2172435
16776960 16777088 10921472 10921555 8421376
8421440 5000192 5000230 2500096 2500115
16760576 16768896 10910720 10916179 8413184
8417344 4995328 4997926 2497792 2498835
16744448 16760704 10900224 10910803 8404992
8413248 4990464 4995366 2495232 2497811
16728064 16752512 10889472 10905683 8396800
8409152 4985600 4993062 2492928 2496531
16711680 16744576 10878976 10900307 8388608
8405056 4980736 4990502 2490368 2495251
16711744 16744607 10879017 10900328 8388640
8405072 4980755 4990512 2490378 2495256
16711808 16744639 10879059 10900348 8388672
8405088 4980774 4990521 2490387 2495261
16711871 16744671 10879100 10900369 8388704
8405104 4980793 4990531 2490397 2495265
16711935 16744703 10879142 10900390 8388736
8405120 4980812 4990540 2490406 2495270
12517631 14647551 8126630 9524134 6291584
7356544 3735628 4400716 1900582 2167590
8388863 12550399 5439654 8147878 4194432
6307968 2490444 3745356 1245222 1905446
4194559 10453247 2687142 6837158 2097280
5259392 1245260 3155532 655398 1577766
5526612 7763574 10000536 12303291 14540253
16777215
)
)
)
Back
VxDeleteGroup - Deletes a group by name
;
; -- Function VxDeleteGroup
; Deletes a group by name
; Copyright:
; ?000 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Nme = Group name [STR]
; Return [Typ]:
; > Null
; Notes:
; Use a DocManagerReactor with a 'vlr-documentToBeDestroyed'-event
; to release the Gb:AcO and Gb:AcD objects at the end of a
; AutoCAD session - otherwise AutoCAD maybe crashes...
;
(defun VxDeleteGroup (Nme)
(setq Gb:AcO (cond (Gb:AcO) ((vlax-get-acad-object)))
Gb:AcD (cond (Gb:AcD) ((vla-get-activedocument Gb:AcO)))
)
(vl-catch-all-apply
'(lambda ()
(vla-delete
(vla-item
(vla-get-groups Gb:AcD)
Nme
)
)
)
)
(princ)
)
Back
VxGetGroupNames - Returns a list of all Group name(s) of the object
;
; -- Function VxGetGroupNames
; Returns a list of all Group name(s) of the object.
; Copyright:
; ?001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Obj = Object [VLA-OBJECT]
; Return [Typ]:
; > Group name(s) [LIST]
; Notes:
; Use a DocManagerReactor with a 'vlr-documentToBeDestroyed'-event
; to release the Gb:AcO and Gb:AcD objects at the end of a
; AutoCAD session - otherwise AutoCAD maybe crashes...
;
(defun VxGetGroupNames (Obj / Cur_ID NmeLst)
(setq Gb:AcO (cond (Gb:AcO) ((vlax-get-acad-object)))
Gb:AcD (cond (Gb:AcD) ((vla-get-activedocument Gb:AcO)))
Cur_ID (vla-get-ObjectID Obj)
)
(vlax-for Grp (vla-get-Groups Gb:AcD)
(vlax-for Ent Grp
(if (equal (vla-get-ObjectID Ent) Cur_ID)
(setq NmeLst (cons (vla-get-Name Grp) NmeLst))
)
(vlax-release-object Ent)
)
(vlax-release-object Grp)
)
(reverse NmeLst)
)
Back
VxGetMassProps - Returns a list of all mass properties of the object
;
; -- Function VxGetMassProps
; Returns a list of all mass properties of the object.
; Copyright:
; ?001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Obj = Object [VLA-OBJECT]
; Return [Typ]:
; > Mass properties '(Centroid RadiiOfGyration PrincipalDirections
; PrincipalMoments MomentOfInertia ProductOfInertia
; {Area Perimeter} {Volume}) [LIST]
; Notes:
; - VxGetMassProps is designed to handle closed *Polylines,
; Regions and 3dsolids.
; - *Polylines and Regions returns 2D-lists in some parameters.
; - 2D-objects returns '(. . . . . . Area Perimeter)
; - 3D-objects returns '(. . . . . . Volume)
; - Use a DocManagerReactor with a 'vlr-documentToBeDestroyed'-event
; to release the Gb:AcO and Gb:AcD objects at the end of a
; AutoCAD session - otherwise AutoCAD maybe crashes...
;
(defun VxGetMassProps (Obj / DelFlg ResLst TmpObj)
(setq Gb:AcO (cond (Gb:AcO) ((vlax-get-acad-object)))
Gb:AcD (cond (Gb:AcD) ((vla-get-ActiveDocument Gb:AcO)))
)
(if (member (vla-get-ObjectName Obj) '("AcDb2dPolyline" "AcDbPolyline"))
(setq DelFlg T
TmpObj (vlax-safearray-get-element
(vlax-variant-value
(vla-AddRegion
(vla-get-ModelSpace Gb:AcD)
(VxListToArray (list Obj) vlax-vbObject)
)
)
0
)
)
(setq TmpObj Obj)
)
(setq ResLst (append
(list
(vlax-get TmpObj "Centroid")
(vlax-get TmpObj "RadiiOfGyration")
(vlax-get TmpObj "PrincipalDirections")
(vlax-get TmpObj "PrincipalMoments")
(vlax-get TmpObj "MomentOfInertia")
)
(if (= (vla-get-ObjectName TmpObj) "AcDbRegion")
(list
(vla-get-ProductOfInertia TmpObj)
(vla-get-Area TmpObj)
(vla-get-Perimeter TmpObj)
)
(list
(vlax-get TmpObj "ProductOfInertia")
(vla-get-Volume TmpObj)
nil
)
)
)
)
(if DelFlg (vla-delete TmpObj))
ResLst
)
Back
VxGetInters - Returns all intersection points between two objects
;
; -- Function VxGetInters
; Returns all intersection points between two objects.
; Copyright:
; ?000 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Fst = First object [VLA-OBJECT]
; Nxt = Second object [VLA-OBJECT]
; Mde = Intersection mode [INT]
; Constants:
; - acExtendNone Does not extend either object.
; - acExtendThisEntity Extends the Fst object.
; - acExtendOtherEntity Extends the Nxt object.
; - acExtendBoth Extends both objects.
; Return [Typ]:
; > list of points '((1.0 1.0 0.0)... [LIST]
; > Nil if no intersection found
; Notes:
; None
;
(defun VxGetInters (Fst Nxt Mde / IntLst PntLst)
(setq IntLst (vlax-invoke Fst "IntersectWith" Nxt Mde))
(cond
(IntLst
(repeat (/ (length IntLst) 3)
(setq PntLst (cons
(list
(car IntLst)
(cadr IntLst)
(caddr IntLst)
)
PntLst
)
IntLst (cdddr IntLst)
)
)
(reverse PntLst)
)
(T nil)
)
)
Back
VxGetBlockInters - Returns all intersection points between a block and an obj...
;
; -- Function VxGetBlockInters
; Returns all intersection points between a Block and an object.
; Copyright:
; ?001-2002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Blk = Block object [VLA-OBJECT]
; Obj = Object [VLA-OBJECT]
; Mde = Intersection mode [INT]
; Constants:
; - acExtendNone Does not extend either object.
; - acExtendThisEntity Extends the Fst object.
; - acExtendOtherEntity Extends the Nxt object.
; - acExtendBoth Extends both objects.
; Return [Typ]:
; > list of points '((1.0 1.0 0.0)... [LIST]
; > Nil if no intersection found
; Notes:
; None
;
(defun VxGetBlockInters (Blk Obj Mde / ObjNme PntLst TmpVal)
(foreach memb (vlax-invoke Blk "Explode")
(setq ObjNme (vla-get-ObjectName memb))
(cond
((or
(not (vlax-method-applicable-p memb 'IntersectWith))
(and
(eq ObjNme "AcDbHatch")
(eq (strcase (vla-get-PatternName memb)) "SOLID")
)
(eq ObjNme "AcDb3dSolid")
)
)
((eq ObjNme "AcDbBlockReference")
(if (setq TmpVal (VxGetBlockInters memb Obj Mde))
(setq PntLst (append PntLst TmpVal))
)
)
(T
(if (setq TmpVal (VxGetInters memb Obj Mde))
(setq PntLst (append PntLst TmpVal))
)
)
)
(vla-Delete memb)
)
PntLst
)
Back
VxGetObjLength - Returns the length of all kind of objects
;
; -- Function VxGetObjLength
; Returns the length of all kind of objects.
; Copyright:
; ?001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Obj = Object [VLA-OBJECT]
; Return [Typ]:
; > Length of the object [REAL]
; Notes:
; - Proceedes *Polylines, Splines, Lines, Arcs, Circles and Ellipses
;
(defun VxGetObjLength (Obj)
(vlax-curve-getDistAtParam Obj (vlax-curve-getEndParam Obj))
)
Back
VxSsetSelect - ActiveX counterpart to 'ssget'
;
; -- Function VxSsetSelect
; ActiveX counterpart to 'ssget'.
; Copyright:
; ?002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Nme = Selection set name [STR]
; Mde = Select mode [INT] 1)
; Constants:
; - acSelectionSetWindow
; - acSelectionSetCrossing
; - acSelectionSetPrevious
; - acSelectionSetLast
; - acSelectionSetAll
; Pt1 = First window corner [LIST] 2)
; Pt2 = Next window corner [LIST] 2)
; Flt = Dotted pair list '((0 . "Name")...(8 . "Layer")) [LIST] 3)
; Return [Typ]:
; > New selection set [VLA-OBJECT]
; Notes:
; 1) If nil, SelectOnScreen is used
; 2) For select modes acSelectionSetWindow and acSelectionSetCrossing
; only, else nil
; 3) Set to nil if not used
;
(defun VxSsetSelect (Nme Mde Pt1 Pt2 Flt / CurSet FltLst FstPnt NxtPnt)
(setq CurSet (VxSsetMake Nme)
FstPnt (cond (Pt1 (vlax-3d-point Pt1)) (T nil))
NxtPnt (cond (Pt2 (vlax-3d-point Pt2)) (T nil))
FltLst (cond (Flt (VxSsetFilter Flt)) (T nil))
)
(if Mde
(if FltLst
(vla-select CurSet Mde FstPnt NxtPnt (car FltLst) (cadr FltLst))
(vla-select CurSet Mde FstPnt NxtPnt)
)
(if FltLst
(vla-SelectOnScreen CurSet (car FltLst) (cadr FltLst))
(vla-SelectOnScreen CurSet)
)
)
CurSet
)
Back
VxSsetMake - Creates a new selection set or clears an existing one
;
; -- Function VxSsetMake
; Creates a new selection set or clears an existing one.
; Copyright:
; ?002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Nme = Selection set name [STR]
; Return [Typ]:
; > New selection set [VLA-OBJECT]
; Notes:
; Use a DocManagerReactor with a 'vlr-documentToBeDestroyed'-event
; to release the Gb:AcO and Gb:AcD objects at the end of a
; AutoCAD session - otherwise AutoCAD maybe crashes...
;
(defun VxSsetMake (Nme / SetCol)
(setq Gb:AcO (cond (Gb:AcO) ((vlax-get-acad-object)))
Gb:AcD (cond (Gb:AcD) ((vla-get-activedocument Gb:AcO)))
SetCol (vla-get-SelectionSets Gb:AcD)
)
(if (vl-catch-all-error-p
(vl-catch-all-apply 'vla-add (list SetCol Nme))
)
(vla-clear (vla-Item SetCol Nme))
)
(vla-Item SetCol Nme)
)
Back
VxSsetFilter - Creates a filter for the SelectXxx methodes
;
; -- Function VxSsetFilter
; Creates a filter for the SelectXxx methodes.
; Copyright:
; ?002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Flt = Dotted pair list '((0 . "Name")...(8 . "Layer")) [LIST]
; Return [Typ]:
; > List of two arrays '(TypArr DatArr) [LIST]
; Notes:
; None
;
(defun VxSsetFilter (Flt)
(mapcar
'(lambda (Typ Dat) (VxListToArray Typ Dat))
(list vlax-vbInteger vlax-vbVariant)
(list (mapcar 'car Flt) (mapcar 'cdr Flt))
)
)
Back
VxListToArray - Converts a list into an array
;
; -- Function VxListToArray
; Converts a list into an array.
; Copyright:
; ?000 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Lst = Standard list [LIST]
; Typ = Datatype [INT]
; Constants:
; - vlax-vbBoolean
; - vlax-vbDecimal *)
; - vlax-vbDouble
; - vlax-vbInteger
; - vlax-vbLong
; - vlax-vbObject
; - vlax-vbSingle
; - vlax-vbString
; - vlax-vbVariant
; Return [Typ]:
; > Array [VARIANT]
; Notes:
; *)Missing datatype in Visual LISP, initialize it in your Autoloader.
; - Can't be used for dotted pair or nested lists.
;
(defun VxListToArray (Typ Lst)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray Typ (cons 0 (1- (length Lst))))
Lst
)
)
)
Back
VxArrayToList - Converts an array into a list
;
; -- Function VxArrayToList
; Converts an array into a list.
; Copyright:
; ?000 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Arr = Array [VARIANT]
; Return [Typ]:
; > Standard List [LIST]
; > nil if array is empty
; Notes:
; - Can't be used for multidimensional arrays.
;
(defun VxArrayToList (Arr / TmpVal)
(setq TmpVal (vlax-variant-value Arr))
(if (safearray-value TmpVal)
(vlax-safearray->list TmpVal)
'()
)
)
Back
VxStringSubst - Substitutes one string for another, within a string
;
; -- Function VxStringSubst
; Substitutes one string for another, within a string.
; Copyright:
; ?001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Fnd = Pattern [STR]
; Rep = Replace [STR]
; Stg = String to search [STR]
; Return [Typ]:
; > Modified string [STR]
; Notes:
; None
;
(defun VxStringSubst (Fnd Rep Stg / TmpStr)
(setq TmpStr Stg)
(while (vl-string-search Fnd TmpStr)
(setq TmpStr (vl-string-subst Rep Fnd TmpStr))
)
TmpStr
)
Back
VxGetDriveInfos - Returns informations from the selected drive
;
; -- Function VxGetDriveInfos
; Returns informations from the selected drive.
; Copyright:
; ?001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Drv = Drive character, eg. "C" or "C:" [STR]
; Return [Typ]:
; > Drive infos '(TotalSize FreeSpace DriveType FileSystem SerialNumber
; ShareName VolumeName) [LIST]
; Explanations:
; - TotalSize (kB) [REAL]
; Returns the total space of a drive or network share.
; - FreeSpace (kB) [REAL]
; Returns the amount of space available to a user on the specified drive
; or network share.
; - DriveType [INT]
; 0 = "Unknown"
; 1 = "Removable"
; 2 = "Fixed"
; 3 = "Network"
; 4 = "CD-ROM"
; 5 = "RAM Disk"
; - FileSystem [STR]
; Returns the type of file system in use for the specified drive, eg.
; "FAT", "NTFS", "CDFS".
; - SerialNumber [INT]
; Returns the serial number used to uniquely identify a disk volume.
; - ShareName [STR]
; Returns the network share name (UNC) for the specified drive. If it's
; not a network drive, ShareName returns a zero-length string ("").
; - VolumeName [STR]
; Returns the volume name of the specified drive.
; > 0 The drive doesn't exist.
; > -1 The drive is not ready. For removable-media drives and CD-ROM drives,
; VxGetDriveInfos returns -1 when the appropriate media is not inserted
; or not ready for access.
; Notes:
; - Requires ScrRun.dll.
;
(defun VxGetDriveInfos (Drv / DrvObj FilSys RetVal)
(setq FilSys (vlax-create-object "Scripting.FileSystemObject")
RetVal (cond
((= (vlax-invoke FilSys "DriveExists" Drv) 0) 0)
((setq DrvObj (vlax-invoke FilSys "GetDrive" Drv))
(cond
((= (vlax-get DrvObj "IsReady") 0) -1)
((list
(/ (vlax-get DrvObj "TotalSize") 1000.0)
(/ (vlax-get DrvObj "FreeSpace") 1000.0)
(vlax-get DrvObj "DriveType")
(vlax-get DrvObj "FileSystem")
(vlax-get DrvObj "SerialNumber")
(vlax-get DrvObj "ShareName")
(vlax-get DrvObj "VolumeName")
)
)
)
)
)
)
(if DrvObj (vlax-release-object DrvObj))
(vlax-release-object FilSys)
RetVal
)
Back
VxGetFileInfos - Returns informations from the selected file
;
; -- VxGetFileInfos
; Returns informations from the selected file.
; Copyright:
; ?002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Fil = Filename "C:\\Temp\\MyTemp\\Scrap.dwg" [STR]
; Return [Typ]:
; > File infos '(DateCreated DateLastModified DateLastAccessed
; Type Size Attributes) [LIST]
; Explanations:
; - DateCreated [REAL]
; Returns serial date/time.
; - DateLastModified [REAL]
; Returns serial date/time.
; - DateLastAccessed [REAL]
; Returns serial date/time.
; - Type [STR]
; Returns the registered file tape, eg. "AutoCAD Drawing".
; - Size (kB) [REAL]
; Returns the size of the file in kB.
; - Attributes [INT]
; 0 = Normal file, no attributes are set.
; 1 = Read-only file.
; 2 = Hidden file.
; 4 = System file.
; 8 = Disk drive volume label. (not available in VxGetFileInfos)
; 16 = Folder or directory. (not available in VxGetFileInfos)
; 32 = File has changed since last backup.
; 64 = Link or shortcut.
; 128 = Compressed file.
; > nil If file doesn't exist
; Notes:
; - Requires ScrRun.dll.
;
(defun VxGetFileInfos (Fil / FilObj FilSys RetVal)
(setq FilSys (vlax-create-object "Scripting.FileSystemObject")
RetVal (cond
((= (vlax-invoke FilSys "FileExists" Fil) 0) nil)
((setq FilObj (vlax-invoke FilSys "GetFile" Fil))
(list
(vlax-get FilObj "DateCreated")
(vlax-get FilObj "DateLastModified")
(vlax-get FilObj "DateLastAccessed")
(vlax-get FilObj "Type")
(/ (vlax-get FilObj "Size") 1000.0)
(vlax-get FilObj "Attributes")
)
)
(T nil)
)
)
(if FilObj (vlax-release-object FilObj))
(vlax-release-object FilSys)
RetVal
)
Back
VxCopyFiles - Copies the specified file(s)
;
; -- VxCopyFiles
; Copies the specified file(s).
; Copyright:
; ?002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Src = Source file(s) to copy "C:\\Temp\\AllScrap.*" [STR]
; Tar = Target directory/file "C:\\Scrap" [STR]
; Return [Typ]:
; > T VxCopyFiles succeed
; nil Error on copy file(s)
; Notes:
; - Requires ScrRun.dll.
;
(defun VxCopyFiles (Src Tar / ErrObj FilSys RetVal)
(setq FilSys (vlax-create-object "Scripting.FileSystemObject")
ErrObj (vl-catch-all-apply
'vlax-invoke-method
(list FilSys 'CopyFile Src Tar :vlax-true)
)
RetVal (not (vl-catch-all-error-p ErrObj))
)
(vlax-release-object FilSys)
RetVal
)
Back
VxDeleteFiles - Deletes the specified file(s)
;
; -- VxDeleteFiles
; Deletes the specified file(s).
; Copyright:
; ?002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Fil = File name(s) to delete "C:\\Temp\\AllScrap.*" [STR]
; Return [Typ]:
; > T VxDeleteFiles succeed
; nil Error on delete file(s)
; Notes:
; - Requires ScrRun.dll.
;
(defun VxDeleteFiles (Fil / ErrObj FilSys RetVal)
(setq FilSys (vlax-create-object "Scripting.FileSystemObject")
ErrObj (vl-catch-all-apply
'vlax-invoke-method
(list FilSys 'DeleteFile Fil :vlax-true)
)
RetVal (not (vl-catch-all-error-p ErrObj))
)
(vlax-release-object FilSys)
RetVal
)
Back
VxCreateDirectory - Creates the specified directory(ies)
;
; -- VxMakeDirectory
; Creates the specified directory(ies).
; Copyright:
; ?001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Dir = Folder to create, eg. "C:\\Temp\\MyTemp\\AllScrap" [STR]
; Return [Typ]:
; > T VxMakeDirectory succeed
; nil Error on creating directory(ies)
; Notes:
; - Requires ScrRun.dll.
;
(defun VxMakeDirectory (Dir / CurDir DrvObj FilSys RetVal TmpLst TmpVal)
(setq FilSys (vlax-create-object "Scripting.FileSystemObject")
CurDir (vl-string-right-trim "\" (vl-string-right-trim "/" Dir))
)
(while (/= (setq TmpVal (vl-filename-directory CurDir)) CurDir)
(setq TmpLst (cons TmpVal TmpLst)
CurDir TmpVal
)
)
(setq RetVal (cond
((= (vlax-invoke FilSys "DriveExists" TmpVal) 0) nil)
((setq DrvObj (vlax-invoke FilSys "GetDrive" TmpVal))
(cond
((= (vlax-get DrvObj "IsReady") 0) nil)
(T
(foreach memb TmpLst
(cond
((= (vlax-invoke FilSys "FolderExists" memb) -1))
((vlax-invoke FilSys "CreateFolder" memb))
)
)
(cond
((= (vlax-invoke FilSys "FolderExists" Dir) -1))
((vlax-invoke FilSys "CreateFolder" Dir) T)
(T nil)
)
)
)
)
)
)
(if DrvObj (vlax-release-object DrvObj))
(vlax-release-object FilSys)
RetVal
)
Back
VxDelDirectory - Deletes the specified directory
;
; -- VxDelDirectory
; Deletes the specified directory.
; Copyright:
; ?002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Dir = Folder to delete "C:\\Temp\\MyTemp\\AllScrap" [STR]
; Return [Typ]:
; > T VxDelDirectory succeed
; nil Error on deleting directory
; Notes:
; - Requires ScrRun.dll.
;
(defun VxDelDirectory (Dir / FilSys RetVal)
(setq FilSys (vlax-create-object "Scripting.FileSystemObject")
RetVal (cond
((= (vlax-invoke FilSys "FolderExists" Dir) 0) nil)
(T (vlax-invoke FilSys "DeleteFolder" Dir :vlax-true) T)
)
)
(vlax-release-object FilSys)
RetVal
)
Back
VxReadTextFile - Reads a textfile and returns a line list (fast)
;
; -- VxReadTextFile
; Reads a textfile and returns a line list (fast).
; Copyright:
; ?001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Fil = (Path)Filename [STR]
; Return [Typ]:
; > List of lines [LIST]
; > nil if file not found
; Notes:
; - Requires ScrRun.dll.
;
(defun VxReadTextFile (Fil / FilObj FilPth FilSys OpnFil RetVal)
(if (setq FilPth (findfile Fil))
(progn
(setq FilSys (vlax-create-object "Scripting.FileSystemObject")
FilObj (vlax-invoke FilSys "GetFile FilPth")
OpnFil (vlax-invoke FilObj "OpenAsTextStream" 1 0)
)
(while (= (vlax-get OpnFil "AtEndOfStream") 0)
(setq RetVal (cons (vlax-invoke OpnFil "ReadLine") RetVal))
)
(vlax-invoke OpnFil "Close")
(vlax-release-object OpnFil)
(vlax-release-object FilObj)
(vlax-release-object FilSys)
(reverse RetVal)
)
nil
)
)
Back
VxCreateShortCut - Creates a shortcut to AutoCAD with the appropriate...
;
; -- Function VxCreateShortCut
; Creates a shortcut to AutoCAD with the appropriate parameters on the desktop.
; Copyright:
; ?002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Typ]:
; Scn = Shortcut name, "MyShortCut" [STR]
; Pro = Profile name, "MyProfile" [STR]
; Icn = (Path)Filename of the icon, "c:\\MyPath\\MyIcon.ico" [STR] 1)
; Return [Typ]:
; > Shortcutpath if suceed [STR]
; > False on error
; Notes:
; 1) If nil, AutoCAD's first internal icon is used
; - Requires ScrRun.dll.
;
(defun VxCreateShortCut (Scn Pro Icn / DskPth IcnPar ExeFil RetVal ShoCut
SpcFld WscObj)
(setq ExeFil (findfile "acad.exe")
IcnPar (cond (Icn) ((strcat ExeFil ", 0")))
WscObj (vlax-create-object "WScript.Shell")
RetVal (cond
((setq SpcFld (vlax-get WscObj 'SpecialFolders))
(setq DskPth (strcat
(vla-Item SpcFld "Desktop")
"\" Scn ".lnk"
)
ShoCut (vlax-invoke WscObj "CreateShortcut" DskPth)
)
(vlax-put-property ShoCut 'TargetPath ExeFil)
(vlax-put-property ShoCut 'Arguments (strcat "/p " Pro))
(vlax-put-property ShoCut 'IconLocation IcnPar)
(vla-save ShoCut)
(findfile DskPth)
)
(T Nil)
)
)
(vlax-release-object WscObj)
RetVal
)
Back
ACAD2000.lsp - Drawing Reactor sample
;
; -- ACAD2000.lsp
; Sets a DocManager Reactor to release the Gb:AcO and Gb:AcD objects at the
; end of a AutoCAD session.
; Copyright:
; ?000 MENZI ENGINEERING GmbH, Switzerland
; Notes:
; None
;
(setq vlax-vbDecimal 14) ;Set missing Datatype
(if s::startup
(defun-q-list-set
's::startup
(append
(defun-q-list-ref 's::startup)
(cdr (defun-q-list-ref 'InitReactor))
)
)
(defun-q s::startup () (InitReactor) (princ))
)
(defun-q InitReactor ()
(prompt "\n>Initialize Document Reactor...")
(vl-load-com)
(if (not Gb:DmR)
(setq Gb:DmR (vlr-DocManager-Reactor
nil
'((:vlr-documentToBeDestroyed . CloseHandling))
)
)
)
(princ)
)
(defun CloseHandling (Rea Arg)
(if Gb:AcO (vlax-release-object Gb:AcO))
(if Gb:AcD (vlax-release-object Gb:AcD))
(vlr-remove-all :vlr-DocManager-Reactor)
(setq Gb:AcO nil
Gb:AcD nil
Gb:DmR nil
)
(princ)
)
(princ)
;
; -- End ACAD2000.lsp
[/FONT]

[FONT=courier new] 
VxOleToAciCol - Converts a OLE- to a ACI-Colornumber 
 
 
; 
; -- Function VxOleToAciCol 
; Converts a OLE- to a ACI-Colornumber 
; Copyright: 
;   ?000 Jimmy Bergmark 
; Arguments [Typ]: 
;   OleCol = OLE-Colornumber [INT] 
; Return [Typ]: 
;   > ACI-Colornumber [INT] 
; Notes: 
; Thanx Jimmy B. for his excellent color converter. 
; 
(defun VxOleToAciCol (OleCol) 
 (vl-position 
  (boole 
   1 
   (vlax-variant-value (vlax-variant-change-type OleCol vlax-vbLong)) 
   16777215 
  ) 
 '(0        255      65535    65280    16776960 
   16711680 16711935 16777215 8421504  12632256 
   255      8421631  166      5460902  128 
   4210816  76       2500172  38       1250086 
   16639    8429567  10662    5466278  8320 
   4214912  4940     2502732  2598     1251366 
   33023    8437759  21414    5471398  16512 
   4219008  9804     2505036  4902     1252646 
   49151    8445951  31910    5476774  24704 
   4223104  14668    2507596  7462     1253670 
   65535    8454143  42662    5482150  32896 
   4227200  19532    2509900  9766     1254950 
   65471    8454111  42620    5482129  32864 
   4227184  19513    2509891  9757     1254945 
   65408    8454079  42579    5482108  32832 
   4227168  19494    2509881  9747     1254941 
   65344    8454047  42537    5482088  32800 
   4227152  19475    2509872  9738     1254936 
   65280    8454016  42496    5482067  32768 
   4227136  19456    2509862  9728     1254931 
   4259584  10485632 2729472  6858323  2129920 
   5275712  1264640  3165222  665088   1582611 
   8453888  12582784 5481984  8169043  4227072 
   6324288  2509824  3755046  1254912  1910291 
   12582656 14679936 8168960  9545299  6324224 
   7372864  3755008  4410406  1910272  2172435 
   16776960 16777088 10921472 10921555 8421376 
   8421440  5000192  5000230  2500096  2500115 
   16760576 16768896 10910720 10916179 8413184 
   8417344  4995328  4997926  2497792  2498835 
   16744448 16760704 10900224 10910803 8404992 
   8413248  4990464  4995366  2495232  2497811 
   16728064 16752512 10889472 10905683 8396800 
   8409152  4985600  4993062  2492928  2496531 
   16711680 16744576 10878976 10900307 8388608 
   8405056  4980736  4990502  2490368  2495251 
   16711744 16744607 10879017 10900328 8388640 
   8405072  4980755  4990512  2490378  2495256 
   16711808 16744639 10879059 10900348 8388672 
   8405088  4980774  4990521  2490387  2495261 
   16711871 16744671 10879100 10900369 8388704 
   8405104  4980793  4990531  2490397  2495265 
   16711935 16744703 10879142 10900390 8388736 
   8405120  4980812  4990540  2490406  2495270 
   12517631 14647551 8126630  9524134  6291584 
   7356544  3735628  4400716  1900582  2167590 
   8388863  12550399 5439654  8147878  4194432 
   6307968  2490444  3745356  1245222  1905446 
   4194559  10453247 2687142  6837158  2097280 
   5259392  1245260  3155532  655398   1577766 
   5526612  7763574  10000536 12303291 14540253 
   16777215 
  ) 
 ) 
) 
 
 
Back 
 
VxDeleteGroup - Deletes a group by name 
 
 
; 
; -- Function VxDeleteGroup 
; Deletes a group by name 
; Copyright: 
;   ?000 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Nme = Group name [STR] 
; Return [Typ]: 
;   > Null 
; Notes: 
;   Use a DocManagerReactor with a 'vlr-documentToBeDestroyed'-event 
;   to release the Gb:AcO and Gb:AcD objects at the end of a 
;   AutoCAD session - otherwise AutoCAD maybe crashes... 
; 
(defun VxDeleteGroup (Nme) 
 (setq Gb:AcO (cond (Gb:AcO) ((vlax-get-acad-object))) 
       Gb:AcD (cond (Gb:AcD) ((vla-get-activedocument Gb:AcO))) 
 ) 
 (vl-catch-all-apply 
 '(lambda () 
   (vla-delete 
    (vla-item 
     (vla-get-groups Gb:AcD) 
     Nme 
    ) 
   ) 
  ) 
 ) 
 (princ) 
) 
 
 
Back 
 
VxGetGroupNames - Returns a list of all Group name(s) of the object 
 
 
; 
; -- Function VxGetGroupNames 
; Returns a list of all Group name(s) of the object. 
; Copyright: 
;   ?001 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Obj = Object [VLA-OBJECT] 
; Return [Typ]: 
;   > Group name(s) [LIST] 
; Notes: 
;   Use a DocManagerReactor with a 'vlr-documentToBeDestroyed'-event 
;   to release the Gb:AcO and Gb:AcD objects at the end of a 
;   AutoCAD session - otherwise AutoCAD maybe crashes... 
; 
(defun VxGetGroupNames (Obj / Cur_ID NmeLst) 
 (setq Gb:AcO (cond (Gb:AcO) ((vlax-get-acad-object))) 
       Gb:AcD (cond (Gb:AcD) ((vla-get-activedocument Gb:AcO))) 
       Cur_ID (vla-get-ObjectID Obj) 
 ) 
 (vlax-for Grp (vla-get-Groups Gb:AcD) 
  (vlax-for Ent Grp 
   (if (equal (vla-get-ObjectID Ent) Cur_ID) 
    (setq NmeLst (cons (vla-get-Name Grp) NmeLst)) 
   ) 
   (vlax-release-object Ent) 
  ) 
  (vlax-release-object Grp) 
 ) 
 (reverse NmeLst) 
) 
 
 
Back 
 
VxGetMassProps - Returns a list of all mass properties of the object 
 
 
; 
; -- Function VxGetMassProps 
; Returns a list of all mass properties of the object. 
; Copyright: 
;   ?001 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Obj = Object [VLA-OBJECT] 
; Return [Typ]: 
;   > Mass properties '(Centroid RadiiOfGyration PrincipalDirections 
;                       PrincipalMoments MomentOfInertia ProductOfInertia 
;                       {Area Perimeter} {Volume}) [LIST] 
; Notes: 
; - VxGetMassProps is designed to handle closed *Polylines, 
;   Regions and 3dsolids. 
; - *Polylines and Regions returns 2D-lists in some parameters. 
; - 2D-objects returns '(. . . . . . Area Perimeter) 
; - 3D-objects returns '(. . . . . . Volume) 
; - Use a DocManagerReactor with a 'vlr-documentToBeDestroyed'-event 
;   to release the Gb:AcO and Gb:AcD objects at the end of a 
;   AutoCAD session - otherwise AutoCAD maybe crashes... 
; 
(defun VxGetMassProps (Obj / DelFlg ResLst TmpObj) 
 (setq Gb:AcO (cond (Gb:AcO) ((vlax-get-acad-object))) 
       Gb:AcD (cond (Gb:AcD) ((vla-get-ActiveDocument Gb:AcO))) 
 ) 
 (if (member (vla-get-ObjectName Obj) '("AcDb2dPolyline" "AcDbPolyline")) 
  (setq DelFlg T 
        TmpObj (vlax-safearray-get-element 
                (vlax-variant-value 
                 (vla-AddRegion 
                  (vla-get-ModelSpace Gb:AcD) 
                  (VxListToArray (list Obj) vlax-vbObject) 
                 ) 
                ) 
                0 
               ) 
  ) 
  (setq TmpObj Obj) 
 ) 
 (setq ResLst (append 
               (list 
                (vlax-get TmpObj "Centroid") 
                (vlax-get TmpObj "RadiiOfGyration") 
                (vlax-get TmpObj "PrincipalDirections") 
                (vlax-get TmpObj "PrincipalMoments") 
                (vlax-get TmpObj "MomentOfInertia") 
               ) 
               (if (= (vla-get-ObjectName TmpObj) "AcDbRegion") 
                (list 
                 (vla-get-ProductOfInertia TmpObj) 
                 (vla-get-Area TmpObj) 
                 (vla-get-Perimeter TmpObj) 
                ) 
                (list 
                 (vlax-get TmpObj "ProductOfInertia") 
                 (vla-get-Volume TmpObj) 
                 nil 
                ) 
               ) 
              ) 
 ) 
 (if DelFlg (vla-delete TmpObj)) 
 ResLst 
) 
 
 
Back 
 
VxGetInters - Returns all intersection points between two objects 
 
 
; 
; -- Function VxGetInters 
; Returns all intersection points between two objects. 
; Copyright: 
;   ?000 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Fst = First object [VLA-OBJECT] 
;   Nxt = Second object [VLA-OBJECT] 
;   Mde = Intersection mode [INT] 
;         Constants: 
;         - acExtendNone           Does not extend either object. 
;         - acExtendThisEntity     Extends the Fst object. 
;         - acExtendOtherEntity    Extends the Nxt object. 
;         - acExtendBoth           Extends both objects. 
; Return [Typ]: 
;   > list of points '((1.0 1.0 0.0)... [LIST] 
;   > Nil if no intersection found 
; Notes: 
;   None 
; 
(defun VxGetInters (Fst Nxt Mde / IntLst PntLst) 
 (setq IntLst (vlax-invoke Fst "IntersectWith" Nxt Mde)) 
 (cond 
  (IntLst 
   (repeat (/ (length IntLst) 3) 
    (setq PntLst (cons 
                  (list 
                   (car IntLst) 
                   (cadr IntLst) 
                   (caddr IntLst) 
                  ) 
                  PntLst 
                 ) 
          IntLst (cdddr IntLst) 
    ) 
   ) 
   (reverse PntLst) 
  ) 
  (T nil) 
 ) 
) 
 
Back 
 
VxGetBlockInters - Returns all intersection points between a block and an obj... 
 
 
; 
; -- Function VxGetBlockInters 
; Returns all intersection points between a Block and an object. 
; Copyright: 
;   ?001-2002 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Blk = Block object [VLA-OBJECT] 
;   Obj = Object [VLA-OBJECT] 
;   Mde = Intersection mode [INT] 
;         Constants: 
;         - acExtendNone           Does not extend either object. 
;         - acExtendThisEntity     Extends the Fst object. 
;         - acExtendOtherEntity    Extends the Nxt object. 
;         - acExtendBoth           Extends both objects. 
; Return [Typ]: 
;   > list of points '((1.0 1.0 0.0)... [LIST] 
;   > Nil if no intersection found 
; Notes: 
;   None 
; 
(defun VxGetBlockInters (Blk Obj Mde / ObjNme PntLst TmpVal) 
 (foreach memb (vlax-invoke Blk "Explode") 
  (setq ObjNme (vla-get-ObjectName memb)) 
  (cond 
   ((or 
     (not (vlax-method-applicable-p memb 'IntersectWith)) 
     (and 
      (eq ObjNme "AcDbHatch") 
      (eq (strcase (vla-get-PatternName memb)) "SOLID") 
     ) 
     (eq ObjNme "AcDb3dSolid") 
    ) 
   ) 
   ((eq ObjNme "AcDbBlockReference") 
    (if (setq TmpVal (VxGetBlockInters memb Obj Mde)) 
     (setq PntLst (append PntLst TmpVal)) 
    ) 
   ) 
   (T 
    (if (setq TmpVal (VxGetInters memb Obj Mde)) 
     (setq PntLst (append PntLst TmpVal)) 
    ) 
   ) 
  ) 
  (vla-Delete memb) 
 ) 
 PntLst 
) 
 
 
Back 
 
VxGetObjLength - Returns the length of all kind of objects 
 
 
; 
; -- Function VxGetObjLength 
; Returns the length of all kind of objects. 
; Copyright: 
;   ?001 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Obj = Object [VLA-OBJECT] 
; Return [Typ]: 
;   > Length of the object [REAL] 
; Notes: 
; - Proceedes *Polylines, Splines, Lines, Arcs, Circles and Ellipses 
; 
(defun VxGetObjLength (Obj) 
 (vlax-curve-getDistAtParam Obj (vlax-curve-getEndParam Obj)) 
) 
 
 
Back 
 
VxSsetSelect - ActiveX counterpart to 'ssget' 
 
 
; 
; -- Function VxSsetSelect 
; ActiveX counterpart to 'ssget'. 
; Copyright: 
;   ?002 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Nme = Selection set name [STR] 
;   Mde = Select mode [INT] 1) 
;         Constants: 
;         - acSelectionSetWindow 
;         - acSelectionSetCrossing 
;         - acSelectionSetPrevious 
;         - acSelectionSetLast 
;         - acSelectionSetAll 
;   Pt1 = First window corner [LIST] 2) 
;   Pt2 = Next window corner [LIST]  2) 
;   Flt = Dotted pair list '((0 . "Name")...(8 . "Layer")) [LIST] 3) 
; Return [Typ]: 
;   > New selection set [VLA-OBJECT] 
; Notes: 
;   1) If nil, SelectOnScreen is used 
;   2) For select modes acSelectionSetWindow and acSelectionSetCrossing 
;      only, else nil 
;   3) Set to nil if not used 
; 
(defun VxSsetSelect (Nme Mde Pt1 Pt2 Flt / CurSet FltLst FstPnt NxtPnt) 
 (setq CurSet (VxSsetMake Nme) 
       FstPnt (cond (Pt1 (vlax-3d-point Pt1)) (T nil)) 
       NxtPnt (cond (Pt2 (vlax-3d-point Pt2)) (T nil)) 
       FltLst (cond (Flt (VxSsetFilter Flt)) (T nil)) 
 ) 
 (if Mde 
  (if FltLst 
   (vla-select CurSet Mde FstPnt NxtPnt (car FltLst) (cadr FltLst)) 
   (vla-select CurSet Mde FstPnt NxtPnt) 
  ) 
  (if FltLst 
   (vla-SelectOnScreen CurSet (car FltLst) (cadr FltLst)) 
   (vla-SelectOnScreen CurSet) 
  ) 
 ) 
 CurSet 
) 
 
Back 
 
VxSsetMake - Creates a new selection set or clears an existing one 
 
 
; 
; -- Function VxSsetMake 
; Creates a new selection set or clears an existing one. 
; Copyright: 
;   ?002 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Nme = Selection set name [STR] 
; Return [Typ]: 
;   > New selection set [VLA-OBJECT] 
; Notes: 
;   Use a DocManagerReactor with a 'vlr-documentToBeDestroyed'-event 
;   to release the Gb:AcO and Gb:AcD objects at the end of a 
;   AutoCAD session - otherwise AutoCAD maybe crashes... 
; 
(defun VxSsetMake (Nme / SetCol) 
 (setq Gb:AcO (cond (Gb:AcO) ((vlax-get-acad-object))) 
       Gb:AcD (cond (Gb:AcD) ((vla-get-activedocument Gb:AcO))) 
       SetCol (vla-get-SelectionSets Gb:AcD) 
 ) 
 (if (vl-catch-all-error-p 
      (vl-catch-all-apply 'vla-add (list SetCol Nme)) 
     ) 
  (vla-clear (vla-Item SetCol Nme)) 
 ) 
 (vla-Item SetCol Nme) 
) 
 
 
Back 
 
VxSsetFilter - Creates a filter for the SelectXxx methodes 
 
 
; 
; -- Function VxSsetFilter 
; Creates a filter for the SelectXxx methodes. 
; Copyright: 
;   ?002 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Flt = Dotted pair list '((0 . "Name")...(8 . "Layer")) [LIST] 
; Return [Typ]: 
;   > List of two arrays '(TypArr DatArr) [LIST] 
; Notes: 
;   None 
; 
(defun VxSsetFilter (Flt) 
 (mapcar 
 '(lambda (Typ Dat) (VxListToArray Typ Dat)) 
  (list vlax-vbInteger vlax-vbVariant) 
  (list (mapcar 'car Flt) (mapcar 'cdr Flt)) 
 ) 
) 
 
 
Back 
 
VxListToArray - Converts a list into an array 
 
 
; 
; -- Function VxListToArray 
; Converts a list into an array. 
; Copyright: 
;   ?000 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Lst = Standard list [LIST] 
;   Typ = Datatype [INT] 
;         Constants: 
;         - vlax-vbBoolean 
;         - vlax-vbDecimal *) 
;         - vlax-vbDouble 
;         - vlax-vbInteger 
;         - vlax-vbLong 
;         - vlax-vbObject 
;         - vlax-vbSingle 
;         - vlax-vbString 
;         - vlax-vbVariant 
; Return [Typ]: 
;   > Array [VARIANT] 
; Notes: 
;   *)Missing datatype in Visual LISP, initialize it in your Autoloader. 
;   - Can't be used for dotted pair or nested lists. 
; 
(defun VxListToArray (Typ Lst) 
 (vlax-make-variant 
  (vlax-safearray-fill 
   (vlax-make-safearray Typ (cons 0 (1- (length Lst)))) 
   Lst 
  ) 
 ) 
) 
 
Back 
 
VxArrayToList - Converts an array into a list 
 
 
; 
; -- Function VxArrayToList 
; Converts an array into a list. 
; Copyright: 
;   ?000 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Arr = Array [VARIANT] 
; Return [Typ]: 
;   > Standard List [LIST] 
;   > nil if array is empty 
; Notes: 
;   - Can't be used for multidimensional arrays. 
; 
(defun VxArrayToList (Arr / TmpVal) 
 (setq TmpVal (vlax-variant-value Arr)) 
 (if (safearray-value TmpVal) 
  (vlax-safearray->list TmpVal) 
  '() 
 ) 
) 
 
Back 
 
VxStringSubst - Substitutes one string for another, within a string 
 
 
; 
; -- Function VxStringSubst 
; Substitutes one string for another, within a string. 
; Copyright: 
;   ?001 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Fnd = Pattern [STR] 
;   Rep = Replace [STR] 
;   Stg = String to search [STR] 
; Return [Typ]: 
;   > Modified string [STR] 
; Notes: 
;   None 
; 
(defun VxStringSubst (Fnd Rep Stg / TmpStr) 
 (setq TmpStr Stg) 
 (while (vl-string-search Fnd TmpStr) 
  (setq TmpStr (vl-string-subst Rep Fnd TmpStr)) 
 ) 
 TmpStr 
) 
 
Back 
 
VxGetDriveInfos - Returns informations from the selected drive 
 
 
; 
; -- Function VxGetDriveInfos 
; Returns informations from the selected drive. 
; Copyright: 
;   ?001 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Drv = Drive character, eg. "C" or "C:" [STR] 
; Return [Typ]: 
;   > Drive infos '(TotalSize FreeSpace DriveType FileSystem SerialNumber 
;                   ShareName VolumeName) [LIST] 
;     Explanations: 
;     - TotalSize (kB) [REAL] 
;       Returns the total space of a drive or network share. 
;     - FreeSpace (kB) [REAL] 
;       Returns the amount of space available to a user on the specified drive 
;       or network share. 
;     - DriveType [INT] 
;       0 = "Unknown" 
;       1 = "Removable" 
;       2 = "Fixed" 
;       3 = "Network" 
;       4 = "CD-ROM" 
;       5 = "RAM Disk" 
;     - FileSystem [STR] 
;       Returns the type of file system in use for the specified drive, eg. 
;       "FAT", "NTFS", "CDFS". 
;     - SerialNumber [INT] 
;       Returns the serial number used to uniquely identify a disk volume. 
;     - ShareName [STR] 
;       Returns the network share name (UNC) for the specified drive. If it's 
;       not a network drive, ShareName returns a zero-length string (""). 
;     - VolumeName [STR] 
;       Returns the volume name of the specified drive. 
;   >  0 The drive doesn't exist. 
;   > -1 The drive is not ready. For removable-media drives and CD-ROM drives, 
;        VxGetDriveInfos returns -1 when the appropriate media is not inserted 
;        or not ready for access. 
; Notes: 
;   - Requires ScrRun.dll. 
; 
(defun VxGetDriveInfos (Drv / DrvObj FilSys RetVal) 
 (setq FilSys (vlax-create-object "Scripting.FileSystemObject") 
       RetVal (cond 
               ((= (vlax-invoke FilSys "DriveExists" Drv) 0) 0) 
               ((setq DrvObj (vlax-invoke FilSys "GetDrive" Drv)) 
                (cond 
                 ((= (vlax-get DrvObj "IsReady") 0) -1) 
                 ((list 
                   (/ (vlax-get DrvObj "TotalSize") 1000.0) 
                   (/ (vlax-get DrvObj "FreeSpace") 1000.0) 
                   (vlax-get DrvObj "DriveType") 
                   (vlax-get DrvObj "FileSystem") 
                   (vlax-get DrvObj "SerialNumber") 
                   (vlax-get DrvObj "ShareName") 
                   (vlax-get DrvObj "VolumeName") 
                  ) 
                 ) 
                ) 
               ) 
              ) 
 ) 
 (if DrvObj (vlax-release-object DrvObj)) 
 (vlax-release-object FilSys) 
 RetVal 
) 
 
Back 
 
VxGetFileInfos - Returns informations from the selected file 
 
 
; 
; -- VxGetFileInfos 
; Returns informations from the selected file. 
; Copyright: 
;   ?002 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Fil = Filename "C:\\Temp\\MyTemp\\Scrap.dwg" [STR] 
; Return [Typ]: 
;   > File infos '(DateCreated DateLastModified DateLastAccessed 
;                  Type Size Attributes) [LIST] 
;     Explanations: 
;     - DateCreated [REAL] 
;       Returns serial date/time. 
;     - DateLastModified [REAL] 
;       Returns serial date/time. 
;     - DateLastAccessed [REAL] 
;       Returns serial date/time. 
;     - Type [STR] 
;       Returns the registered file tape, eg. "AutoCAD Drawing". 
;     - Size (kB) [REAL] 
;       Returns the size of the file in kB. 
;     - Attributes [INT] 
;         0 = Normal file, no attributes are set. 
;         1 = Read-only file. 
;         2 = Hidden file. 
;         4 = System file. 
;         8 = Disk drive volume label. (not available in VxGetFileInfos) 
;        16 = Folder or directory. (not available in VxGetFileInfos) 
;        32 = File has changed since last backup. 
;        64 = Link or shortcut. 
;       128 = Compressed file. 
;   > nil If file doesn't exist 
; Notes: 
;   - Requires ScrRun.dll. 
; 
(defun VxGetFileInfos (Fil / FilObj FilSys RetVal) 
 (setq FilSys (vlax-create-object "Scripting.FileSystemObject") 
       RetVal (cond 
               ((= (vlax-invoke FilSys "FileExists" Fil) 0) nil) 
               ((setq FilObj (vlax-invoke FilSys "GetFile" Fil)) 
                (list 
                 (vlax-get FilObj "DateCreated") 
                 (vlax-get FilObj "DateLastModified") 
                 (vlax-get FilObj "DateLastAccessed") 
                 (vlax-get FilObj "Type") 
                 (/ (vlax-get FilObj "Size") 1000.0) 
                 (vlax-get FilObj "Attributes") 
                ) 
               ) 
               (T nil) 
              ) 
 ) 
 (if FilObj (vlax-release-object FilObj)) 
 (vlax-release-object FilSys) 
 RetVal 
) 
 
 
Back 
 
VxCopyFiles - Copies the specified file(s) 
 
 
; 
; -- VxCopyFiles 
; Copies the specified file(s). 
; Copyright: 
;   ?002 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Src = Source file(s) to copy "C:\\Temp\\AllScrap.*" [STR] 
;   Tar = Target directory/file "C:\\Scrap" [STR] 
; Return [Typ]: 
;   > T   VxCopyFiles succeed 
;     nil Error on copy file(s) 
; Notes: 
;   - Requires ScrRun.dll. 
; 
(defun VxCopyFiles (Src Tar / ErrObj FilSys RetVal) 
 (setq FilSys (vlax-create-object "Scripting.FileSystemObject") 
       ErrObj (vl-catch-all-apply 
              'vlax-invoke-method 
               (list FilSys 'CopyFile Src Tar :vlax-true) 
              ) 
       RetVal (not (vl-catch-all-error-p ErrObj)) 
 ) 
 (vlax-release-object FilSys) 
 RetVal 
) 
 
 
Back 
 
VxDeleteFiles - Deletes the specified file(s) 
 
 
; 
; -- VxDeleteFiles 
; Deletes the specified file(s). 
; Copyright: 
;   ?002 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Fil = File name(s) to delete "C:\\Temp\\AllScrap.*" [STR] 
; Return [Typ]: 
;   > T   VxDeleteFiles succeed 
;     nil Error on delete file(s) 
; Notes: 
;   - Requires ScrRun.dll. 
; 
(defun VxDeleteFiles (Fil / ErrObj FilSys RetVal) 
 (setq FilSys (vlax-create-object "Scripting.FileSystemObject") 
       ErrObj (vl-catch-all-apply 
              'vlax-invoke-method 
               (list FilSys 'DeleteFile Fil :vlax-true) 
              ) 
       RetVal (not (vl-catch-all-error-p ErrObj)) 
 ) 
 (vlax-release-object FilSys) 
 RetVal 
) 
 
Back 
 
VxCreateDirectory - Creates the specified directory(ies) 
 
 
; 
; -- VxMakeDirectory 
; Creates the specified directory(ies). 
; Copyright: 
;   ?001 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Dir = Folder to create, eg. "C:\\Temp\\MyTemp\\AllScrap" [STR] 
; Return [Typ]: 
;   > T   VxMakeDirectory succeed 
;     nil Error on creating directory(ies) 
; Notes: 
;   - Requires ScrRun.dll. 
; 
(defun VxMakeDirectory (Dir / CurDir DrvObj FilSys RetVal TmpLst TmpVal) 
 (setq FilSys (vlax-create-object "Scripting.FileSystemObject") 
       CurDir (vl-string-right-trim "\" (vl-string-right-trim "/" Dir)) 
 ) 
 (while (/= (setq TmpVal (vl-filename-directory CurDir)) CurDir) 
  (setq TmpLst (cons TmpVal TmpLst) 
        CurDir TmpVal 
  ) 
 ) 
 (setq RetVal (cond 
               ((= (vlax-invoke FilSys "DriveExists" TmpVal) 0) nil) 
               ((setq DrvObj (vlax-invoke FilSys "GetDrive" TmpVal)) 
                (cond 
                 ((= (vlax-get DrvObj "IsReady") 0) nil) 
                 (T 
                  (foreach memb TmpLst 
                   (cond 
                    ((= (vlax-invoke FilSys "FolderExists" memb) -1)) 
                    ((vlax-invoke FilSys "CreateFolder" memb)) 
                   ) 
                  ) 
                  (cond 
                   ((= (vlax-invoke FilSys "FolderExists" Dir) -1)) 
                   ((vlax-invoke FilSys "CreateFolder" Dir) T) 
                   (T nil) 
                  ) 
                 ) 
                ) 
               ) 
              ) 
 ) 
 (if DrvObj (vlax-release-object DrvObj)) 
 (vlax-release-object FilSys) 
 RetVal 
) 
 
 
Back 
 
VxDelDirectory - Deletes the specified directory 
 
 
; 
; -- VxDelDirectory 
; Deletes the specified directory. 
; Copyright: 
;   ?002 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Dir = Folder to delete "C:\\Temp\\MyTemp\\AllScrap" [STR] 
; Return [Typ]: 
;   > T   VxDelDirectory succeed 
;     nil Error on deleting directory 
; Notes: 
;   - Requires ScrRun.dll. 
; 
(defun VxDelDirectory (Dir / FilSys RetVal) 
 (setq FilSys (vlax-create-object "Scripting.FileSystemObject") 
       RetVal (cond 
               ((= (vlax-invoke FilSys "FolderExists" Dir) 0) nil) 
               (T (vlax-invoke FilSys "DeleteFolder" Dir :vlax-true) T) 
              ) 
 ) 
 (vlax-release-object FilSys) 
 RetVal 
) 
 
 
Back 
 
VxReadTextFile - Reads a textfile and returns a line list (fast) 
 
 
; 
; -- VxReadTextFile 
; Reads a textfile and returns a line list (fast). 
; Copyright: 
;   ?001 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Fil = (Path)Filename [STR] 
; Return [Typ]: 
;   > List of lines [LIST] 
;   > nil if file not found 
; Notes: 
;   - Requires ScrRun.dll. 
; 
(defun VxReadTextFile (Fil / FilObj FilPth FilSys OpnFil RetVal) 
 (if (setq FilPth (findfile Fil)) 
  (progn 
   (setq FilSys (vlax-create-object "Scripting.FileSystemObject") 
         FilObj (vlax-invoke FilSys "GetFile FilPth") 
         OpnFil (vlax-invoke FilObj "OpenAsTextStream" 1 0) 
   ) 
   (while (= (vlax-get OpnFil "AtEndOfStream") 0) 
    (setq RetVal (cons (vlax-invoke OpnFil "ReadLine") RetVal)) 
   ) 
   (vlax-invoke OpnFil "Close") 
   (vlax-release-object OpnFil) 
   (vlax-release-object FilObj) 
   (vlax-release-object FilSys) 
   (reverse RetVal) 
  ) 
  nil 
 ) 
) 
 
 
Back 
 
VxCreateShortCut - Creates a shortcut to AutoCAD with the appropriate... 
 
 
; 
; -- Function VxCreateShortCut 
; Creates a shortcut to AutoCAD with the appropriate parameters on the desktop. 
; Copyright: 
;   ?002 MENZI ENGINEERING GmbH, Switzerland 
; Arguments [Typ]: 
;   Scn = Shortcut name, "MyShortCut" [STR] 
;   Pro = Profile name, "MyProfile" [STR] 
;   Icn = (Path)Filename of the icon, "c:\\MyPath\\MyIcon.ico" [STR] 1) 
; Return [Typ]: 
;   > Shortcutpath if suceed [STR] 
;   > False on error 
; Notes: 
;   1) If nil, AutoCAD's first internal icon is used 
;   - Requires ScrRun.dll. 
; 
(defun VxCreateShortCut (Scn Pro Icn / DskPth IcnPar ExeFil RetVal ShoCut 
                                       SpcFld WscObj) 
 (setq ExeFil (findfile "acad.exe") 
       IcnPar (cond (Icn) ((strcat ExeFil ", 0"))) 
       WscObj (vlax-create-object "WScript.Shell") 
       RetVal (cond 
               ((setq SpcFld (vlax-get WscObj 'SpecialFolders)) 
                (setq DskPth (strcat 
                              (vla-Item SpcFld "Desktop") 
                              "\" Scn ".lnk" 
                             ) 
                      ShoCut (vlax-invoke WscObj "CreateShortcut" DskPth) 
                ) 
                (vlax-put-property ShoCut 'TargetPath ExeFil) 
                (vlax-put-property ShoCut 'Arguments (strcat "/p " Pro)) 
                (vlax-put-property ShoCut 'IconLocation IcnPar) 
                (vla-save ShoCut) 
                (findfile DskPth) 
               ) 
               (T Nil) 
              ) 
 ) 
 (vlax-release-object WscObj) 
 RetVal 
) 
 
 
Back 
 
ACAD2000.lsp - Drawing Reactor sample 
 
 
; 
; -- ACAD2000.lsp 
; Sets a DocManager Reactor to release the Gb:AcO and Gb:AcD objects at the 
; end of a AutoCAD session. 
; Copyright: 
;   ?000 MENZI ENGINEERING GmbH, Switzerland 
; Notes: 
;   None 
; 
(setq vlax-vbDecimal 14) ;Set missing Datatype 
 
(if s::startup 
 (defun-q-list-set 
 's::startup 
  (append 
   (defun-q-list-ref 's::startup) 
   (cdr (defun-q-list-ref 'InitReactor)) 
  ) 
 ) 
 (defun-q s::startup () (InitReactor) (princ)) 
) 
 
(defun-q InitReactor () 
 (prompt "\n>Initialize Document Reactor...") 
 (vl-load-com) 
 (if (not Gb:DmR) 
  (setq Gb:DmR (vlr-DocManager-Reactor 
                nil 
               '((:vlr-documentToBeDestroyed . CloseHandling)) 
               ) 
  ) 
 ) 
 (princ) 
) 
 
(defun CloseHandling (Rea Arg) 
 (if Gb:AcO (vlax-release-object Gb:AcO)) 
 (if Gb:AcD (vlax-release-object Gb:AcD)) 
 (vlr-remove-all :vlr-DocManager-Reactor) 
 (setq Gb:AcO nil 
       Gb:AcD nil 
       Gb:DmR nil 
 ) 
 (princ) 
) 
 
(princ) 
; 
; -- End ACAD2000.lsp 
  [/FONT]

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

[求助]：有人知道Excel中的Color和ColorIndex同AutoCAD的ACI/TrueColor之间的转换关系

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子