Terms of usage and legal liabilities:
Program code examples provided on this document are for informational purposes only. No warranties,
guarantees or promises are made, implied, given, or stated as to fitness or functionality of any portions
of the given information. User assumes any and all risks of consequential damages that may result from
any derivative or direct implementation of example code.
All code is the work of Jürg Menzi, MENZI ENGINEERING GmbH ©2000-2007 all rights reserved, unless
explicitly noted otherwise as being the work of another author. Any similarities to existing works by other
authors is entirely accidental and unintentional. No works are taken or accepted from other authors without
explicit permission and any such works are clearly noted as to their source if not the owner of this site.
Users that do not accept these Terms and Conditions are not authorised to use or adapt this work for any
reason in any form whatsoever.
|
Notes:
- Before using the Vx-Functions, issue the command (vl-load-com) to initialize ActiveX support.
- Vx-Functions requires vla-objects, not entities. Convert entities with (vlax-ename->vla-object EntName).
- There is also a collection of Vx components using the Windows Script Technologies. This functions
require ScrRun.dll from Windows Script Components (WinNT4/9x/ME only, included in Win2k+).
|
Questions, comments, ideas or corrections? Please e-mail your feedback to us.
|
|
|
|
|
|
|
| |
|
VxAlignAtts
- Rotates all attributes of a block to n°
|
|
;
; -- Function VxAlignAtts
; Rotates all attributes of a block to n°.
; Copyright:
; ©2000 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Obj = Object [VLA-OBJECT]
; Ang = Angle (Radians) [REAL]
; Return [Type]:
; > Null
; Notes:
; - None
;
(defun VxAlignAtts (Obj Ang)
(mapcar
'(lambda (Att) (vla-put-Rotation Att Ang))
(vlax-invoke Obj 'GetAttributes)
)
(vla-update Obj)
(princ)
)
|
|
Back
|
|
VxGetAtts
- Reads all attribute values from a block
|
|
;
; -- Function VxGetAtts
; Reads all attribute values from a block.
; Copyright:
; ©2000 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Obj = Object [VLA-OBJECT]
; Return [Type]:
; > Dotted pair list '(("Tag1" . "Val1")...) [LIST]
; Notes:
; - None
;
(defun VxGetAtts (Obj)
(mapcar
'(lambda (Att)
(cons (vla-get-TagString Att)
(vla-get-TextString Att)
)
)
(vlax-invoke Obj 'GetAttributes)
)
)
|
|
Back
|
|
VxSetAtts
- Sets attribute values to block
|
|
;
; -- Function VxSetAtts
; Sets attribute values to block.
; Copyright:
; ©2000 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Obj = Object [VLA-OBJECT]
; Lst = Dotted pair list '(("Tag1" . "Val1")...) [LIST]
; Return [Type]:
; > Null
; Notes:
; - None
;
(defun VxSetAtts (Obj Lst / AttVal)
(mapcar
'(lambda (Att)
(if (setq AttVal (cdr (assoc (vla-get-TagString Att) Lst)))
(vla-put-TextString Att AttVal)
)
)
(vlax-invoke Obj 'GetAttributes)
)
(vla-update Obj)
(princ)
)
|
|
Back
|
|
VxGetOpenDwgs
- Returns a list of all open drawings including path
|
|
;
; -- Function VxGetOpenDwgs
; Returns a list of all open Drawing names including path.
; Copyright:
; ©2001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; None
; Return [Type]:
; > Drawing names [LIST]
; Notes:
; - None
;
(defun VxGetOpenDwgs ( / DwgLst DwgNme)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(vlax-for Doc (vla-get-Documents Gb:AcO)
(if (/= (setq DwgNme (vla-get-Fullname Doc)) "")
(setq DwgLst (cons DwgNme DwgLst))
)
)
(reverse DwgLst)
)
|
|
Back
|
|
VxGetTextStyles
- Returns a list of all text style names and her font files
|
|
;
; -- Function VxGetTextStyles
; Returns a list of all text style names and her font files.
; Copyright:
; ©2001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; None
; Return [Type]:
; > Dotted pair list '(("StyleName" . "FontFile")...) [LIST]
; Notes:
; - None
;
(defun VxGetTextStyles ( / StyLst)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(or Gb:AcD (setq Gb:AcD (vla-get-ActiveDocument Gb:AcO)))
(vlax-for Sty (vla-get-TextStyles Gb:AcD)
(setq StyLst (cons
(cons
(vla-get-Name Sty)
(vla-get-FontFile Sty)
)
StyLst
)
)
)
(reverse StyLst)
)
|
|
Back
|
|
VxGetLineTypes
- Returns a list of all line types and her descriptions
|
|
;
; -- Function VxGetLineTypes
; Returns a list of all line types and her descriptions.
; Copyright:
; ©2001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; None
; Return [Type]:
; > Dotted pair list '(("LtpName" . "Description")...) [LIST]
; Notes:
; - None
;
(defun VxGetLineTypes ( / LtpLst)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(or Gb:AcD (setq Gb:AcD (vla-get-ActiveDocument Gb:AcO)))
(vlax-for Ltp (vla-get-LineTypes Gb:AcD)
(setq LtpLst (cons
(cons
(vla-get-Name Ltp)
(vla-get-Description Ltp)
)
LtpLst
)
)
)
(reverse LtpLst)
)
|
|
Back
|
|
VxGetDimStyles
- Returns a list of all dimension style names
|
|
;
; -- Function VxGetDimStyles
; Returns a list of all dimension style names.
; Copyright:
; ©2001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; None
; Return [Type]:
; > List of Dim style names [LIST]
; Notes:
; - None
;
(defun VxGetDimStyles ( / DstLst)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(or Gb:AcD (setq Gb:AcD (vla-get-ActiveDocument Gb:AcO)))
(vlax-for Dst (vla-get-DimStyles Gb:AcD)
(setq DstLst (cons (vla-get-Name Dst) DstLst))
)
(reverse DstLst)
)
|
|
Back
|
|
VxGetXplotLayers
- Returns a list of all plot or non plot layers
|
|
;
; -- Function VxGetXplotLayers
; Returns a list of all plot or non plot layers.
; Copyright:
; ©2000 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Mde = Flag [SYM]
; Constants:
; - :vlax-true Plot layers
; - :vlax-false Non plot layers
; Return [Type]:
; > Layer names [LIST]
; Notes:
; - None
;
(defun VxGetXplotLayers (Mde / NmeLst)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(or Gb:AcD (setq Gb:AcD (vla-get-ActiveDocument Gb:AcO)))
(vlax-for Obj (vla-get-Layers Gb:AcD)
(if (= (vla-get-plottable Obj) Mde)
(setq NmeLst (cons (vla-get-name Obj) NmeLst))
)
(vlax-release-object Obj)
)
(reverse NmeLst)
)
|
|
Back
|
|
VxGetLockLayers
- Returns a list of all locked layers
|
|
;
; -- Function VxGetLockLayers
; Returns a list of all locked layers.
; Copyright:
; ©2004 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; --- =
; Return [Type]:
; > Layer names [LIST]
; Notes:
; - None
;
(defun VxGetLockLayers ( / NmeLst)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(or Gb:AcD (setq Gb:AcD (vla-get-ActiveDocument Gb:AcO)))
(vlax-for Obj (vla-get-Layers Gb:AcD)
(if (= (vla-get-Lock Obj) :vlax-true)
(setq NmeLst (cons (vla-get-name Obj) NmeLst))
)
(vlax-release-object Obj)
)
(reverse NmeLst)
)
|
|
Back
|
|
VxIsOnLockedLay
- Check an object for locked layer
|
|
;
; -- Function VxIsOnLockedLay
; Check an object for locked layer.
; Copyright:
; ©2004 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Obj = Object [VLA-OBJECT]
; Return [Type]:
; > :vlax-true = Object is on a locked layer [SYM]
; > :vlax-false = Object is not on a locked layer [SYM]
; Notes:
; - None
;
(defun VxIsOnLockedLay (Obj)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(or Gb:AcD (setq Gb:AcD (vla-get-ActiveDocument Gb:AcO)))
(vla-get-Lock
(vla-Item
(vla-get-Layers Gb:AcD)
(vla-get-Layer Obj)
)
)
)
|
|
Back
|
|
VxGetLayoutNames
- Returns a list of all Layout names
|
|
;
; -- Function VxGetLayoutNames
; Returns a list of all Layout names.
; Copyright:
; ©2000 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; --- =
; Return [Type]:
; > Layout names [LIST]
; Notes:
; - None
;
(defun VxGetLayoutNames ( / NmeLst)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(or Gb:AcD (setq Gb:AcD (vla-get-ActiveDocument Gb:AcO)))
(vlax-for obj (vla-get-layouts Gb:AcD)
(setq NmeLst (cons (vla-get-name obj) NmeLst))
(vlax-release-object Obj)
)
(reverse NmeLst)
)
|
|
Back
|
|
VxGetVptBoundary
- Returns the lower left and upper right corner of a view...
|
|
;
; -- Function VxGetVptBoundary
; Returns the lower left and upper right corner of a viewport in model space
; coordinates.
; Copyright:
; ©2002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Obj = Viewport object [VLA-OBJECT]
; Return [Type]:
; > Point list [LIST]
; Notes:
; - None
;
(defun VxGetVptBoundary (Obj / VptCen XofSet YofSet)
(setq VptCen (vlax-get Obj 'Center)
XofSet (/ (vla-get-Width Obj) 2.0)
YofSet (/ (vla-get-Height Obj) 2.0)
)
(list
(trans (list (- (car VptCen) XofSet) (- (cadr VptCen) YofSet)) 3 2)
(trans (list (+ (car VptCen) XofSet) (+ (cadr VptCen) YofSet)) 3 2)
)
)
|
|
Back
|
|
VxGetLoadedMenus
- Returns a list of all loaded Menu files and Groups
|
|
;
; -- Function VxGetLoadedMenus
; Returns a list of all loaded Menu files and Groups.
; Copyright:
; ©2000 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; --- =
; Return [Type]:
; > Dotted pair list '(("MenuFile" . "MenuGroup")...) [LIST]
; Notes:
; - None
;
(defun VxGetLoadedMenus ( / MnuLst)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(vlax-for Obj (vla-get-MenuGroups Gb:AcO)
(setq MnuLst (cons
(cons
(vla-get-MenuFileName Obj)
(vla-get-Name Obj)
)
MnuLst
)
)
(vlax-release-object Obj)
)
(reverse MnuLst)
)
|
|
Back
|
|
VxUnLoadMenuGroup
- Unloads the specified Menu Group
|
|
;
; -- Function VxUnLoadMenuGroup
; Unloads the specified Menu Group.
; Copyright:
; ©2002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Nme = Menu group name [STR]
; Return [Type]:
; > Null
; Notes:
; - None
;
(defun VxUnLoadMenuGroup (Nme)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(vlax-for Obj (vla-get-MenuGroups Gb:AcO)
(if (eq (vla-get-Name Obj) Nme)
(vla-unload Obj)
)
(vlax-release-object Obj)
)
(princ)
)
|
|
Back
|
|
VxGetPopups
- Returns a list with all Menu groups, PopupID's and their ...
|
|
;
; -- Function VxGetPopups
; Returns a list with all Menu groups, PopupID's and their IsContext property.
; Copyright:
; ©2000 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; --- =
; Return [Type]:
; > Nested dotted pair list:
; '(("MenuGroup" . '(("PopupID" . IsContext)...))...) [LIST]
; Notes:
; - If you want to list the menu names in place of the ID's,
; change the property vla-get-TagString to vla-get-Name, see *)
;
(defun VxGetPopups ( / PopLst TmpLst)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(vlax-for Grp (vla-get-MenuGroups Gb:AcO)
(setq TmpLst '())
(vlax-for Pop (vla-get-Menus Grp)
(setq TmpLst (cons
(cons
(vla-get-TagString Pop) ;*)
(if (= (vla-get-OnMenuBar Pop) :vlax-false) 1 0)
)
TmpLst
)
)
(vlax-release-object Pop)
)
(setq PopLst (cons
(cons
(vla-get-Name Grp)
(reverse TmpLst)
)
PopLst
)
)
(vlax-release-object Grp)
)
(reverse PopLst)
)
|
|
Back
|
|
VxGetToolbars
- Returns a list with all Menu groups, ToolbarID's and their...
|
|
;
; -- Function VxGetToolbars
; Returns a list with all Menu groups, ToolbarID's and their IsVisible property.
; Copyright:
; ©2000 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; --- =
; Return [Type]:
; > Nested dotted pair list:
; '(("MenuGroup" . '(("ToolbarID" . IsVisible)...))...) [LIST]
; Notes:
; - If you want to list the menu names in place of the ID's,
; change the property vla-get-TagString to vla-get-Name, see *)
;
(defun VxGetToolbars ( / TlbLst TmpLst)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(vlax-for Grp (vla-get-MenuGroups Gb:AcO)
(setq TmpLst '())
(vlax-for Tlb (vla-get-Toolbars Grp)
(setq TmpLst (cons
(cons
(vla-get-TagString Tlb) ;*)
(if (= (vla-get-visible Tlb) :vlax-true) 1 0)
)
TmpLst
)
)
(vlax-release-object Tlp)
)
(setq TlbLst (cons
(cons
(vla-get-Name Grp)
(reverse TmpLst)
)
TlbLst
)
)
(vlax-release-object Grp)
)
(reverse TlbLst)
)
|
|
Back
|
|
VxXetDispCmdLines
- Sets or gets the number of command lines
|
|
;
; -- Function VxXetDispCmdLines
; Sets or gets the number of command lines.
; Copyright:
; ©2001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Mde = Mode, Values:
; - Nil (VxGetDispCmdLines) [SYM]
; - Number of command lines (VxSetDispCmdLines) [INT]
; Return [Type]:
; > Number of command lines (Mde = Nil) [INT]
; > Nil (Mde = Number) [SYM]
; Notes:
; - If Mde is numeric, it must be > 0.
; - AutoCAD 2k0/2k2 only, not available in 2k4+
;
(defun VxXetDispCmdLines (Mde / DspObj)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(setq DspObj (vla-get-Display (vla-get-Preferences Gb:AcO)))
(if (numberp Mde)
(vla-put-DockedVisibleLines DspObj Mde)
(vla-get-DockedVisibleLines DspObj)
)
)
|
|
Back
|
|
VxXetDispHistLines
- Sets or gets the number of history lines in the text...
|
|
;
; -- Function VxXetDispHistLines
; Sets or gets the number of history lines in the text window.
; Copyright:
; ©2001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Mde = Mode, Values:
; - Nil (VxGetDispHistLines) [SYM]
; - Number of history lines (VxSetDispHistLines) [INT]
; Return [Type]:
; > Number of history lines (Mde = Nil) [INT]
; > Nil (Mde = Number) [SYM]
; Notes:
; - If Mde is numeric, it must be >= 25 and <= 2048.
;
(defun VxXetDispHistLines (Mde / DspObj)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(setq DspObj (vla-get-Display (vla-get-Preferences Gb:AcO)))
(if (numberp Mde)
(vla-put-HistoryLines DspObj Mde)
(vla-get-HistoryLines DspObj)
)
)
|
|
Back
|
|
VxGetLoadedVbaProjs
- Returns a list of all loaded VBA-Project names
|
|
;
; -- Function VxGetLoadedVbaProjs
; Returns a list of all loaded VBA-Project names.
; Copyright:
; ©2000 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; --- =
; Return [Type]:
; > VBA-Project names [LIST]
; Notes:
; - None
;
(defun VxGetLoadedVbaProjs ( / AllPrj IndCnt PrjLst)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(setq AllPrj (vlax-get-property
(vla-get-VBE Gb:AcO)
'VbProjects
)
IndCnt 1
)
(repeat (vla-get-Count AllPrj)
(setq PrjLst (cons
(vla-get-Name (vla-Item AllPrj IndCnt))
PrjLst
)
IndCnt (1+ IndCnt)
)
)
(reverse PrjLst)
)
|
|
Back
|
|
VxGetDispBackCol
- Returns the ACI-ColorNº of the actual graphics...
|
|
;
; -- Function VxGetDispBackCol
; Returns the ACI-ColorNº of the actual graphics background.
; Copyright:
; ©2000 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; None
; Return [Type]:
; > ACI-Colornumber of the active space background [INT]
; Notes:
; - None
;
(defun VxGetDispBackCol ( / DspObj)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(setq DspObj (vla-get-display (vla-get-preferences Gb:AcO)))
(VxOleToAciCol
(if (= (caar (vports)) 1)
(vla-get-GraphicsWinLayoutBackgrndColor DspObj)
(vla-get-GraphicsWinModelBackgrndColor DspObj)
)
)
)
|
|
Back
|
|
VxOleToAciCol
- Converts a OLE- to a ACI-Colornumber
|
|
;
; -- Function VxOleToAciCol
; Converts a OLE- to a ACI-Colornumber.
; Copyright:
; ©2000 Jimmy Bergmark
; Arguments [Type]:
; OleCol = OLE-Colornumber [INT]
; Return [Type]:
; > ACI-Colornumber [INT]
; Notes:
; - Thanx Jimmy Bergmark 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
|
|
VxGetTrueCol
- Returns a TrueColor list from an object
|
|
;
; -- Function VxGetTrueCol
; Returns a TrueColor list from an object.
; Arguments [Type]:
; Obj = Object to read [VLA-OBJECT]
; Return [Type]:
; > ColorMethod and Color or RGB list '(CM (R G B)) [LIST]
; Notes:
; - AutoCAD 2k4+ only
;
(defun VxGetTrueCol (Obj / ColObj ColMet)
(setq ColObj (vla-get-TrueColor Obj)
ColMet (vla-get-ColorMethod ColObj)
)
(cons
ColMet
(if (= ColMet acColorMethodByRGB)
(mapcar '(lambda (l) (vlax-get ColObj l)) '(Red Green Blue))
(vla-get-ColorIndex ColObj)
)
)
)
|
|
Back
|
|
VxSetTrueCol
- Applies a TrueColor list to an object
|
|
;
; -- Function VxSetTrueCol
; Applies a TrueColor list to an object.
; Arguments [Type]:
; Obj = Object to modify [VLA-OBJECT]
; Lst = ColorMethod and Color or RGB list '(CM (R G B)) [LIST]
; ColorMethodes:
; - acColorMethodByACI
; - acColorMethodByBlock
; - acColorMethodByLayer
; - acColorMethodByRGB
; - acColorMethodForeground
; Return [Type]:
; > Modified object [VLA-OBJECT]
; Notes:
; - AutoCAD 2k4+ only
;
(defun VxSetTrueCol (Obj Lst / ColObj ColMet)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(setq ColObj (vla-GetInterfaceObject Gb:AcO "AutoCAD.AcCmColor.16")
ColMet (car Lst)
)
(vla-put-ColorMethod ColObj ColMet)
(if (= ColMet acColorMethodByRGB)
(vla-SetRGB ColObj (cadr Lst) (caddr Lst) (cadddr Lst))
(vla-put-ColorIndex ColObj (cdr Lst))
)
(vla-put-TrueColor Obj ColObj)
(vlax-release-object ColObj)
Obj
)
|
|
Back
|
|
VxDeleteGroup
- Deletes a group by name
|
|
;
; -- Function VxDeleteGroup
; Deletes a group by name.
; Copyright:
; ©2000 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Nme = Group name [STR]
; Return [Type]:
; > Null
; Notes:
; - None
;
(defun VxDeleteGroup (Nme)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(or Gb:AcD (setq 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:
; ©2001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Obj = Object [VLA-OBJECT]
; Return [Type]:
; > Group name(s) [LIST]
; Notes:
; - None
;
(defun VxGetGroupNames (Obj / Cur_ID NmeLst)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(or Gb:AcD (setq Gb:AcD (vla-get-activedocument Gb:AcO)))
(setq 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
|
|
VxGetAcadLicenseInfos
- Returns the license information's of the current...
|
|
;
; -- Function VxGetAcadLicenseInfos
; Returns the license information's of the current AutoCAD version
; like ProductName, Release, SerialNumber, Language, etc.
; Copyright:
; ©2004 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; None
; Return [Type]:
; > License information's '((Info1 . Value1)...) [STR]
; Notes:
; - The number of information's depends on the AutoCAD version
;
(defun VxGetAcadLicenseInfos ( / KeyLst RegPth RetVal)
(setq RegPth (strcat "HKEY_LOCAL_MACHINE\\" (vlax-product-key))
KeyLst (vl-registry-descendents RegPth T)
)
(foreach memb KeyLst
(if (not (eq memb ""))
(setq RetVal (cons
(cons memb (vl-registry-read RegPth memb))
RetVal
)
)
)
)
(reverse RetVal)
)
|
|
Back
|
|
VxGetAcadLanguage
- Returns the *program* language of the current...
|
|
;
; -- Function VxGetAcadLanguage
; Returns the *program* language of the current AutoCAD version.
; Copyright:
; ©2004 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; None
; Return [Type]:
; > Language ("English", "Deutsch", "Français", etc.) [STR]
; Notes:
; - None
;
(defun VxGetAcadLanguage ( / RegPth)
(setq RegPth (strcat "HKEY_LOCAL_MACHINE\\" (vlax-product-key)))
(vl-registry-read RegPth "Language")
)
|
|
Back
|
|
VxScrollDocs
- Scrolls the open docs in alphabetic order up or down
|
|
;
; -- Function VxScrollDocs
; Scrolls the open docs in alphabetic order up or down.
; Copyright:
; ©2004 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Dir = Direction "U" or "D" (Up or Down) [STR]
; Return [Type]:
; > Null
; Notes:
; - Load this function by AcadDoc.lsp to have it available in each
; document
;
(defun VxScrollDocs (Dir / DocCol DocLst DocNum DocObj MaxPos MovDir)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(setq DocCol (vlax-get Gb:AcO 'Documents))
(if (> (vla-get-Count DocCol) 1)
(progn
(vlax-for DocObj DocCol
(setq DocLst (cons (cons (vla-get-Name DocObj) DocObj) DocLst))
)
(setq DocLst (vl-sort
DocLst
(function
(lambda (a b)
(< (strcase (car a)) (strcase (car b)))
)
)
)
MaxPos (1- (length DocLst))
MovDir (eq (strcase Dir) "D")
DocNum (vl-position (getvar 'DWGNAME) (mapcar 'car DocLst))
DocNum (cond
((and MovDir (< DocNum MaxPos)) (1+ DocNum))
((and MovDir (= DocNum MaxPos)) 0)
((> DocNum 0) (1- DocNum))
(MaxPos)
)
)
(vlax-put Gb:AcO 'Activedocument (cdr (nth DocNum DocLst)))
)
)
(princ)
)
|
|
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:
; ©2001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Obj = Object [VLA-OBJECT]
; Return [Type]:
; > 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)
;
(defun VxGetMassProps (Obj / DelFlg ResLst TmpObj)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(or Gb:AcD (setq 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:
; ©2000 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; 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 [Type]:
; > 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:
; ©2001-2002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; 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 [Type]:
; > list of points '((1.0 1.0 0.0)... [LIST]
; > Nil if no intersection found
; Notes:
; - Because of a (reported) bug in A2k4/A2k5/A2k6, the used explode method
; will fail on NUS blocks. No limitations in A2k, A2ki and A2k2
;
(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
|
|
VxCloneBlockRef
- Clones the specified block reference to a new name
|
|
;
; -- Function VxCloneBlockRef
; Clones the specified block reference to a new name.
; Copyright:
; ©2004 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Src = Source block reference name [STR]
; Tar = Target block reference name [STR]
; Return [Type]:
; > New block reference object [VLA_OBJECT]
; > Nil if source name not exists, target name exists or ObjectDBX error
; Notes:
; - Credits to Tony Tanzillo
; - For A2k-A2k2 you need to register axdb15.dll by regsvr32, no need
; to do that for A2k4+
;
(defun VxCloneBlockRef (Src Tar / DbxDoc DbxStr SrcBlk SrcCol TarBlk TarCol)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(or Gb:AcD (setq Gb:AcD (vla-get-ActiveDocument Gb:AcO)))
(setq DbxStr (if (< (atof (getvar "ACADVER")) 16.0)
"ObjectDBX.AxDbDocument"
"ObjectDBX.AxDbDocument.16"
)
)
(if (and
(tblsearch "BLOCK" Src)
(not (tblsearch "BLOCK" Tar))
(not
(vl-catch-all-error-p
(setq DbxDoc (vl-catch-all-apply
'vla-GetInterfaceObject (list Gb:AcO DbxStr)
)
)
)
)
)
(progn
(setq SrcCol (vla-get-Blocks Gb:AcD)
TarCol (vla-get-Blocks DbxDoc)
SrcBlk (vla-Item SrcCol Src)
)
(vlax-invoke Gb:AcD 'CopyObjects (list SrcBlk) TarCol)
(setq TarBlk (vla-Item TarCol Src))
(vla-put-Name TarBlk Tar)
(vlax-invoke DbxDoc 'CopyObjects (list TarBlk) SrcCol)
(vlax-release-object DbxDoc)
(vla-Item (vla-get-Blocks Gb:AcD) Tar)
)
)
)
|
|
Back
|
|
VxExplode
- Explodes complex objects
|
|
;
; -- Function VxExplode
; Explodes complex objects.
; Copyright:
; ©2001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Obj = Complex object [VLA-OBJECT]
; Del = Delete mode [SYM]
; - T = Delete base object
; - nil = Keep base object
; Return [Type]:
; > Selection set [PICKSET]
; Notes:
; - Because of a (reported) bug in A2k4/A2k5/A2k6, the used explode method
; will fail on NUS blocks. No limitations in A2k, A2ki and A2k2
;
(defun VxExplode (Obj Del / CurSet ExpMde)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(or Gb:AcD (setq Gb:AcD (vla-get-ActiveDocument Gb:AcO)))
(setq ExpMde (vla-GetVariable Gb:AcD "EXPLMODE")
CurSet (ssadd)
)
(vla-SetVariable Gb:AcD "EXPLMODE" 1)
(foreach memb (vlax-invoke Obj 'Explode)
(ssadd (vlax-vla-object->ename memb) CurSet)
)
(if Del (vla-delete Obj))
(vla-SetVariable Gb:AcD "EXPLMODE" ExpMde)
CurSet
)
|
|
Back
|
|
VxGetTangentAtPoint
- Returns the tangent at the specific point
|
|
;
; == Function VxGetTangentAtPoint
; Returns the tangent at the specified point.
; Copyright:
; ©2004 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Obj = Object [VLA-OBJECT/ENAME]
; Pnt = Point on object [LIST]
; Return [Type]:
; > Tangent angle at point [REAL]
; > False if point is not on object.
; Notes:
; - None
;
(defun VxGetTangentAtPoint (Obj Pnt / CurPar PntLst TmpPnt)
(setq PntLst (VxGetEndPoints Obj)
CurPar (cond
((equal Pnt (car PntLst) 1E-5)
(vlax-curve-getStartParam Obj)
)
((equal Pnt (cadr PntLst) 1E-5)
(vlax-curve-getEndParam Obj)
)
((setq TmpPnt (vlax-curve-getClosestPointTo Obj Pnt))
(if (<= (distance TmpPnt Pnt) 1E-5)
(vlax-curve-getParamAtPoint Obj TmpPnt)
)
)
(T nil)
)
)
(if CurPar
(angle
'(0.0 0.0 0.0)
(vlax-curve-getFirstDeriv Obj CurPar)
)
)
)
|
|
Back
|
|
VxGetEndPoints
- Returns the endpoints of an object
|
|
;
; -- Function VxGetEndPoints
; Returns the endpoints of an object.
; Copyright:
; ©2004 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Obj = Object [VLA-OBJECT/ENAME]
; Return [Type]:
; > Endpoints '((x y z) (x y z)) [LIST]
; > Nil if invalid object
; Notes:
; - Proceeds *Polyline, Spline, Ellipse, Line and Arc
;
(defun VxGetEndPoints (Obj)
(list
(vlax-curve-getStartPoint Obj)
(vlax-curve-getEndPoint Obj)
)
)
|
|
Back
|
|
VxRevPline
- Reverse vertex order of Polylines
|
|
;
; -- Function VxRevPline
; Reverse vertex order of Polylines.
; Copyright:
; ©2004 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Obj = Pline object [VLA-OBJECT]
; Return [Type]:
; > Pline object reversed [VLA-OBJECT]
; Notes:
; - Credits to Angeliki Anastasopoulou
;
(defun VxRevPline (Obj / BlgLst ObjName PntLst SegCnt TmpLst Ubound)
(setq ObjName (strcase (vlax-get Obj 'ObjectName))
TmpLst (vlax-get Obj 'Coordinates)
)
(if (eq ObjNme "AcDbPolyline")
(repeat (/ (length TmpLst) 2)
(setq PntLst (cons (list (car TmpLst) (cadr TmpLst)) PntLst)
TmpLst (cddr TmpLst)
)
)
(repeat (/ (length TmpLst) 3)
(setq PntLst (cons (list (car TmpLst) (cadr TmpLst) (caddr TmpLst)) PntLst)
TmpLst (cdddr TmpLst)
)
)
)
(vlax-put Obj 'Coordinates (apply 'append PntLst))
(if (not (eq ObjNme "AcDb3dPolyline"))
(progn
(setq Ubound (1- (length PntLst))
BlgLst (list (* (vla-GetBulge Obj Ubound) -1))
SegCnt 0
)
(repeat Ubound
(setq BlgLst (cons (* (vla-GetBulge Obj SegCnt) -1) BlgLst)
SegCnt (1+ SegCnt)
)
)
(setq SegCnt 0)
(foreach memb BlgLst
(vla-SetBulge Obj SegCnt memb)
(setq SegCnt (1+ SegCnt))
)
)
)
(vla-Update Obj)
Obj
)
|
|
Back
|
|
VxGetObjLength
- Returns the length of all kind of objects
|
|
;
; -- Function VxGetObjLength
; Returns the length of all kind of objects.
; Copyright:
; ©2001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Obj = Object [VLA-OBJECT/ENAME]
; Return [Type]:
; > Length of the object [REAL]
; Notes:
; - Proceeds *Polylines, Splines, Lines, Arcs, Circles and Ellipses
;
(defun VxGetObjLength (Obj)
(vlax-curve-getDistAtParam Obj (vlax-curve-getEndParam Obj))
)
|
|
Back
|
|
VxSetDrawOrder
- Changes draw order of object(s) by given method
|
|
;
; -- Function VxSetDrawOrder
; Changes draw order of object(s) by given method.
; Copyright:
; ©2004 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Obl = Object list [LIST]
; Tob = Target object [VLA-OBJECT] *)
; or nil
; Mde = Draw order method [SYMBOL]
; Methods:
; - 'MoveToTop
; - 'MoveToBottom
; - 'MoveAbove
; - 'MoveBelow
; Return [Type]:
; - True = VxSetDrawOrder succeed [BOOLEAN]
; - False = VxSetDrawOrder failed [BOOLEAN]
; Notes:
; *) Draw order methods 'MoveAbove and 'MoveBelow require
; a target object (Tob) as target of the draw order.
; - AutoCAD 2k5+ only (Bug? <2k5 missing class 'AcDbSortentsTable')
;
(defun VxSetDrawOrder (Obl Tob Mde / ExtDic SreTbl)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(or Gb:AcD (setq Gb:AcD (vla-get-ActiveDocument Gb:AcO)))
(setq ExtDic (vla-GetExtensionDictionary (vla-get-ModelSpace Gb:AcD)))
(if (vl-catch-all-error-p
(setq SreTbl (vl-catch-all-apply
'vla-Item (list ExtDic "ACAD_SORTENTS")
)
)
)
(setq SreTbl (vla-AddObject ExtDic "ACAD_SORTENTS" "AcDbSortentsTable"))
)
(cond
((vl-position Mde '(MoveToTop MoveToBottom))
(not (vlax-Invoke SreTbl Mde Obl))
)
(Tob
(not (vlax-Invoke SreTbl Mde Obl Tob))
)
)
)
|
|
Back
|
|
VxSsetSelect
- ActiveX counterpart to 'ssget'
|
|
;
; -- Function VxSsetSelect
; ActiveX counterpart to 'ssget'.
; Copyright:
; ©2002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; 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 [Type]:
; > 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:
; ©2002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Nme = Selection set name [STR]
; Return [Type]:
; > New selection set [VLA-OBJECT]
; Notes:
; - None
;
(defun VxSsetMake (Nme / SetCol)
(or Gb:AcO (setq Gb:AcO (vlax-get-acad-object)))
(or Gb:AcD (setq Gb:AcD (vla-get-activedocument Gb:AcO)))
(setq 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 methods
|
|
;
; -- Function VxSsetFilter
; Creates a filter for the SelectXxx methods.
; Copyright:
; ©2002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Flt = Dotted pair list '((0 . "Name")...(8 . "Layer")) [LIST]
; Return [Type]:
; > List of two arrays '(TypArr DatArr) [LIST]
; Notes:
; - None
;
(defun VxSsetFilter (Flt)
(mapcar
'(lambda (Typ Dat) (VxListToArray Dat Typ))
(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:
; ©2000 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; 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 [Type]:
; > Array [VARIANT]
; Notes:
; *)Missing data type in Visual LISP, initialize it in your Autoloader.
; - Can't be used for dotted pair or nested lists.
;
(defun VxListToArray (Lst Typ)
(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:
; ©2000 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Arr = Array [VARIANT]
; Return [Type]:
; > 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.
; ©2001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Fnd = Pattern [STR]
; Rep = Replace [STR]
; Stg = String to search [STR]
; Return [Type]:
; > Modified string [STR]
; Notes:
; - None
;
(defun VxStringSubst (Fnd Rep Stg / StrLgt StrPos TmpStr)
(setq TmpStr Stg
StrLgt (strlen Rep)
StrPos 0
)
(while (and
(not (eq TmpStr ""))
(setq StrPos (vl-string-search Fnd TmpStr StrPos))
)
(setq TmpStr (vl-string-subst Rep Fnd TmpStr StrPos)
StrPos (+ StrPos StrLgt)
)
)
TmpStr
)
|
|
Back
|
|
VxGetDriveInfos
- Returns information's from a drive
|
|
;
; -- Function VxGetDriveInfos
; Returns information's from a drive.
; Copyright:
; ©2001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Drv = Drive character, e.g. "C" or "C:" [STR]
; Return [Type]:
; > 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, e.g.
; "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 (see also notes at top of page).
;
(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 information's from a file
|
|
;
; -- VxGetFileInfos
; Returns information's from a file.
; Copyright:
; ©2002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Fil = Filename "C:\\Temp\\MyTemp\\Scrap.dwg" [STR]
; Return [Type]:
; > 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, e.g. "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 (see also notes at top of page).
;
(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:
; ©2002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Src = Source file(s) to copy "C:\\Temp\\AllScrap.*" [STR]
; Tar = Target directory/file "C:\\Scrap" [STR]
; Return [Type]:
; > T VxCopyFiles succeed
; Nil Error on copy file(s)
; Notes:
; - Requires ScrRun.dll (see also notes at top of page).
;
(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:
; ©2002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Fil = File name(s) to delete "C:\\Temp\\AllScrap.*" [STR]
; Return [Type]:
; > T VxDeleteFiles succeed
; Nil Error on delete file(s)
; Notes:
; - Requires ScrRun.dll (see also notes at top of page).
;
(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:
; ©2001 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Dir = Folder to create, e.g. "C:\\Temp\\MyTemp\\AllScrap" [STR]
; Return [Type]:
; > T VxMakeDirectory succeed
; Nil Error on creating directory(ies)
; Notes:
; - Requires ScrRun.dll (see also notes at top of page).
;
(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:
; ©2002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Dir = Folder to delete "C:\\Temp\\MyTemp\\AllScrap" [STR]
; Return [Type]:
; > T VxDelDirectory succeed
; Nil Error on deleting directory
; Notes:
; - Requires ScrRun.dll (see also notes at top of page).
;
(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
|
|
VxListNetworkDrives
- Returns a list of all mapped network drives with UNC...
|
|
;
; -- Function VxListNetworkDrives
; Returns a list of all mapped network drives with UNC path.
; Copyright:
; ©2005 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; --- =
; Return [Type]:
; > List of mapped drives '(("X:" . "\\\\Server\\Xpath")...) [LIST]
; Notes:
; - Requires ScrRun.dll (see also notes at top of page).
;
(defun VxListNetworkDrives ( / DrvCol ItmCnt RetVal WsnObj)
(setq WsnObj (vlax-create-object "WScript.Network")
DrvCol (vlax-invoke WsnObj 'EnumNetworkDrives)
ItmCnt 0
)
(repeat (/ (vlax-invoke DrvCol 'Count) 2)
(setq RetVal (cons
(cons
(strcase (vla-Item DrvCol ItmCnt))
(vla-Item DrvCol (1+ ItmCnt))
)
RetVal
)
ItmCnt (+ ItmCnt 2)
)
)
(vlax-release-object WsnObj)
(reverse RetVal)
)
|
|
Back
|
|
VxRemapNetworkDrives
- Remaps a network drive to another drive letter
|
|
;
; -- Function VxRemapNetworkDrive
; Remaps a network drive to another drive letter.
; Copyright:
; ©2005 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Old = Old drive letter, e.g. "X:" [STR]
; New = New drive letter, e.g. "Y:" [STR]
; Return [Type]:
; > True: Remapping successful
; > False: Remapping failed
; Notes:
; - Requires ScrRun.dll (see also notes at top of page).
;
(defun VxRemapNetworkDrive (Old New / OldUnc RetVal WsnObj)
(setq WsnObj (vlax-create-object "WScript.Network")
OldUnc (cdr (assoc (strcase Old) (VxListNetworkDrives)))
)
(cond
((vl-catch-all-apply
'vlax-invoke
(list WsnObj 'RemoveNetworkDrive Old :vlax-true :vlax-true)
)
)
((vl-catch-all-apply
'vlax-invoke
(list WsnObj 'MapNetworkDrive New OldUnc :vlax-true)
)
)
((setq RetVal T))
)
(vlax-release-object WsnObj)
RetVal
)
|
|
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:
; ©2002 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Scn = Shortcut name, "MyShortCut" [STR]
; Pro = Profile name, "MyProfile" [STR]
; Icn = (Path)Filename of the icon, "c:\\MyPath\\MyIcon.ico" [STR] 1)
; Return [Type]:
; > Shortcut path if succeed [STR]
; > Nil on error
; Notes:
; 1) If nil, AutoCAD's first internal icon is used
; - Requires ScrRun.dll (see also notes at top of page).
;
(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
|
|
VxGetShortCutTargPaths
- Returns all shortcut target paths according to the...
|
|
;
; -- Function VxGetShortCutTargPaths
; Returns all shortcut target paths according to the arguments.
; Copyright:
; ©2004 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Pth = Shortcut path "c:\\MyPath" [STR]
; Flt = Filter (DOS pattern), "*.dwg" [STR]
; Return [Type]:
; > List of shortcut paths if succeed [LIST]
; > Nil if nothing found
; Notes:
; - Requires ScrRun.dll (see also notes at top of page).
;
(defun VxGetShortCutTargetPaths (Pth Flt / RetVal ShoCut TmpPth WscObj)
(setq WscObj (vlax-create-object "WScript.Shell"))
(foreach Fil (vl-directory-files Pth (strcat Flt ".lnk") 1)
(setq TmpPth (strcat Pth "\\" Fil)
ShoCut (vlax-invoke-method WscObj 'CreateShortcut TmpPth)
RetVal (cons (vlax-get-property ShoCut 'TargetPath) RetVal)
)
)
(vlax-release-object WscObj)
RetVal
)
|
|
Back
|
|
VxGetShortName
- Returns the short path/name used by programs that...
|
|
;
; -- VxGetShortName
; Returns the short path/name used by programs that require the earlier 8.3
; file naming convention.
; Copyright:
; ©2004 MENZI ENGINEERING GmbH, Switzerland
; Arguments [Type]:
; Fil = Filename "C:\\Program Files\\ScrapFolder\\ScrapInit.dll" [STR]
; Return [Type]:
; > Short path/name [STR]
; > Nil if file doesn't exist
; Notes:
; - Requires ScrRun.dll (see also notes at top of page).
;
(defun VxGetShortName (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))
(vlax-get FilObj 'ShortPath)
)
(T nil)
)
)
(if FilObj (vlax-release-object FilObj))
(vlax-release-object FilSys)
RetVal
)
|
|
Back
|
|
AcadDoc.lsp
- Reactor sample
|
|
;
; == AcadDoc.lsp ==============================================================
; Sets a Command Reactor to set newly created viewports to a certain Layer.
; Load 'VxScrollDocs' with each document.
; Copyright:
; ©2000-2005 MENZI ENGINEERING GmbH, Switzerland
; Notes:
; - None
;
; -- Initialize ActiveX support -----------------------------------------------
(vl-load-com)
;
; - Set missing Datatype
(setq vlax-vbDecimal 14)
;
; - Preload document-based AutoLISP routines
(load "VxScrollDocs")
;;; load others...
;
; -- Reactors -----------------------------------------------------------------
;
; - If not set, initialize DocManager-Reactor
(or Gb:ReaDma
(setq Gb:ReaDma (VLR-DocManager-Reactor
nil
'(
(:VLR-documentToBeDestroyed . VxDocToBeDestroyedCallbacks)
)
)
)
)
;
; - If not set, initialize Command-Reactor
(or Gb:ReaCom
(setq Gb:ReaCom (VLR-Command-Reactor
nil
'(
(:VLR-commandEnded . VxCommandEndedCallbacks)
)
)
)
)
;
; -- Notifications ------------------------------------------------------------
;
; - CommandEnded notifications
(defun VxCommandEndedCallbacks (Rea Arg)
(VxDoCmdEndedStuff Arg)
;;; other functions...
(princ)
)
;
; - DocToBeDestroyed notification
(defun VxDocToBeDestroyedCallbacks (Rea Arg)
;;; other functions...
(VxDoCloseStuff)
(princ)
)
;
; -- Subs ---------------------------------------------------------------------
;
; - Command ended function
(defun VxDoCmdEndedStuff (Arg / CurCmd CurEnt CurSet FltLst LayNme)
(setq CurCmd (strcase (car Arg)))
(cond
((wcmatch CurCmd "*VPORTS,MVIEW")
(setq LayNme "VportLayer" ;Set the desired Vport Layer name (must exist)
FltLst (list '(0 . "VIEWPORT") (cons 8 (strcat "~" LayNme)))
)
(if (tblsearch "LAYER" LayNme)
(progn
(setq CurSet (ssget "X" FltLst))
(while (setq CurEnt (ssname CurSet 0))
(vla-put-layer (vlax-ename->vla-object CurEnt) LayNme)
(ssdel CurEnt CurSet)
)
)
(alert
(strcat
" Viewport Layer '" LayNme
"' not found - the current Layer is used. "
)
)
)
)
;;; other command ended dependent stuff...
)
(princ)
)
; - Reactor cleanup function
(defun VxDoCloseStuff ( / VarLst)
(setq VarLst (VxGetReaVars))
(mapcar 'VLR-remove (mapcar 'eval VarLst))
(mapcar '(lambda (l) (set l nil)) VarLst)
(princ)
)
; - Collect global reactor variables Gb:Rea*
(defun VxGetReaVars ( / RetVal)
(foreach memb (atoms-family 1)
(if (wcmatch (strcase memb) "GB:REA*")
(setq RetVal (cons (read memb) RetVal))
)
)
RetVal
)
(princ)
;
; == End AcadDoc.lsp ==========================================================
|
|
Back
|
|
|
|
|
|
|
|
|
|
Bei Problemen oder Fragen zu unserer
Webseite kontaktieren Sie bitte: Webmaster
Copyright ©
2001-2007 MENZI
ENGINEERING GmbH Last modified: 15. Januar 2007
|
