[转贴]：DSX-API-Objects.LSP

eachy · 发表于 2003-7-24 23:04:50

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

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

×

;;;*************************************************************************;;;
;;; DSX-API-Objects.LSP ;;;
;;; Visual LISP ActiveX Object Methods for DSX Tools 2002 ;;;
;;; Copyright (C) 2002 David M. Stein, All Rights Reserved. ;;;
;;;*************************************************************************;;;
;;; Version 2001.00 07/10/01: Initial release ;;;
;;; Version 2002.22 05/15/02: updated error handlers ;;;
;;;*************************************************************************;;;
;;; Code provided AS-IS without warranty of any kind given for any purpose ;;;
;;; or use, either explicitly, implicitly or as a derivative work item. ;;;
;;; User assumes ANY AND ALL RISK and LIABILITY for use of any of this code ;;;
;;; for any consequential damages of any kind. These functions are defined ;;;
;;; within DSX Tools 2002.22 when loaded into AutoCAD. This document is ;;;
;;; provided for informational purposes only. ;;;
;;;*************************************************************************;;;
;;;*************************************************************************;;;
;;; MODULE: DSX-AddArc ;;;
;;; DESCRIPTION: Creates an ARC object with given properties ;;;
;;; ARGS: centerpoint, radius, start-angle, end-angle, layer, color, ltype ;;;
;;; EXAMPLE: (DSX-AddArc pt1 0.5 "WALLS" 2 nil) ;;;
;;; NOTES: ;;;
;;;*************************************************************************;;;
(vl-load-com)
(defun DSX-AddArc
(cpt rad ang-s ang-e lay col ltype / obj)
(dsx-princ "\n(DSX-AddArc)")
(cond
( (vl-catch-all-error-p
(setq obj
(vl-catch-all-apply
'vla-AddArc
(list (DSX-ActiveSpace) (vlax-3d-point cpt) rad (DTR ang-s) (DTR ang-e))
)
)
)
(dsx-objerr obj)
)
( T
(if lay (vla-put-Layer obj lay))
(if col (vla-put-Color obj col))
(if ltype (DSX-ApplyLtype obj ltype))
(vla-update obj)
(vlax-Release-Object obj)
(entlast)
)
)
)
;;;*************************************************************************;;;
;;; MODULE: DSX-AddCircle ;;;
;;; DESCRIPTION: Creates a CIRCLE object with given properties ;;;
;;; ARGS: centerpoint, radius, layer, color, linetype ;;;
;;; EXAMPLE: (DSX-AddCircle p1 0.5 "WALLS" 2 nil) ;;;
;;; NOTES: ;;;
;;;*************************************************************************;;;
(defun DSX-AddCircle
(cpt rad lay col ltype / obj)
(dsx-princ "\n(DSX-AddCircle)")
(cond
( (vl-catch-all-error-p
(setq obj
(vl-catch-all-apply
'vla-AddCircle
(list
(DSX-ActiveSpace)
(vlax-3d-point cpt)
rad
)
)
)
)
(dsx-objerr obj)
)
( T
(if lay (vla-put-layer obj lay))
(if col (vla-put-color obj col))
(if ltype (DSX-ApplyLtype obj ltype))
(vla-update obj)
(vlax-release-object obj)
(entlast)
)
)
)
;;;*************************************************************************;;;
;;; MODULE: DSX-AddLine ;;;
;;; DESCRIPTION: Creates a LINE object with given properties ;;;
;;; ARGS: point1, point2, layer, color, linetype ;;;
;;; EXAMPLE: (DSX-AddLine p1 p2 "WALLS" nil nil) ;;;
;;; NOTES: ;;;
;;;*************************************************************************;;;
(defun DSX-AddLine
(p1 p2 lay col ltype / obj)
(dsx-princ "\n(DSX-AddLine)")
(cond
( (vl-catch-all-error-p
(setq obj
(vl-catch-all-apply
'vla-AddLine
(list
(DSX-ActiveSpace)
(vlax-3d-Point p1)
(vlax-3d-Point p2)
)
)
)
)
(dsx-objerr obj)
)
( T
(if lay (vla-put-Layer obj lay))
(if col (vla-put-Color obj col))
(if ltype (DSX-ApplyLtype obj ltype))
(vla-Update obj)
(vlax-release-object obj)
(entlast)
)
)
)
;;;*************************************************************************;;;
;;; MODULE: DSX-AddLineC ;;;
;;; DESCRIPTION: Creates multiple segment LINEs from list of points ;;;
;;; ARGS: points-list, closed-flag, layer, color, linetype ;;;
;;; EXAMPLE: (DSX-AddLineC plist T "WALLS" nil nil) --> closed at end ;;;
;;; NOTES: ;;;
;;;*************************************************************************;;;
(defun DSX-AddLineC
(ptlist Bclosed strLayer intColor strLtype / pt1 ptz)
(dsx-princ "\n(DSX-AddLineC)")
(cond
( (and ptlist (listp ptlist) (listp (car ptlist)))
(setq pt1 (car ptlist);; save first point
ptz (last ptlist);; save last point
)
(while (and ptlist (>= (length ptlist) 2))
(DSX-AddLine (car ptlist) (cadr ptlist) strLayer intColor strLtype)
(setq ptlist (cdr ptlist))
)
(if (= Bclosed T) (DSX-AddLine pt1 ptz strLayer intColor strLtype) )
)
); cond
)
;;;*************************************************************************;;;
;;; MODULE: DSX-AddPoint ;;;
;;; DESCRIPTION: Creates a POINT object with given properties ;;;
;;; ARGS: point, layer, color ;;;
;;; EXAMPLE: (DSX-AddPoint pt1 "WALLS" nil) ;;;
;;; NOTES: ;;;
;;;*************************************************************************;;;
(defun DSX-AddPoint
(pt strLayer col / obj)
(dsx-princ "\n(DSX-AddPoint)")
(cond
( (vl-catch-all-error-p
(setq obj
(vl-catch-all-apply
'vla-AddPoint
(list
(DSX-ActiveSpace)
(vlax-3d-point pt)
)
)
)
)
(dsx-objerr obj)
)
( T
(if strLayer (vla-Put-Layer obj strLayer))
(if col (vla-Put-Color obj col))
(vla-Update obj)
(vlax-Release-Object obj)
(entlast)
)
)
)
;;;*************************************************************************;;;
;;; MODULE: DSX-AddEllipse ;;;
;;; DESCRIPTION: Creates a closed ELLIPSE with given properties ;;;
;;; ARGS: centerpoint, hmajor-pt, roll-angle(deg), layer, color, linetype ;;;
;;; EXAMPLE: (DSX-AddEllipse pt1 pt2 45 "WALLS" nil nil) ;;;
;;; NOTES: ;;;
;;;*************************************************************************;;;
(defun DSX-AddEllipse
(ctr hmpt roll strLayer intColor strLtype / obj)
(dsx-princ "\n(DSX-AddEllipse)")
(cond
( (and
(setq hmpt (list
(- (car hmpt) (car ctr))
(- (cadr hmpt) (cadr ctr))
)
)
)
(cond
( (vl-catch-all-error-p
(setq obj
(vl-catch-all-apply
'vla-addEllipse
(list
(DSX-ActiveSpace)
(vlax-3D-Point ctr)
(vlax-3D-Point hmpt)
(Roll->Ratio roll)
)
)
)
)
(dsx-objerr obj)
)
( T
(if strLayer (vla-Put-Layer obj strLayer))
(if intColor (vla-Put-Color obj intColor))
(if strLtype (DSX-ApplyLtype obj strLtype))
(vla-Update obj)
(vlax-Release-Object obj)
(entlast)
)
)
)
( T (princ "\n(DSX-AddEllipse): Invalid parameter list!") )
)
)
;;;*************************************************************************;;;
;;; MODULE: DSX-AddEllipseArc1 ;;;
;;; DESCRIPTION: Creates ARC-Ellipse with given properties using roll-angle ;;;
;;; ARGS: center-pt, hmajor-pt, roll(deg), start-ang, end-ang, layer, color, linetype
;;; EXAMPLE: (DSX-AddEllipseArc1 pt1 pt2 45 90 180 "WALLS" nil nil) ;;;
;;; NOTES: ;;;
;;;*************************************************************************;;;
(defun DSX-AddEllipseArc1
(ctr hmpt roll StartAng EndAng strLayer intColor strLtype / obj rang)
(dsx-princ "\n(DSX-AddEllipseArc1)")
(cond
( (and
(setq hmpt (list
(- (car hmpt) (car ctr))
(- (cadr hmpt) (cadr ctr))
)
)
)
(cond
( (vl-catch-all-error-p
(setq obj
(vl-catch-all-apply
'vla-AddEllipse
(list
(DSX-ActiveSpace)
(vlax-3D-Point ctr)
(vlax-3D-Point hmpt)
(Roll->Ratio roll)
)
)
)
)
(dsx-objerr obj)
)
( T
(vla-Put-StartAngle obj (DTR StartAng))
(vla-Put-EndAngle obj (DTR EndAng))
(if strLayer (vla-Put-Layer obj strLayer))
(if intColor (vla-Put-Color obj intColor))
(if strLtype (DSX-ApplyLtype obj strLtype))
(vla-Update obj)
(vlax-Release-Object obj)
(entlast)
)
)
)
( T (princ "\n(DSX-AddEllipseArc1): Invalid parameter list...") )
)
)
;;;************************************************************************;;;
;;; MODULE: DSX-AddEllipseArc2 () ;;;
;;; DESCRIPTION: Same as DSX-AddEllipseArc1 but uses h-minor ratio ;;;
;;; ARGS: centerpoint, h-major-pt, h-minor-ratio, start-ang(deg), end-ang(deg), layer, color, linetype
;;; EXAMPLE: ;;;
;;;************************************************************************;;;
(defun DSX-AddEllipseArc2
(ctr hmpt hmin StartAng EndAng strLayer intColor strLtype / obj rang)
(dsx-princ "\n(DSX-AddEllipseArc2)")
(cond
( (and
ctr (listp ctr) hmpt (listp hmpt) hmin StartAng EndAng
(setq hmpt (list
(- (car hmpt) (car ctr))
(- (cadr hmpt) (cadr ctr))
)
)
)
(cond
( (vl-catch-all-error-p
(setq obj
(vl-catch-all-apply
'vla-AddEllipse
(list
(DSX-ActiveSpace)
(vlax-3D-Point ctr)
(vlax-3D-Point hmpt)
hmin ; radius-ratio value
)
)
)
)
(dsx-objerr obj)
)
( T
(vla-Put-StartAngle obj (DTR StartAng))
(vla-Put-EndAngle obj (DTR EndAng))
(if strLayer (vla-Put-Layer obj strLayer))
(if intColor (vla-Put-Color obj intColor))
(if strLtype (DSX-ApplyLtype obj strLtype))
(vla-Update obj)
(vlax-release-object obj)
(entlast)
)
)
)
( T (princ "\n(DSX-AddEllipseArc2): Invalid Parameter list...") )
)
)
;;;************************************************************************;;;
;;; MODULE: DSX-AddPline () ;;;
;;; DESCRIPTION: Create LwPolyline object with given properties & width. ;;;
;;; ARGS: pointlist, close, layer, color, linetype, lweight, lt-gen-flag ;;;
;;; EXAMPLE: (DSX-AddPline ptlist "Layer" T 3 "CENTER3" 0 nil) ;;;
;;;************************************************************************;;;
(defun DSX-AddPline
(ptlist strLayer Bclosed intColor strLt dblWidth bLTG
/ vrtcs plgen plist plpoints obj)
(dsx-princ "\n(DSX-AddPline)")
(cond
( (and ptlist (listp ptlist) (listp (car ptlist)))
(setq plist (apply 'append (mapcar '3dpoint->2dpoint ptlist))
plpoints (List->VariantArray plist)
)
(cond
( (vl-catch-all-error-p
(setq obj
(vl-catch-all-apply
'vla-AddLightWeightPolyline
(list
(DSX-ActiveSpace)
plpoints
)
)
)
)
(dsx-objerr obj)
)
( T
(if Bclosed (vla-Put-Closed obj :vlax-True));; make closed
(if strLayer (vla-Put-Layer obj strLayer));; apply layer
(if intColor (vla-Put-Color obj intColor));; apply color
(if dblWidth (vla-Put-ConstantWidth obj dblWidth));; apply constant width
(if strLt (DSX-ApplyLtype obj strLt))
(if bLTG (DSX-ApplyLtypeGen obj))
(vla-Update obj);; force graphic update
(vlax-Release-Object obj)
(entlast)
)
)
)
( T (princ "\n(DSX-AddPline): Invalid parameter list...") )
)
)
;;;************************************************************************;;;
;;; MODULE: DSX-AddSolid ;;;
;;; DESCRIPTION: Create solid region with given properties and points ;;;
;;; ARGS: pointlist, layer, color ;;;
;;; EXAMPLE: (DSX-AddSolid (list p1 p2 p3) "0" 3) ;;;
;;;************************************************************************;;;
(defun DSX-AddSolid
(ptlist strLayer intColor / plist obj)
(dsx-princ "\n(DSX-AddSolid)")
(cond
( (and ptlist (listp ptlist) (listp (car ptlist)))
(if (= (length ptlist) 3)
(setq plist (append ptlist (list (last ptlist))))
(setq plist ptlist)
)
(dsx-princ "\nMaking solid object...")
(cond
( (vl-catch-all-error-p
(setq obj
(vl-catch-all-apply
'vla-AddSolid
(list
(DSX-ActiveSpace)
(vlax-3D-Point (car plist))
(vlax-3D-Point (cadr plist))
(vlax-3D-Point (caddr plist))
(vlax-3D-Point (cadddr plist))
)
)
)
)
(dsx-objerr obj)
)
( T
(if strLayer (vla-Put-Layer obj strLayer))
(if intColor (vla-Put-Color obj intColor))
(vla-Update obj)
(vlax-Release-Object obj)
(entlast)
)
)
)
( T (princ "\n(DSX-AddSolid): Invalid parameter list...") )
)
)
;;;*************************************************************************;;;
;;; MODULE: DSX-AddText ;;;
;;; DESCRIPTION: Create TEXT objects with given properties ;;;
;;; ARGS: textstring, inspt, justification, stylename, height(real), width(real), rotation(real), layer, color
;;; EXAMPLE: (DSX-AddText "TITLE" pt1 "MC" "Standard" 0.15 1.0 0 "TEXT" nil)
;;; NOTES: ;;;
;;;*************************************************************************;;;
(defun DSX-AddText
(strTxt pt Just strStyle dblHgt dblWid dblRot strLay intCol
/ txtobj
)
(dsx-princ "\n(DSX-AddText)")
(cond
( (vl-catch-all-error-p
(setq txtobj
(vl-catch-all-apply
'vla-AddText
(list
(DSX-ActiveSpace)
strTxt
(if (not (member (strcase Just) '("A" "F")))
(vlax-3d-Point pt)
(vlax-3d-Point (car pt))
)
dblHgt ;; ignored for ALIGNED justified text
)
)
)
)
(dsx-objerr txtobj)
)
( T
(if strstyle (vla-put-StyleName txtobj strStyle))
(if strLay (vla-put-Layer txtobj strLay))
(if intCol (vla-put-Color txtobj intCol))
;; Left/Align/Fit/Center/Middle/Right/BL/BC/BR/ML/MC/MR/TL/TC/TR
;; Note that "Left" is not a normal default.
;;
;; ALIGNMENT TYPES...
;; AcAlignmentLeft=0
;; AcAlignmentCenter=1
;; AcAlignmentRight=2
;; AcAlignmentAligned=3
;; AcAlignmentMiddle=4
;; AcAlignmentFit=5
;; AcAlignmentTopLeft=6
;; AcAlignmentTopCenter=7
;; AcAlignmentTopRight=8
;; AcAlignmentMiddleLeft=9
;; AcAlignmentMiddleCenter=10
;; AcAlignmentMiddleRight=11
;; AcAlignmentBottomLeft=12
;; AcAlignmentBottomCenter=13
;; AcAlignmentBottomRight=14
;;
;; HORIZONTAL JUSTIFICATIONS...
;; AcHorizontalAlignmentLeft=0
;; AcHorizontalAlignmentCenter=1
;; AcHorizontalAlignmentRight=2
;; AcHorizontalAlignmentAligned=3
;; AcHorizontalAlignmentMiddle=4
;; AcHorizontalAlignmentFit=5
;;
;; VERTICAL JUSTIFICATIONS...
;; AcVerticalAlignmentBaseline=0
;; AcVerticalAlignmentBottom=1
;; AcVerticalAlignmentMiddle=2
;; AcVerticalAlignmentTop=3
(cond
( (= Just "L")
(if dblWid (vla-put-ScaleFactor txtobj dblWid))
(if dblRot (vla-put-Rotation txtobj (DTR dblRot)))
)
( (= Just "C")
(vla-put-Alignment txtobj 1)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(if dblWid (vla-put-ScaleFactor txtobj dblWid))
(if dblRot (vla-put-Rotation txtobj (DTR dblRot)))
)
( (= Just "R")
(vla-put-Alignment txtobj 2)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(if dblWid (vla-put-ScaleFactor txtobj dblWid))
(if dblRot (vla-put-Rotation txtobj (DTR dblRot)))
)
( (= Just "A")
(vla-put-Alignment txtobj 3)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point (cadr pt)))
)
( (= Just "M")
(vla-put-Alignment txtobj 4)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(if dblWid (vla-put-ScaleFactor txtobj dblWid))
(if dblRot (vla-put-Rotation txtobj (DTR dblRot)))
)
( (= Just "F")
(vla-put-Alignment txtobj 5)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point (cadr pt)))
)
( (= Just "TL");; Top-Left
(vla-put-Alignment txtobj 6)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(if dblWid (vla-put-ScaleFactor txtobj dblWid))
(if dblRot (vla-put-Rotation txtobj (DTR dblRot)))
)
( (= Just "TC");; Top-Center
(vla-put-Alignment txtobj 7)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(if dblWid (vla-put-ScaleFactor txtobj dblWid))
(if dblRot (vla-put-Rotation txtobj (DTR dblRot)))
)
( (= Just "TR");; Top-Right
(vla-put-Alignment txtobj 8)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(if dblWid (vla-put-ScaleFactor txtobj dblWid))
(if dblRot (vla-put-Rotation txtobj (DTR dblRot)))
)
( (= Just "ML")
(vla-put-Alignment txtobj 9)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(if dblWid (vla-put-ScaleFactor txtobj dblWid))
(if dblRot (vla-put-Rotation txtobj (DTR dblRot)))
)
( (= Just "MC")
(vla-put-Alignment txtobj 10)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(if dblWid (vla-put-ScaleFactor txtobj dblWid))
(if dblRot (vla-put-Rotation txtobj (DTR dblRot)))
)
( (= Just "MR")
(vla-put-Alignment txtobj 11)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(if dblWid (vla-put-ScaleFactor txtobj dblWid))
(if dblRot (vla-put-Rotation txtobj (DTR dblRot)))
)
( (= Just "BL")
(vla-put-Alignment txtobj 12)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(if dblWid (vla-put-ScaleFactor txtobj dblWid))
(if dblRot (vla-put-Rotation txtobj (DTR dblRot)))
)
( (= Just "BC")
(vla-put-Alignment txtobj 13)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(if dblWid (vla-put-ScaleFactor txtobj dblWid))
(if dblRot (vla-put-Rotation txtobj (DTR dblRot)))
)
( (= Just "BR")
(vla-put-Alignment txtobj 14)
(vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt))
(if dblWid (vla-put-ScaleFactor txtobj dblWid))
(if dblRot (vla-put-Rotation txtobj (DTR dblRot)))
)
)
(vla-update txtobj)
(vlax-Release-Object txtobj)
(entlast)
)
)
)
;;;*************************************************************************;;;
;;; MODULE: DSX-AddPolygon ;;;
;;; DESCRIPTION: Creates a circumscribed polygon ;;;
;;; ARGS: center, radius, sides, flag ("C" or "I"), width, layer, color, ltype, ltgen
;;; EXAMPLE: (DSX-AddPolygon pt1 1.0 6 "C" 0 "0" nil "DASHED" T) ;;;
;;;*************************************************************************;;;
(defun DSX-AddPolygon
(ctrpt dblRad intSides strType dblWid strLay intCol strLtype Bltgen
/ pa dg ptlist deg)
(dsx-princ "\n(DSX-AddPolygon)")
(if (= (strcase strType) "C")
(setq dblRad (* dblRad (/ 1 (/ (sqrt 3.0) 2.0))))
)
(setq pa (polar ctrpt 0 dblRad)
dg (/ 360.0 intSides);; get angles between faces
deg dg
)
(repeat intSides
(setq ptlist
(if ptlist
(append ptlist (list (polar ctrpt (DTR deg) dblRad)))
(list (polar ctrpt (DTR deg) dblRad))
)
)
(setq deg (+ dg deg))
)
(DSX-AddPline ptlist strLay T intCol strLtype dblWid Bltgen)
)
;;;*************************************************************************;;;
;;; MODULE: DSX-AddRectangle ;;;
;;; DESCRIPTION: Creates LwPolyline rectangle with given properties ;;;
;;; ARGS: pt1, pt2, layer, color, linetype, lineweight, ltgen-flag ;;;
;;; EXAMPLE: (DSX-AddRectangle p1 p2 "DOORS" 1 "DASHED" 0 nil) ;;;
;;; NOTES: ;;;
;;;*************************************************************************;;;
(defun DSX-AddRectangle
(p1 p3 strLayer intColor strLtype dblWid bLTG / p2 p4 obj)
(dsx-princ "\n(DSX-AddRectangle)")
(setq p2 (list (car p1) (cadr p3))
p4 (list (car p3) (cadr p1))
)
(cond
( (setq obj
(DSX-AddPline (list p1 p2 p3 p4)
strLayer T intColor strLtype dblWid bLTG
)
)
obj ;; raise object (entity name)
)
)
)
;;;*************************************************************************;;;
;;; MODULE: DSX-AttachXREF ;;;
;;; DESCRIPTION: Attaches named drawing as an XREF-ATTACHment ;;;
;;; ARGS: pathname, fulldwgname ;;;
;;; EXAMPLE: (DSX-AttachXREF "c:\\dwgfiles" "c:\\dwgfiles\\dwg1.dwg") ;;;
;;; NOTES: ;;;
;;;*************************************************************************;;;
(defun DSX-AttachXREF (pathname fullname)
(dsx-princ "\n(DSX-AttachXREF)")
(vlax-for layout
(vla-get-layouts (DSX-ActiveDocument))
(vla-AttachExternalReference
(vla-get-Block layout)
pathname
fullname
(vlax-3d-point '(0.0 0.0 0.0))
1.0 1.0 1.0 0.0
:vlax-false
)
)
)
;;;*************************************************************************;;;
;;; MODULE: Roll->Ratio ;;;
;;; DESCRIPTION: Converts a roll angle into the h-major/minor ratio value ;;;
;;; ARGS: roll-angle (deg) ;;;
;;; EXAMPLE: (Roll->Ratio 45) --> 0.707107 ;;;
;;; NOTES: ;;;
;;;*************************************************************************;;;
(defun Roll->Ratio (RollAngle)
(cos (DTR RollAngle))
)
;;;*************************************************************************;;;
;;; MODULE: DSX-GetEllipseArcPoints ;;;
;;; DESCRIPTION: Returns coordinates of Elliptical-Arc endpoints in current UCS or WCS (default)
;;; ARGS: entity-or-object ;;;
;;; EXAMPLE: (DSX-GetEllipseArcPoints ellObj) -->((1.0 2.0 0.0) (1.0 3.0 0.0))
;;; NOTES: ;;;
;;;*************************************************************************;;;
(defun DSX-GetEllipseArcPoints
(ellent / ename-ellipse vlaobject-ellipse p-start p-end out)
(dsx-princ "\n(DSX-GetEllipseArcPoints)")
(setq vlaObject-Ellipse (DSX-MakeObject ellent);; convert ename to object
p-start (vla-Get-StartPoint vlaObject-Ellipse)
p-end (vla-Get-EndPoint vlaObject-Ellipse)
out (list
(vlax-SafeArray->List (vlax-Variant-Value p-start))
(vlax-SafeArray->List (vlax-Variant-Value p-end))
)
)
out
); defun
;;;************************************************************************;;;
;;; MODULE: DeltaPt ;;;
;;; DESCRIPTION: Determine delta offset from point<p1> to point<p2> ;;;
;;; ARGS: point1, point2 ;;;
;;; EXAMPLE: (DeltaPt p1 p2) returns (1.0 2.4 0.0) ;;;
;;; NOTES: ;;;
;;;************************************************************************;;;
(defun DeltaPt (p1 p2)
(list
(- (car p2) (car p1));; x-delta
(- (cadr p2) (cadr p1));; y-delta
(- (caddr p2) (caddr p1));; z-delta
)
)
;;;************************************************************************;;;
;;; MODULE: DSX-ApplyLtype ;;;
;;; DESCRIPTION: Apply linetype to vla-object or entity ;;;
;;; ARGS: entname(or vla-object), linetype-name ;;;
;;; EXAMPLE: (DSX-ApplyLtype line-ent "DASHED") ;;;
;;; NOTES: ;;;
;;;************************************************************************;;;
(defun DSX-ApplyLtype
(obj strLtype / ent els try ltobj ltn)
(dsx-princ "\n(DSX-ApplyLtype)")
(cond
( (not (member (strcase strLtype) '("CONTINUOUS" "BYBLOCK" "BYLAYER")))
(if (setq ltobj (dsx-loadltype strLtype nil))
(progn
(setq ltn (vla-get-name ltobj))
(vlax-put-property (dsx-makeobject obj) ltn)
(vlax-release-object ltobj)
)
)
( T
(vlax-put-property (dsx-makeobject obj) strLtype)
)
)
)
)
;;;************************************************************************;;;
;;; MODULE: DSX-ApplyLtScale ;;;
;;; DESCRIPTION: Apply object linetype scaling ;;;
;;; ARGS: ename or object, scale (real) ;;;
;;; EXAMPLE: (DSX-ApplyLtScale line-ent 24.0) ;;;
;;; NOTES: ;;;
;;;************************************************************************;;;
(defun DSX-ApplyLtScale
(ent sc / obj)
(dsx-princ "\n(DSX-ApplyLtScale)")
(setq obj (DSX-MakeObject ent))
(if (vlax-property-available-p obj "linetypescale")
(vla-Put-LinetypeScale obj sc)
(princ "\n(DSX-ApplyLtScale): Unable to modify object linetype scale property...")
)
(vlax-Release-Object obj)
)
;;;************************************************************************;;;
;;; MODULE: DSX-ApplyLtypeGen ;;;
;;; DESCRIPTION: Apply linetype-generation to polyline or lwpolyline object;;;
;;; ARGS: linetype-name, object or ename ;;;
;;; EXAMPLE: (DSX-ApplyLtypeGen "CENTER3" pline-obj) ;;;
;;; NOTES: ;;;
;;;************************************************************************;;;
(defun DSX-ApplyLtypeGen (object)
(dsx-princ "\n(DSX-ApplyLtypeGen)")
(if (vlax-property-available-p object "linetypegeneration")
(vla-Put-LinetypeGeneration object :vlax-True)
(princ "\nError: Object has not 'linetypegeneration' property.")
)
)
;;;*************************************************************************;;;
;;; MODULE: DSX-GetAttributes ;;;
;;; DESCRIPTION: Returns attribute data list ((tag . value) (tag . value)...)
;;; ARGS: entity-or-object (blockref) ;;;
;;; EXAMPLE: (DSX-GetAttributes blkent) ;;;
;;; NOTES: ;;;
;;;*************************************************************************;;;
(defun DSX-GetAttributes (ent / blkref lst)
(dsx-princ "\n(DSX-GetAttributes)")
(setq blkref (DSX-MakeObject ent))
(if (= (vla-get-objectname blkref) "AcDbBlockReference")
(if (vla-get-hasattributes blkref)
(mapcar
'(lambda (x)
(setq lst
(cons
(cons
(vla-get-tagstring x)
(vla-get-textstring x)
)
lst
)
)
)
(vlax-safearray->list
(vlax-variant-value (vla-getattributes blkref))
)
); mapcar
); endif
); endif
(reverse lst)
)
;;;*************************************************************************;;;
;;; MODULE: DSX-ModAttributes ;;;
;;; DESCRIPTION: Updates block attribute values with cons list ;;;
;;; ARGS: block-object, att-value-list ;;;
;;; EXAMPLE: (DSX-ModAttributes blkobj '(("tag1" . "value1")...)) ;;;
;;; NOTES: ;;;
;;;*************************************************************************;;;
(defun DSX-ModAttributes
(blkobj datlst / itm atts)
(dsx-princ "\n(DSX-ModAttributes)")
(if (= (vla-Get-HasAttributes blkobj) :vlax-true)
(progn
(setq atts
(vlax-SafeArray->list
(vlax-Variant-Value (vla-GetAttributes blkobj))
)
); setq
(foreach item datlst
(mapcar
'(lambda (x)
(if
(= (strcase (car item)) (strcase (vla-get-TagString x)))
(vla-put-TextString x (cdr item))
)
)
atts
); mapcar
); foreach
(vla-Update blkobj)
)
); endif
)
;;;*************************************************************************;;;
;;; MODULE: DSX-CopyProp ;;;
;;; DESCRIPTION: Copies named properties from one object to another ;;;
;;; ARGS: property-name(string), source(object), target(object) ;;;
;;; EXAMPLE: (DSX-CopyProp "Layer" obj1 obj2) ;;;
;;; NOTES: ;;;
;;;*************************************************************************;;;
(defun DSX-CopyProp (propName source target)
(dsx-princ "\n(DSX-CopyProp)")
(cond
( (and
(not (vlax-erased-p source));; is source accessible?
(not (vlax-erased-p target));; is target accessible?
(vlax-property-available-p source propName);; is property valid?
(vlax-property-available-p target propName T);; is property modifiable?
)
(vlax-put-property
target propName
(vlax-get-property source propName)
)
T ;; return TRUE
)
( T (princ "\nOne or more objects inaccessible!") )
); cond
)
;;;*************************************************************************;;;
;;; MODULE: DSX-MapPropertyList ;;;
;;; DESCRIPTION: Copies multiple properties from one object to another ;;;
;;; ARGS: list, object, object ;;;
;;; EXAMPLE: (DSX-MapPropertyList '("Layer" "Color") obj1 obj2) ;;;
;;; NOTES: ;;;
;;;*************************************************************************;;;
(defun DSX-MapPropertyList (propList source target)
(dsx-princ "\n(DSX-MapPropertyList)")
(foreach prop propList
(DSX-CopyProp prop source target)
)
)
;;;*************************************************************************;;;
;;; MODULE: Tol ;;;
;;; DESCRIPTION: checks to see if num is between two values be them upper or lower limits or a toleranced target value. ;;;
;;; ARGS: num, target, toler, uplim, lolim ;;;
;;; EXAMPLE: (Tol 4.5 4.52 0.05 nil nil) or (Tol 4.5 nil nil 3 5) returns T ;;;
;;; NOTES: ;;;
;;;*************************************************************************;;;
(defun Tol (num target toler uplim lolim)
(cond
( (and (/= toler nil) (/= target nil))
(if (<= (- target toler) num (+ target toler)) T)
)
( T (if (<= lolim num uplim) T) )
)
)
;;;*************************************************************************
;;; MODULE: DSX-AddLeader-Simple
;;; DESCRIPTION: Add LEADER with TEXT using 2 points and text string value
;;; ARGS: point1, point2, textstring
;;; EXAMPLE: (DSX-AddLeader-Simple p1 p2 "REFERENCE LINE")
;;;*************************************************************************
(defun DSX-AddLeader-Simple
(p1 p2 text)
(vl-cmdf "leader" "_NON" p1 "_NON" p2 "A" text "")
(entlast)
)
;;;*************************************************************************
;;; MODULE: DSX-AddLeader
;;; DESCRIPTION: Creates leader with given properties and text string
;;; ARGS: points-list, textstring (or list of strings) , txtheight, justification key ("T" "M" "B"), pointer (ACAD enum), layer(opt), color(opt), dimstyle(opt)
;;; EXAMPLE: (DSX-AddLeader ptlist "DATUM LINE" 0.15 "T" acArrowDefault $lay $tlay acByLayer nil) returns Ename
;;;*************************************************************************
(defun DSX-AddLeader
(ptlist txtstr hgt justky pntr lay mlay col style / Make3dPt xlist xarray xvariant oLeader mtpt oMtext tmp i)
(defun Make3dPt (pt)
(if (not (caddr pt))
(list
(car pt)
(cadr pt)
(getvar "elevation")
)
pt
)
)
;; Odd stuff here: A Leader object uses a flat matrix for
;; its coordinates list. The array is simply a list of all
;; coordinate points appended into a single 1 dimensional list
;; In order to make a Leader, you must first stuff all the
;; supplied points into a flat list, then convert that list
;; into a safearray and then convert the safearray into a
;; variant object. Then the AddLeader function will accept
;; it.
;; Also, the AnnotationObject property will not allow anything
;; but a valid object handle. The documentation says it will
;; accept NULL (aka nil, vlax-vbNull, etc.) but this causes
;; an error and fails entirely. You must supply an object of
;; some kind to make the Leader object work in VLISP.
;; pack coords into a flat matrix list
(setq xlist (apply 'append (mapcar 'Make3dPt ptlist)))
;; Convert flat list into a safearray
(setq xarray
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbDouble
(cons
0
(1- (length xlist))
)
)
xlist
)
)
;; Convert safearray into a variant object
(setq xvariant (vlax-make-variant xarray))
;; Calculate attachment point of Mtext object off of end of
;; last point in leader coordinates list
;; Only Justifications on the ends are supported --
;; (TL, ML, BL, TR, MR, & BR) therefore the justky tells whether
;; its T (top) M (middle) or B (bottom) concatenated with "L" or "R"
;; upon examination of the point list.
(if
(>
(car (nth 0 (reverse ptlist)))
(car (nth 1 (reverse ptlist)))
)
(setq mtpt (DSX-PTOFF (last ptlist) 0.125 (/ (ASWPM-TextSize1) 2.0))
mtjs (strcat justky "L")
)
(setq mtpt (PTOFF (last ptlist) -0.125 (/ (ASWPM-TextSize1) 2.0))
mtjs (strcat justky "R")
)
)
(cond
( (or (= mtjs "TL") (= mtjs "TR")) (setq offst (- (/ hgt 2.0))))
( (or (= mtjs "BR") (= mtjs "BL")) (setq offst (/ hgt 2.0)))
( T (setq offst nil))
)
;; function allows for a list of strings which correspond to different lines
;; of text. This portion will concatenate the strings in the list to reflect
;; the different lines of text using the control code "\\P" for new lines.
(cond
( (listp txtstr)
(setq i 0
tmp ""
)
(repeat (length txtstr)
(if (= tmp "")
(setq tmp (nth i txtstr))
(setq tmp (strcat tmp "\\P" (nth i txtstr)))
)
(setq i (1+ i))
)
(setq txtstr tmp)
)
)
;; Create Mtext annotation object
(setq oMtext (DSX-AddMtext1 txtstr mtpt hgt 0 mtjs))
(if mlay (vla-put-layer oMtext mlay))
(cond
( (not
(vl-catch-all-error-p
(setq oLeader
(vl-catch-all-apply
'vla-AddLeader
(list
(DSX-ActiveSpace)
xvariant ; points
oMtext ; annotation object
acLineWithArrow ; leadertype
)
); vl-catch-all-apply
); setq
); vl-catch-all-error-p
); not
(if lay (vla-put-Layer oLeader lay))
(if col (vla-put-Color oLeader col))
(if style (vla-put-StyleName oLeader style))
(if pntr (vla-put-arrowheadtype oLeader pntr))
(if offst
(progn
(setq ename (vlax-vla-object->ename oLeader)
elist (entget ename)
prev (assoc 213 elist)
new (cons 213 (list 0.0 offst 0.0))
elist (subst new prev elist)
)
(entmod elist)
(entupd ename)
(vla-evaluate (DSX-MakeObject ename))
)
)
)
( T
(princ
(strcat "\nError: "
(vl-catch-all-error-message oLeader)
)
)
(vlax-release-object oLeader)
)
)
ename
)
(defun DSX-AddMtext1 (txt pt hgt wid jus)
(vl-cmdf "-mtext" "_NON" pt "_j" jus "_h" hgt "_w" wid txt "")
(DSX-MakeObject (entlast))
)
;;;*************************************************************************
;;; MODULE: dsx-Copy
;;; DESCRIPTION: Copy method for picksets, entities or objects, returns object if possible, ignores osmode
;;; ARGS: entity-or-object, point1, point2
;;; EXAMPLE: (DSx-Copy (entlast) p1 p2)
;;;*************************************************************************
(defun dsx-copy (obj p1 p2 / o1 o2 i)
(dsx-princ "\n(dsx-copy)")
(cond
( (= 'PICKSET (type obj))
(setq i 0)
(repeat (sslength obj)
(setq o1 (dsx-MakeObject (ssname obj i)))
(setq o2 (vla-copy o1))
(vla-move o2 (vlax-3d-point p1) (vlax-3d-point p2))
(vlax-release-object o1)
(vlax-release-object o2)
(setq i (1+ i))
)
)
( (= 'vla-object (type obj))
(setq o2 (vla-copy o1))
(vla-move o2 (vlax-3d-point p1) (vlax-3d-point p2))
(vlax-release-object o1)
o2
)
( (= 'ename (type obj))
(setq o1 (dsx-MakeObject obj))
(setq o2 (vla-copy o1))
(vla-move o2 (vlax-3d-point p1) (vlax-3d-point p2))
(vlax-release-object o1)
o2
)
)
)
;;;*************************************************************************
;;; MODULE: dsx-Move
;;; DESCRIPTION: Move method for picksets, entities or objects, returns nil, ignores osmode
;;; ARGS: entity-or-object-or-pickset, point1, point2
;;; EXAMPLE: (DSX-Move (entlast) p1 p2)
;;;*************************************************************************
(defun dsx-Move (obj p1 p2 / i o)
(dsx-princ "\n(dsx-move)")
(cond
( (= 'PICKSET (type obj))
(setq i 0)
(repeat (sslength obj)
(setq o (dsx-MakeObject (ssname obj i)))
(vla-move o (vlax-3d-point p1) (vlax-3d-point p2))
(vlax-release-object o)
(setq i (1+ i))
)
)
( (= 'VLA-OBJECT (type obj))
(vla-move obj (vlax-3d-point p1) (vlax-3d-point p2))
)
( (= 'ENAME (type obj))
(setq o (dsx-MakeObject obj))
(vla-move o (vlax-3d-point p1) (vlax-3d-point p2))
(vlax-release-object o)
)
)
)
;;;*************************************************************************
;;; MODULE: dsx-Rotate
;;; DESCRIPTION: Rotate method for picksets, entities or objects, returns nil, ignores osmode
;;; ARGS: entity-or-object-or-pickset, point, angle-degrees
;;; EXAMPLE: (dsx-Rotate sset pt1 180)
;;;*************************************************************************
(defun dsx-Rotate (obj pt ang-deg / i o)
(dsx-princ "\n(dsx-rotate)")
(cond
( (= 'VLA-OBJECT (type obj))
(if (vlax-method-applicable-p obj "rotate")
(vla-rotate obj (vlax-3d-point pt) (DTR ang-deg))
)
)
( (= 'ENAME (type obj))
(setq o (dsx-MakeObject obj))
(if (vlax-method-applicable-p o "rotate")
(vla-rotate o (vlax-3d-point pt) (DTR ang-deg))
)
(vlax-release-object o)
)
( (= 'PICKSET (type obj))
(setq i 0)
(repeat (sslength obj)
(setq o (dsx-MakeObject (ssname obj i)))
(if (vlax-method-applicable-p o "rotate")
(vla-rotate o (vlax-3d-point pt) (DTR ang-deg))
)
(vlax-release-object o)
(setq i (1+ i))
)
)
)
)
;;;*************************************************************************
;;; MODULE: dsx-Mirror
;;; DESCRIPTION: Mirror method for picksets, entities or objects, returns new object or nil
;;; ARGS: ename/object/pickset, point1, point2, delete-flag
;;; EXAMPLE: (dsx-Mirror sset p1 p2 T) mirrors and deletes original
;;;*************************************************************************
(defun dsx-Mirror (obj p1 p2 delete / o i out)
(dsx-princ "\n(dsx-Mirror)")
(cond
( (= (type obj) 'vla-object)
(if (vlax-method-applicable-p obj "mirror")
(progn
(setq out (vla-mirror obj (vlax-3d-point p1) (vlax-3d-point p2)))
(if delete (vla-delete obj))
)
)
)
( (= (type obj) 'ename)
(setq o (vlax-ename->vla-object obj))
(if (vlax-method-applicable-p o "Mirror")
(progn
(setq out (vlax-invoke-method o "Mirror" (vlax-3d-point p1) (vlax-3d-point p2)))
(if delete (vla-delete o))
)
)
(vlax-release-object o)
)
( (= (type obj) 'pickset)
(setq i 0)
(repeat (sslength obj)
(setq o (vlax-ename->vla-object (ssname obj i)))
(if (vlax-method-applicable-p o "Mirror")
(progn
(vlax-invoke-method o "Mirror" (vlax-3d-point p1) (vlax-3d-point p2))
(if delete (vla-delete o))
)
)
(vlax-release-object o)
(setq i (1+ i))
)
)
)
out
)
(princ)
;;;*************************************************************************
;;; MODULE: dsx-Scale
;;; DESCRIPTION: Scale method for picksets, entities or objects, returns nil, ignores osmode
;;; ARGS: entity-or-object-or-pickset, point, scalefactor
;;; EXAMPLE: (dsx-Scale sset pt1 2)
;;;*************************************************************************
(defun dsx-Scale (obj pt scafac / i o)
(cond
( (= 'PICKSET (type obj))
(setq i 0)
(repeat (sslength obj)
(setq o (dsx-MakeObject (ssname obj i)))
(vla-ScaleEntity o (vlax-3d-point pt) scafac)
(vlax-release-object o)
(setq i (1+ i))
)
)
( (= 'VLA-OBJECT (type obj))
(vla-ScaleEntity obj (vlax-3d-point pt) scafac)
)
( (= 'ENAME (type obj))
(setq o (dsx-MakeObject obj))
(vla-ScaleEntity obj (vlax-3d-point pt) scafac)
(vlax-release-object o)
)
)
)
(princ)

;;;*************************************************************************;;; 
;;; DSX-API-Objects.LSP                                                     ;;; 
;;; Visual LISP ActiveX Object Methods for DSX Tools 2002                   ;;; 
;;; Copyright (C) 2002 David M. Stein, All Rights Reserved.                 ;;; 
;;;*************************************************************************;;; 
;;; Version 2001.00 07/10/01: Initial release                               ;;; 
;;; Version 2002.22 05/15/02: updated error handlers                        ;;; 
;;;*************************************************************************;;; 
;;; Code provided AS-IS without warranty of any kind given for any purpose  ;;; 
;;; or use, either explicitly, implicitly or as a derivative work item.     ;;; 
;;; User assumes ANY AND ALL RISK and LIABILITY for use of any of this code ;;; 
;;; for any consequential damages of any kind.  These functions are defined ;;; 
;;; within DSX Tools 2002.22 when loaded into AutoCAD.  This document is    ;;; 
;;; provided for informational purposes only.                               ;;; 
;;;*************************************************************************;;; 
 
;;;*************************************************************************;;; 
;;; MODULE: DSX-AddArc                                                      ;;; 
;;; DESCRIPTION: Creates an ARC object with given properties                ;;; 
;;; ARGS: centerpoint, radius, start-angle, end-angle, layer, color, ltype  ;;; 
;;; EXAMPLE: (DSX-AddArc pt1 0.5 "WALLS" 2 nil)                             ;;; 
;;; NOTES:                                                                  ;;; 
;;;*************************************************************************;;; 
 
(vl-load-com) 
 
(defun DSX-AddArc 
        (cpt rad ang-s ang-e lay col ltype / obj) 
        (dsx-princ "\n(DSX-AddArc)") 
  (cond 
    ( (vl-catch-all-error-p 
                                (setq obj 
                                        (vl-catch-all-apply 
                        'vla-AddArc 
                                                (list (DSX-ActiveSpace)        (vlax-3d-point cpt) rad (DTR ang-s) (DTR ang-e)) 
                ) 
              ) 
                        ) 
                  (dsx-objerr obj) 
                ) 
                ( T 
                  (if lay (vla-put-Layer obj lay)) 
                  (if col (vla-put-Color obj col)) 
                  (if ltype (DSX-ApplyLtype obj ltype)) 
                  (vla-update obj) 
                  (vlax-Release-Object obj) 
                  (entlast) 
                ) 
        ) 
) 
 
;;;*************************************************************************;;; 
;;; MODULE: DSX-AddCircle                                                   ;;; 
;;; DESCRIPTION: Creates a CIRCLE object with given properties              ;;; 
;;; ARGS: centerpoint, radius, layer, color, linetype                       ;;; 
;;; EXAMPLE: (DSX-AddCircle p1 0.5 "WALLS" 2 nil)                           ;;; 
;;; NOTES:                                                                  ;;; 
;;;*************************************************************************;;; 
 
(defun DSX-AddCircle 
  (cpt rad lay col ltype / obj) 
        (dsx-princ "\n(DSX-AddCircle)") 
        (cond 
                ( (vl-catch-all-error-p 
                                (setq obj 
                                        (vl-catch-all-apply 
                                                'vla-AddCircle 
                                                (list 
                                                        (DSX-ActiveSpace) 
                                                        (vlax-3d-point cpt) 
                                                        rad 
                                                ) 
                                        ) 
                                ) 
                        ) 
                  (dsx-objerr obj) 
                ) 
                ( T 
                  (if lay (vla-put-layer obj lay)) 
                  (if col (vla-put-color obj col)) 
                  (if ltype (DSX-ApplyLtype obj ltype)) 
                  (vla-update obj) 
                  (vlax-release-object obj) 
                  (entlast) 
                ) 
        ) 
) 
 
;;;*************************************************************************;;; 
;;; MODULE: DSX-AddLine                                                     ;;; 
;;; DESCRIPTION: Creates a LINE object with given properties                ;;; 
;;; ARGS: point1, point2, layer, color, linetype                            ;;; 
;;; EXAMPLE: (DSX-AddLine p1 p2 "WALLS" nil nil)                            ;;; 
;;; NOTES:                                                                  ;;; 
;;;*************************************************************************;;; 
 
(defun DSX-AddLine 
        (p1 p2 lay col ltype / obj) 
        (dsx-princ "\n(DSX-AddLine)") 
        (cond 
                ( (vl-catch-all-error-p 
                                (setq obj 
                                        (vl-catch-all-apply 
                                                'vla-AddLine 
                                                (list 
                                                        (DSX-ActiveSpace) 
                                                        (vlax-3d-Point p1) 
                                                        (vlax-3d-Point p2) 
                                                ) 
                                        ) 
                                ) 
                        ) 
                        (dsx-objerr obj) 
                ) 
                ( T 
                         (if lay (vla-put-Layer obj lay)) 
                  (if col (vla-put-Color obj col)) 
                  (if ltype (DSX-ApplyLtype obj ltype)) 
                  (vla-Update obj) 
                  (vlax-release-object obj) 
                  (entlast) 
                ) 
        ) 
) 
 
;;;*************************************************************************;;; 
;;; MODULE: DSX-AddLineC                                                    ;;; 
;;; DESCRIPTION: Creates multiple segment LINEs from list of points         ;;; 
;;; ARGS: points-list, closed-flag, layer, color, linetype                  ;;; 
;;; EXAMPLE: (DSX-AddLineC plist T "WALLS" nil nil) --> closed at end       ;;; 
;;; NOTES:                                                                  ;;; 
;;;*************************************************************************;;; 
 
(defun DSX-AddLineC 
        (ptlist Bclosed strLayer intColor strLtype / pt1 ptz) 
  (dsx-princ "\n(DSX-AddLineC)") 
   
  (cond 
    ( (and ptlist (listp ptlist) (listp (car ptlist))) 
                        (setq pt1 (car  ptlist);; save first point 
                                                ptz (last ptlist);; save last point 
                        ) 
                        (while (and ptlist (>= (length ptlist) 2)) 
                                (DSX-AddLine (car ptlist) (cadr ptlist) strLayer intColor strLtype) 
                                (setq ptlist (cdr ptlist)) 
                        ) 
                        (if (= Bclosed T) (DSX-AddLine pt1 ptz strLayer intColor strLtype) ) 
                ) 
        ); cond 
) 
 
;;;*************************************************************************;;; 
;;; MODULE: DSX-AddPoint                                                    ;;; 
;;; DESCRIPTION: Creates a POINT object with given properties               ;;; 
;;; ARGS: point, layer, color                                               ;;; 
;;; EXAMPLE: (DSX-AddPoint pt1 "WALLS" nil)                                 ;;; 
;;; NOTES:                                                                  ;;; 
;;;*************************************************************************;;; 
 
(defun DSX-AddPoint 
        (pt strLayer col / obj) 
  (dsx-princ "\n(DSX-AddPoint)") 
  (cond 
    ( (vl-catch-all-error-p 
                                (setq obj 
                                        (vl-catch-all-apply 
                                                'vla-AddPoint 
                                                (list 
                                                        (DSX-ActiveSpace) 
                                                        (vlax-3d-point pt) 
                                                ) 
                                        ) 
                                ) 
                        ) 
                        (dsx-objerr obj) 
                ) 
                ( T 
                        (if strLayer (vla-Put-Layer obj strLayer)) 
                  (if col      (vla-Put-Color obj col)) 
                        (vla-Update obj) 
                        (vlax-Release-Object obj) 
                        (entlast) 
                ) 
        ) 
) 
 
;;;*************************************************************************;;; 
;;; MODULE: DSX-AddEllipse                                                  ;;; 
;;; DESCRIPTION: Creates a closed ELLIPSE with given properties             ;;; 
;;; ARGS: centerpoint, hmajor-pt, roll-angle(deg), layer, color, linetype   ;;; 
;;; EXAMPLE: (DSX-AddEllipse pt1 pt2 45 "WALLS" nil nil)                    ;;; 
;;; NOTES:                                                                  ;;; 
;;;*************************************************************************;;; 
 
(defun DSX-AddEllipse 
  (ctr hmpt roll strLayer intColor strLtype / obj) 
  (dsx-princ "\n(DSX-AddEllipse)") 
   
  (cond 
    ( (and 
                                (setq hmpt         (list 
                                                                                        (- (car  hmpt) (car  ctr)) 
                                                                                        (- (cadr hmpt) (cadr ctr)) 
                                                                                ) 
                                ) 
                        ) 
                  (cond 
                                ( (vl-catch-all-error-p 
                                                (setq        obj 
                                                        (vl-catch-all-apply 
                                                                'vla-addEllipse 
                                                                (list 
                                                                        (DSX-ActiveSpace) 
                                                                        (vlax-3D-Point ctr) 
                                                                        (vlax-3D-Point hmpt) 
                                                                        (Roll->Ratio roll) 
                                                                ) 
                                                        ) 
                                                ) 
                                        ) 
                                  (dsx-objerr obj) 
                                ) 
                                ( T 
                                        (if strLayer (vla-Put-Layer obj strLayer)) 
                                        (if intColor (vla-Put-Color obj intColor)) 
                                        (if strLtype (DSX-ApplyLtype   obj strLtype)) 
                                        (vla-Update obj) 
                                  (vlax-Release-Object obj) 
                                  (entlast) 
                                ) 
                        ) 
                ) 
                ( T (princ "\n(DSX-AddEllipse): Invalid parameter list!") ) 
        ) 
) 
 
;;;*************************************************************************;;; 
;;; MODULE: DSX-AddEllipseArc1                                              ;;; 
;;; DESCRIPTION: Creates ARC-Ellipse with given properties using roll-angle ;;; 
;;; ARGS: center-pt, hmajor-pt, roll(deg), start-ang, end-ang, layer, color, linetype 
;;; EXAMPLE: (DSX-AddEllipseArc1 pt1 pt2 45 90 180 "WALLS" nil nil)         ;;; 
;;; NOTES:                                                                  ;;; 
;;;*************************************************************************;;; 
 
(defun DSX-AddEllipseArc1 
  (ctr hmpt roll StartAng EndAng strLayer intColor strLtype / obj rang) 
  (dsx-princ "\n(DSX-AddEllipseArc1)") 
   
  (cond 
    ( (and 
                                (setq hmpt  (list 
                                                                                (- (car  hmpt) (car  ctr)) 
                                                                                (- (cadr hmpt) (cadr ctr)) 
                                                                        ) 
                                ) 
                        ) 
                  (cond 
                                ( (vl-catch-all-error-p 
                                                (setq        obj 
                                                        (vl-catch-all-apply 
                                                                'vla-AddEllipse 
                                                                (list 
                                                                        (DSX-ActiveSpace) 
                                                                        (vlax-3D-Point ctr) 
                                                                        (vlax-3D-Point hmpt) 
                                                                        (Roll->Ratio roll) 
                                                                ) 
                                                        ) 
                                                ) 
                                        ) 
                                  (dsx-objerr obj) 
                                ) 
                                ( T 
                                        (vla-Put-StartAngle obj (DTR StartAng)) 
                                        (vla-Put-EndAngle   obj (DTR EndAng)) 
                                        (if strLayer (vla-Put-Layer obj strLayer)) 
                                        (if intColor (vla-Put-Color obj intColor)) 
                                        (if strLtype (DSX-ApplyLtype obj strLtype)) 
                                        (vla-Update obj) 
                                        (vlax-Release-Object obj) 
                                        (entlast) 
                                ) 
                        ) 
                ) 
                ( T (princ "\n(DSX-AddEllipseArc1): Invalid parameter list...") ) 
        ) 
) 
 
;;;************************************************************************;;; 
;;; MODULE: DSX-AddEllipseArc2 ()                                          ;;; 
;;; DESCRIPTION: Same as DSX-AddEllipseArc1 but uses h-minor ratio         ;;; 
;;; ARGS: centerpoint, h-major-pt, h-minor-ratio, start-ang(deg), end-ang(deg), layer, color, linetype 
;;; EXAMPLE:                                                               ;;; 
;;;************************************************************************;;; 
 
(defun DSX-AddEllipseArc2 
  (ctr hmpt hmin StartAng EndAng strLayer intColor strLtype / obj rang) 
  (dsx-princ "\n(DSX-AddEllipseArc2)") 
   
  (cond 
    ( (and 
                                ctr (listp ctr) hmpt (listp hmpt) hmin StartAng EndAng 
                                (setq hmpt  (list 
                                                                                        (- (car  hmpt) (car  ctr)) 
                                                                                        (- (cadr hmpt) (cadr ctr)) 
                                                                                ) 
                                ) 
                        ) 
                  (cond 
                                ( (vl-catch-all-error-p 
                                                (setq obj 
                                                        (vl-catch-all-apply 
                                                                'vla-AddEllipse 
                                                                (list 
                                                                        (DSX-ActiveSpace) 
                                                                        (vlax-3D-Point ctr) 
                                                                        (vlax-3D-Point hmpt) 
                                                                        hmin ; radius-ratio value 
                                                                ) 
                                                        ) 
                                                ) 
                                        ) 
                                  (dsx-objerr obj) 
                                ) 
                                ( T 
                                        (vla-Put-StartAngle obj (DTR StartAng)) 
                                        (vla-Put-EndAngle   obj (DTR EndAng)) 
                                        (if strLayer (vla-Put-Layer obj strLayer)) 
                                        (if intColor (vla-Put-Color obj intColor)) 
                                        (if strLtype (DSX-ApplyLtype obj strLtype)) 
                                        (vla-Update obj) 
                                        (vlax-release-object obj) 
                                        (entlast) 
                                ) 
                        ) 
                ) 
                ( T (princ "\n(DSX-AddEllipseArc2): Invalid Parameter list...") ) 
        ) 
) 
 
 
;;;************************************************************************;;; 
;;; MODULE: DSX-AddPline ()                                                ;;; 
;;; DESCRIPTION: Create LwPolyline object with given properties & width.   ;;; 
;;; ARGS: pointlist, close, layer, color, linetype, lweight, lt-gen-flag   ;;; 
;;; EXAMPLE: (DSX-AddPline ptlist "Layer" T 3 "CENTER3" 0 nil)             ;;; 
;;;************************************************************************;;; 
 
(defun DSX-AddPline 
  (ptlist strLayer Bclosed intColor strLt dblWidth bLTG 
   / vrtcs plgen plist plpoints obj) 
   
  (dsx-princ "\n(DSX-AddPline)") 
   
  (cond 
    ( (and ptlist (listp ptlist) (listp (car ptlist))) 
                        (setq plist     (apply 'append (mapcar '3dpoint->2dpoint ptlist)) 
                                                plpoints  (List->VariantArray plist) 
                        ) 
                  (cond 
                                ( (vl-catch-all-error-p 
                                                (setq obj 
                                                        (vl-catch-all-apply 
                                                                'vla-AddLightWeightPolyline 
                                                                (list 
                                                                        (DSX-ActiveSpace) 
                                                                        plpoints 
                                                                ) 
                                                        ) 
                                                ) 
                                        ) 
                                  (dsx-objerr obj) 
                                ) 
                                ( T 
                                        (if Bclosed  (vla-Put-Closed obj :vlax-True));; make closed 
                                        (if strLayer (vla-Put-Layer obj strLayer));; apply layer 
                                        (if intColor (vla-Put-Color obj intColor));; apply color 
                                        (if dblWidth (vla-Put-ConstantWidth obj dblWidth));; apply constant width 
                                        (if strLt    (DSX-ApplyLtype obj strLt)) 
                                  (if bLTG                  (DSX-ApplyLtypeGen obj)) 
                                        (vla-Update obj);; force graphic update 
                                        (vlax-Release-Object obj) 
                                        (entlast) 
                                ) 
                        ) 
                ) 
                ( T (princ "\n(DSX-AddPline): Invalid parameter list...") ) 
        ) 
) 
 
;;;************************************************************************;;; 
;;; MODULE: DSX-AddSolid                                                   ;;; 
;;; DESCRIPTION: Create solid region with given properties and points      ;;; 
;;; ARGS: pointlist, layer, color                                          ;;; 
;;; EXAMPLE: (DSX-AddSolid (list p1 p2 p3) "0" 3)                          ;;; 
;;;************************************************************************;;; 
 
(defun DSX-AddSolid 
  (ptlist strLayer intColor / plist obj) 
   
  (dsx-princ "\n(DSX-AddSolid)") 
   
  (cond 
    ( (and ptlist (listp ptlist) (listp (car ptlist))) 
                        (if (= (length ptlist) 3) 
                                (setq plist (append ptlist (list (last ptlist)))) 
                                (setq plist ptlist) 
                        ) 
                        (dsx-princ "\nMaking solid object...") 
                  (cond 
                          ( (vl-catch-all-error-p 
                                                (setq obj 
                                                        (vl-catch-all-apply 
                                                                'vla-AddSolid 
                                                                (list 
                                                                        (DSX-ActiveSpace) 
                                                                        (vlax-3D-Point (car plist)) 
                                                                        (vlax-3D-Point (cadr plist)) 
                                                                        (vlax-3D-Point (caddr plist)) 
                                                                        (vlax-3D-Point (cadddr plist)) 
                                                                ) 
                                                        ) 
                                                ) 
                                        ) 
                                  (dsx-objerr obj) 
                                ) 
                                ( T 
                                        (if strLayer (vla-Put-Layer obj strLayer)) 
                                        (if intColor (vla-Put-Color obj intColor)) 
                                        (vla-Update obj) 
                                  (vlax-Release-Object obj) 
                                  (entlast) 
                                ) 
                  ) 
                ) 
                ( T (princ "\n(DSX-AddSolid): Invalid parameter list...") ) 
        ) 
) 
 
;;;*************************************************************************;;; 
;;; MODULE: DSX-AddText                                                     ;;; 
;;; DESCRIPTION: Create TEXT objects with given properties                  ;;; 
;;; ARGS: textstring, inspt, justification, stylename, height(real), width(real), rotation(real), layer, color 
;;; EXAMPLE: (DSX-AddText "TITLE" pt1 "MC" "Standard" 0.15 1.0 0 "TEXT" nil)    
;;; NOTES:                                                                  ;;; 
;;;*************************************************************************;;; 
 
(defun DSX-AddText 
        (strTxt pt Just strStyle dblHgt dblWid dblRot strLay intCol 
         / txtobj 
        ) 
 
        (dsx-princ "\n(DSX-AddText)") 
        
        (cond 
                ( (vl-catch-all-error-p 
                                (setq txtobj 
                                        (vl-catch-all-apply 
                                          'vla-AddText 
                                                (list 
                                                        (DSX-ActiveSpace) 
                                                        strTxt 
                                                        (if (not (member (strcase Just) '("A" "F"))) 
                                                                (vlax-3d-Point pt) 
                                                                (vlax-3d-Point (car pt)) 
                                                        ) 
                                                        dblHgt ;; ignored for ALIGNED justified text 
                                                ) 
                                        ) 
                                ) 
                        ) 
                  (dsx-objerr txtobj) 
                ) 
                ( T 
                  (if strstyle (vla-put-StyleName txtobj strStyle)) 
                  (if strLay (vla-put-Layer txtobj strLay)) 
                  (if intCol (vla-put-Color txtobj intCol)) 
 
                        ;; Left/Align/Fit/Center/Middle/Right/BL/BC/BR/ML/MC/MR/TL/TC/TR 
                        ;; Note that "Left" is not a normal default. 
                        ;; 
                        ;; ALIGNMENT TYPES... 
                        ;; AcAlignmentLeft=0 
                        ;; AcAlignmentCenter=1 
                        ;; AcAlignmentRight=2 
                        ;; AcAlignmentAligned=3 
                        ;; AcAlignmentMiddle=4 
                        ;; AcAlignmentFit=5 
                        ;; AcAlignmentTopLeft=6 
                        ;; AcAlignmentTopCenter=7 
                        ;; AcAlignmentTopRight=8 
                        ;; AcAlignmentMiddleLeft=9 
                        ;; AcAlignmentMiddleCenter=10 
                        ;; AcAlignmentMiddleRight=11 
                        ;; AcAlignmentBottomLeft=12 
                        ;; AcAlignmentBottomCenter=13 
                        ;; AcAlignmentBottomRight=14 
                        ;;                                                                
                        ;; HORIZONTAL JUSTIFICATIONS...                                  
                        ;; AcHorizontalAlignmentLeft=0                                    
                        ;; AcHorizontalAlignmentCenter=1                                  
                        ;; AcHorizontalAlignmentRight=2                                  
                        ;; AcHorizontalAlignmentAligned=3                                 
                        ;; AcHorizontalAlignmentMiddle=4                                  
                        ;; AcHorizontalAlignmentFit=5                                     
                        ;;                                                                
                        ;; VERTICAL JUSTIFICATIONS...                                     
                        ;; AcVerticalAlignmentBaseline=0                                  
                        ;; AcVerticalAlignmentBottom=1                                    
                        ;; AcVerticalAlignmentMiddle=2                                    
                        ;; AcVerticalAlignmentTop=3                                       
                  
                  (cond 
                                ( (= Just "L") 
                                  (if dblWid (vla-put-ScaleFactor txtobj dblWid)) 
                                  (if dblRot (vla-put-Rotation txtobj (DTR dblRot))) 
                          ) 
                                ( (= Just "C") 
                                  (vla-put-Alignment txtobj 1) 
                                  (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt)) 
                                  (if dblWid (vla-put-ScaleFactor txtobj dblWid)) 
                                  (if dblRot (vla-put-Rotation txtobj (DTR dblRot))) 
                          ) 
                                ( (= Just "R") 
                                  (vla-put-Alignment txtobj 2) 
                                  (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt)) 
                                  (if dblWid (vla-put-ScaleFactor txtobj dblWid)) 
                                  (if dblRot (vla-put-Rotation txtobj (DTR dblRot))) 
                                ) 
                                ( (= Just "A") 
                                  (vla-put-Alignment txtobj 3) 
                                  (vla-put-TextAlignmentPoint txtobj (vlax-3d-point (cadr pt))) 
                          ) 
                                ( (= Just "M") 
                                  (vla-put-Alignment txtobj 4) 
                                  (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt)) 
                                  (if dblWid (vla-put-ScaleFactor txtobj dblWid)) 
                                  (if dblRot (vla-put-Rotation txtobj (DTR dblRot))) 
                                ) 
                                ( (= Just "F") 
                                  (vla-put-Alignment txtobj 5) 
                                  (vla-put-TextAlignmentPoint txtobj (vlax-3d-point (cadr pt))) 
                                ) 
                                ( (= Just "TL");; Top-Left 
          (vla-put-Alignment txtobj 6) 
          (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt)) 
          (if dblWid (vla-put-ScaleFactor txtobj dblWid)) 
          (if dblRot (vla-put-Rotation txtobj (DTR dblRot))) 
        ) 
        ( (= Just "TC");; Top-Center 
          (vla-put-Alignment txtobj 7) 
          (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt)) 
          (if dblWid (vla-put-ScaleFactor txtobj dblWid)) 
          (if dblRot (vla-put-Rotation txtobj (DTR dblRot))) 
        ) 
        ( (= Just "TR");; Top-Right 
          (vla-put-Alignment txtobj 8) 
          (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt)) 
          (if dblWid (vla-put-ScaleFactor txtobj dblWid)) 
          (if dblRot (vla-put-Rotation txtobj (DTR dblRot))) 
        ) 
                                ( (= Just "ML") 
                                  (vla-put-Alignment txtobj 9) 
                                  (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt)) 
                                  (if dblWid (vla-put-ScaleFactor txtobj dblWid)) 
                                  (if dblRot (vla-put-Rotation txtobj (DTR dblRot))) 
                          ) 
                                ( (= Just "MC") 
                                  (vla-put-Alignment txtobj 10) 
                                  (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt)) 
                                  (if dblWid (vla-put-ScaleFactor txtobj dblWid)) 
                                  (if dblRot (vla-put-Rotation txtobj (DTR dblRot))) 
                           ) 
                                ( (= Just "MR") 
                                  (vla-put-Alignment txtobj 11) 
                                  (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt)) 
                                  (if dblWid (vla-put-ScaleFactor txtobj dblWid)) 
                                  (if dblRot (vla-put-Rotation txtobj (DTR dblRot))) 
                          ) 
                                ( (= Just "BL") 
                                  (vla-put-Alignment txtobj 12) 
                                  (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt)) 
                                  (if dblWid (vla-put-ScaleFactor txtobj dblWid)) 
                                  (if dblRot (vla-put-Rotation txtobj (DTR dblRot))) 
                          ) 
                                ( (= Just "BC") 
                                  (vla-put-Alignment txtobj 13) 
                                  (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt)) 
                                  (if dblWid (vla-put-ScaleFactor txtobj dblWid)) 
                                  (if dblRot (vla-put-Rotation txtobj (DTR dblRot))) 
                          ) 
                                ( (= Just "BR") 
                                  (vla-put-Alignment txtobj 14) 
                                  (vla-put-TextAlignmentPoint txtobj (vlax-3d-point pt)) 
                                  (if dblWid (vla-put-ScaleFactor txtobj dblWid)) 
                                  (if dblRot (vla-put-Rotation txtobj (DTR dblRot))) 
                          ) 
                        ) 
      (vla-update txtobj) 
                  (vlax-Release-Object txtobj) 
                  (entlast) 
                ) 
        ) 
) 
 
;;;*************************************************************************;;; 
;;; MODULE: DSX-AddPolygon                                                  ;;; 
;;; DESCRIPTION: Creates a circumscribed polygon                            ;;; 
;;; ARGS: center, radius, sides, flag ("C" or "I"), width, layer, color, ltype, ltgen 
;;; EXAMPLE: (DSX-AddPolygon pt1 1.0 6 "C" 0 "0" nil "DASHED" T)            ;;; 
;;;*************************************************************************;;; 
 
(defun DSX-AddPolygon 
  (ctrpt dblRad intSides strType dblWid strLay intCol strLtype Bltgen 
   / pa dg ptlist deg) 
  (dsx-princ "\n(DSX-AddPolygon)") 
  (if (= (strcase strType) "C") 
    (setq dblRad (* dblRad (/ 1 (/ (sqrt 3.0) 2.0)))) 
  ) 
  (setq pa (polar ctrpt 0 dblRad)       
        dg (/ 360.0 intSides);; get angles between faces 
        deg dg 
  ) 
  (repeat intSides 
    (setq ptlist 
      (if ptlist 
        (append ptlist (list (polar ctrpt (DTR deg) dblRad))) 
        (list (polar ctrpt (DTR deg) dblRad)) 
      ) 
    ) 
    (setq deg (+ dg deg)) 
  ) 
  (DSX-AddPline ptlist strLay T intCol strLtype dblWid Bltgen) 
) 
 
;;;*************************************************************************;;; 
;;; MODULE: DSX-AddRectangle                                                ;;; 
;;; DESCRIPTION: Creates LwPolyline rectangle with given properties         ;;; 
;;; ARGS: pt1, pt2, layer, color, linetype, lineweight, ltgen-flag          ;;; 
;;; EXAMPLE: (DSX-AddRectangle p1 p2 "DOORS" 1 "DASHED" 0 nil)              ;;; 
;;; NOTES:                                                                  ;;; 
;;;*************************************************************************;;; 
 
(defun DSX-AddRectangle 
        (p1 p3 strLayer intColor strLtype dblWid bLTG / p2 p4 obj) 
        (dsx-princ "\n(DSX-AddRectangle)") 
 
        (setq p2 (list (car p1) (cadr p3)) 
                                p4 (list (car p3) (cadr p1)) 
        ) 
        (cond 
                ( (setq obj 
                                (DSX-AddPline (list p1 p2 p3 p4) 
                                        strLayer T intColor strLtype dblWid bLTG 
                                ) 
                        ) 
                  obj ;; raise object (entity name) 
          ) 
        ) 
) 
 
;;;*************************************************************************;;; 
;;; MODULE: DSX-AttachXREF                                                  ;;; 
;;; DESCRIPTION: Attaches named drawing as an XREF-ATTACHment               ;;; 
;;; ARGS: pathname, fulldwgname                                             ;;; 
;;; EXAMPLE: (DSX-AttachXREF "c:\\dwgfiles" "c:\\dwgfiles\\dwg1.dwg")       ;;; 
;;; NOTES:                                                                  ;;; 
;;;*************************************************************************;;; 
 
(defun DSX-AttachXREF (pathname fullname) 
        (dsx-princ "\n(DSX-AttachXREF)") 
        (vlax-for layout 
                (vla-get-layouts (DSX-ActiveDocument)) 
                (vla-AttachExternalReference 
                        (vla-get-Block layout) 
                        pathname 
                        fullname 
                        (vlax-3d-point '(0.0 0.0 0.0)) 
                        1.0 1.0        1.0        0.0 
                        :vlax-false 
                ) 
        ) 
) 
 
;;;*************************************************************************;;; 
;;; MODULE: Roll->Ratio                                                     ;;; 
;;; DESCRIPTION: Converts a roll angle into the h-major/minor ratio value   ;;; 
;;; ARGS: roll-angle (deg)                                                  ;;; 
;;; EXAMPLE: (Roll->Ratio 45) --> 0.707107                                  ;;; 
;;; NOTES:                                                                  ;;; 
;;;*************************************************************************;;; 
 
(defun Roll->Ratio (RollAngle) 
  (cos (DTR RollAngle)) 
) 
 
;;;*************************************************************************;;; 
;;; MODULE: DSX-GetEllipseArcPoints                                         ;;; 
;;; DESCRIPTION: Returns coordinates of Elliptical-Arc endpoints in current UCS or WCS (default) 
;;; ARGS: entity-or-object                                                  ;;; 
;;; EXAMPLE: (DSX-GetEllipseArcPoints ellObj) -->((1.0 2.0 0.0) (1.0 3.0 0.0)) 
;;; NOTES:                                                                  ;;; 
;;;*************************************************************************;;; 
 
(defun DSX-GetEllipseArcPoints 
  (ellent / ename-ellipse vlaobject-ellipse p-start p-end out) 
   
  (dsx-princ "\n(DSX-GetEllipseArcPoints)") 
   
  (setq vlaObject-Ellipse (DSX-MakeObject ellent);; convert ename to object 
        p-start (vla-Get-StartPoint vlaObject-Ellipse) 
        p-end   (vla-Get-EndPoint   vlaObject-Ellipse) 
        out     (list 
                  (vlax-SafeArray->List (vlax-Variant-Value p-start)) 
                  (vlax-SafeArray->List (vlax-Variant-Value p-end)) 
                ) 
  ) 
  out 
); defun 
 
;;;************************************************************************;;; 
;;; MODULE: DeltaPt                                                        ;;; 
;;; DESCRIPTION: Determine delta offset from point<p1> to point<p2>        ;;; 
;;; ARGS: point1, point2                                                   ;;; 
;;; EXAMPLE: (DeltaPt p1 p2) returns (1.0 2.4 0.0)                         ;;; 
;;; NOTES:                                                                 ;;; 
;;;************************************************************************;;; 
 
(defun DeltaPt (p1 p2) 
  (list 
    (- (car p2) (car p1));; x-delta 
    (- (cadr p2) (cadr p1));; y-delta 
    (- (caddr p2) (caddr p1));; z-delta 
  ) 
) 
 
;;;************************************************************************;;; 
;;; MODULE: DSX-ApplyLtype                                                 ;;; 
;;; DESCRIPTION: Apply linetype to vla-object or entity                    ;;; 
;;; ARGS: entname(or vla-object), linetype-name                            ;;; 
;;; EXAMPLE: (DSX-ApplyLtype line-ent "DASHED")                            ;;; 
;;; NOTES:                                                                 ;;; 
;;;************************************************************************;;; 
 
(defun DSX-ApplyLtype 
        (obj strLtype / ent els try ltobj ltn) 
  (dsx-princ "\n(DSX-ApplyLtype)") 
   
  (cond 
                ( (not (member (strcase strLtype) '("CONTINUOUS" "BYBLOCK" "BYLAYER"))) 
                  (if (setq ltobj (dsx-loadltype strLtype nil)) 
                    (progn 
                            (setq ltn (vla-get-name ltobj)) 
                            (vlax-put-property (dsx-makeobject obj) ltn) 
                            (vlax-release-object ltobj) 
                    ) 
                  ) 
                  ( T 
                    (vlax-put-property (dsx-makeobject obj) strLtype) 
                  ) 
                ) 
        ) 
) 
 
;;;************************************************************************;;; 
;;; MODULE: DSX-ApplyLtScale                                               ;;; 
;;; DESCRIPTION: Apply object linetype scaling                             ;;; 
;;; ARGS: ename or object, scale (real)                                    ;;; 
;;; EXAMPLE: (DSX-ApplyLtScale line-ent 24.0)                              ;;; 
;;; NOTES:                                                                 ;;; 
;;;************************************************************************;;; 
 
(defun DSX-ApplyLtScale 
        (ent sc / obj) 
  (dsx-princ "\n(DSX-ApplyLtScale)") 
 
  (setq obj (DSX-MakeObject ent)) 
 
  (if (vlax-property-available-p obj "linetypescale") 
    (vla-Put-LinetypeScale obj sc) 
    (princ "\n(DSX-ApplyLtScale): Unable to modify object linetype scale property...") 
  ) 
  (vlax-Release-Object obj) 
) 
 
;;;************************************************************************;;; 
;;; MODULE: DSX-ApplyLtypeGen                                              ;;; 
;;; DESCRIPTION: Apply linetype-generation to polyline or lwpolyline object;;; 
;;; ARGS: linetype-name, object or ename                                   ;;; 
;;; EXAMPLE: (DSX-ApplyLtypeGen "CENTER3" pline-obj)                       ;;; 
;;; NOTES:                                                                 ;;; 
;;;************************************************************************;;; 
 
(defun DSX-ApplyLtypeGen (object) 
  (dsx-princ "\n(DSX-ApplyLtypeGen)") 
        (if (vlax-property-available-p object "linetypegeneration") 
          (vla-Put-LinetypeGeneration object :vlax-True) 
                (princ "\nError: Object has not 'linetypegeneration' property.") 
        ) 
) 
 
;;;*************************************************************************;;; 
;;; MODULE: DSX-GetAttributes                                               ;;; 
;;; DESCRIPTION: Returns attribute data list ((tag . value) (tag . value)...) 
;;; ARGS: entity-or-object (blockref)                                       ;;; 
;;; EXAMPLE: (DSX-GetAttributes blkent)                                     ;;; 
;;; NOTES:                                                                  ;;; 
;;;*************************************************************************;;; 
 
(defun DSX-GetAttributes (ent / blkref lst) 
        (dsx-princ "\n(DSX-GetAttributes)") 
        (setq blkref (DSX-MakeObject ent)) 
  (if (= (vla-get-objectname blkref) "AcDbBlockReference") 
    (if (vla-get-hasattributes blkref) 
      (mapcar 
                                '(lambda (x) 
                                         (setq lst 
                                                                 (cons 
                                                                         (cons 
                                                                                 (vla-get-tagstring x) 
                                                                                 (vla-get-textstring x) 
                                                                         ) 
                                                                         lst 
                                                                ) 
                                        ) 
              ) 
              (vlax-safearray->list 
                                        (vlax-variant-value (vla-getattributes blkref)) 
                                ) 
      ); mapcar 
    ); endif 
  ); endif 
  (reverse lst) 
) 
 
;;;*************************************************************************;;; 
;;; MODULE: DSX-ModAttributes                                               ;;; 
;;; DESCRIPTION: Updates block attribute values with cons list              ;;; 
;;; ARGS: block-object, att-value-list                                      ;;; 
;;; EXAMPLE: (DSX-ModAttributes blkobj '(("tag1" . "value1")...))           ;;; 
;;; NOTES:                                                                  ;;; 
;;;*************************************************************************;;; 
 
(defun DSX-ModAttributes 
        (blkobj datlst / itm atts) 
        (dsx-princ "\n(DSX-ModAttributes)") 
  (if (= (vla-Get-HasAttributes blkobj) :vlax-true) 
    (progn 
      (setq atts 
                                                         (vlax-SafeArray->list 
                                                           (vlax-Variant-Value (vla-GetAttributes blkobj)) 
                                                         ) 
      ); setq 
      (foreach item datlst 
                                (mapcar 
                                  '(lambda (x) 
                                     (if 
                                       (= (strcase (car item)) (strcase (vla-get-TagString x))) 
                                                        (vla-put-TextString x (cdr item)) 
                                     ) 
                                   ) 
                                  atts 
                                ); mapcar 
      ); foreach 
      (vla-Update blkobj) 
    ) 
  ); endif 
) 
 
;;;*************************************************************************;;; 
;;; MODULE: DSX-CopyProp                                                    ;;; 
;;; DESCRIPTION: Copies named properties from one object to another         ;;; 
;;; ARGS: property-name(string), source(object), target(object)             ;;; 
;;; EXAMPLE: (DSX-CopyProp "Layer" obj1 obj2)                               ;;; 
;;; NOTES:                                                                  ;;; 
;;;*************************************************************************;;; 
 
(defun DSX-CopyProp (propName source target) 
        (dsx-princ "\n(DSX-CopyProp)") 
  (cond 
    ( (and 
        (not (vlax-erased-p source));; is source accessible? 
        (not (vlax-erased-p target));; is target accessible? 
        (vlax-property-available-p source propName);; is property valid? 
        (vlax-property-available-p target propName T);; is property modifiable? 
      ) 
                  (vlax-put-property 
                    target propName 
                    (vlax-get-property source propName) 
                  ) 
                  T ;; return TRUE 
                ) 
                ( T (princ "\nOne or more objects inaccessible!")        ) 
  ); cond 
) 
 
;;;*************************************************************************;;; 
;;; MODULE: DSX-MapPropertyList                                             ;;; 
;;; DESCRIPTION: Copies multiple properties from one object to another      ;;; 
;;; ARGS: list, object, object                                              ;;; 
;;; EXAMPLE: (DSX-MapPropertyList '("Layer" "Color") obj1 obj2)             ;;; 
;;; NOTES:                                                                  ;;; 
;;;*************************************************************************;;; 
 
(defun DSX-MapPropertyList (propList source target) 
        (dsx-princ "\n(DSX-MapPropertyList)") 
  (foreach prop propList 
    (DSX-CopyProp prop source target) 
  ) 
) 
 
;;;*************************************************************************;;; 
;;; MODULE: Tol                                                             ;;; 
;;; DESCRIPTION: checks to see if num is between two values be them upper or lower limits or a toleranced target value.        ;;; 
;;; ARGS: num, target, toler, uplim, lolim                                  ;;; 
;;; EXAMPLE: (Tol 4.5 4.52 0.05 nil nil) or (Tol 4.5 nil nil 3 5) returns T ;;; 
;;; NOTES:                                                                  ;;; 
;;;*************************************************************************;;; 
 
(defun Tol (num target toler uplim lolim) 
  (cond 
    ( (and (/= toler nil) (/= target nil)) 
      (if (<= (- target toler) num (+ target toler)) T) 
    ) 
    ( T (if (<= lolim num uplim) T) ) 
  ) 
) 
 
;;;************************************************************************* 
;;; MODULE: DSX-AddLeader-Simple 
;;; DESCRIPTION: Add LEADER with TEXT using 2 points and text string value 
;;; ARGS: point1, point2, textstring 
;;; EXAMPLE: (DSX-AddLeader-Simple p1 p2 "REFERENCE LINE") 
;;;************************************************************************* 
 
(defun DSX-AddLeader-Simple 
        (p1 p2 text) 
        (vl-cmdf "leader" "_NON" p1 "_NON" p2 "A" text "") 
        (entlast) 
) 
 
;;;************************************************************************* 
;;; MODULE: DSX-AddLeader 
;;; DESCRIPTION: Creates leader with given properties and text string 
;;; ARGS: points-list, textstring (or list of strings) , txtheight, justification key ("T" "M" "B"), pointer (ACAD enum), layer(opt), color(opt), dimstyle(opt) 
;;; EXAMPLE: (DSX-AddLeader ptlist "DATUM LINE" 0.15 "T" acArrowDefault $lay $tlay acByLayer nil) returns Ename 
;;;************************************************************************* 
 
(defun DSX-AddLeader 
        (ptlist txtstr hgt justky pntr lay mlay col style / Make3dPt xlist xarray xvariant oLeader mtpt oMtext tmp i) 
 
        (defun Make3dPt (pt) 
                (if (not (caddr pt)) 
                        (list 
                                (car pt) 
                                (cadr pt) 
                                (getvar "elevation") 
                        ) 
                        pt 
                ) 
        ) 
        ;; Odd stuff here: A Leader object uses a flat matrix for 
        ;; its coordinates list.  The array is simply a list of all 
        ;; coordinate points appended into a single 1 dimensional list 
        ;; In order to make a Leader, you must first stuff all the 
        ;; supplied points into a flat list, then convert that list 
        ;; into a safearray and then convert the safearray into a 
        ;; variant object.  Then the AddLeader function will accept 
        ;; it. 
        ;; Also, the AnnotationObject property will not allow anything 
        ;; but a valid object handle.  The documentation says it will 
        ;; accept NULL (aka nil, vlax-vbNull, etc.) but this causes 
        ;; an error and fails entirely.  You must supply an object of 
        ;; some kind to make the Leader object work in VLISP. 
        
        ;; pack coords into a flat matrix list 
        (setq xlist (apply 'append (mapcar 'Make3dPt ptlist))) 
 
        ;; Convert flat list into a safearray 
        (setq xarray 
                (vlax-safearray-fill 
                        (vlax-make-safearray 
                                vlax-vbDouble 
                                (cons 
                                        0 
                                        (1- (length xlist)) 
                                ) 
                        ) 
                        xlist 
                ) 
        ) 
 
        ;; Convert safearray into a variant object 
        (setq xvariant (vlax-make-variant xarray)) 
 
        ;; Calculate attachment point of Mtext object off of end of 
        ;; last point in leader coordinates list 
  ;; Only Justifications on the ends are supported -- 
  ;;   (TL, ML, BL, TR, MR, & BR) therefore the justky tells whether 
  ;;   its T (top) M (middle) or B (bottom) concatenated with "L" or "R" 
  ;;   upon examination of the point list. 
        (if 
                (> 
                        (car (nth 0 (reverse ptlist))) 
                        (car (nth 1 (reverse ptlist))) 
                ) 
    (setq mtpt (DSX-PTOFF (last ptlist) 0.125 (/ (ASWPM-TextSize1) 2.0)) 
          mtjs (strcat justky "L") 
    ) 
                (setq mtpt (PTOFF (last ptlist) -0.125 (/ (ASWPM-TextSize1) 2.0)) 
          mtjs (strcat justky "R") 
    ) 
  ) 
  (cond 
    ( (or (= mtjs "TL") (= mtjs "TR")) (setq offst (- (/ hgt 2.0)))) 
    ( (or (= mtjs "BR") (= mtjs "BL")) (setq offst (/ hgt 2.0))) 
    ( T (setq offst nil)) 
         ) 
 
  ;; function allows for a list of strings which correspond to different lines 
  ;; of text.  This portion will concatenate the strings in the list to reflect 
  ;; the different lines of text using the control code "\\P" for new lines. 
 
  (cond 
    ( (listp txtstr) 
      (setq i 0 
            tmp "" 
      ) 
      (repeat (length txtstr) 
        (if (= tmp "") 
          (setq tmp (nth i txtstr)) 
          (setq tmp (strcat tmp "\\P" (nth i txtstr))) 
        ) 
        (setq i (1+ i)) 
      ) 
      (setq txtstr tmp) 
    ) 
  ) 
 
        ;; Create Mtext annotation object 
        (setq oMtext (DSX-AddMtext1 txtstr mtpt hgt 0 mtjs)) 
  (if mlay (vla-put-layer oMtext mlay)) 
        (cond 
                ( (not 
                                (vl-catch-all-error-p 
                                        (setq oLeader 
                                                (vl-catch-all-apply 
                                                        'vla-AddLeader 
                                                        (list 
                                                                (DSX-ActiveSpace) 
                                                                xvariant ; points 
                                                          oMtext ; annotation object 
                                                                acLineWithArrow ; leadertype 
                                                        ) 
                                                ); vl-catch-all-apply 
                                        ); setq 
                                ); vl-catch-all-error-p 
                        ); not 
                  (if lay (vla-put-Layer oLeader lay)) 
                  (if col (vla-put-Color oLeader col)) 
                  (if style (vla-put-StyleName oLeader style)) 
      (if pntr (vla-put-arrowheadtype oLeader pntr)) 
      (if offst 
        (progn 
                                  (setq ename (vlax-vla-object->ename oLeader) 
                            elist (entget ename) 
                            prev  (assoc 213 elist) 
                            new   (cons 213 (list 0.0 offst 0.0)) 
                            elist (subst new prev elist) 
                      ) 
                      (entmod elist) 
                      (entupd ename) 
          (vla-evaluate (DSX-MakeObject ename)) 
        ) 
      ) 
                ) 
                ( T 
                  (princ 
                                (strcat "\nError: " 
                                        (vl-catch-all-error-message oLeader) 
                                ) 
                        ) 
                  (vlax-release-object oLeader) 
                ) 
        ) 
  ename 
) 
 
(defun DSX-AddMtext1 (txt pt hgt wid jus) 
        (vl-cmdf "-mtext" "_NON" pt "_j" jus "_h" hgt "_w" wid txt "") 
        (DSX-MakeObject (entlast)) 
) 
 
;;;************************************************************************* 
;;; MODULE: dsx-Copy 
;;; DESCRIPTION: Copy method for picksets, entities or objects, returns object if possible, ignores osmode 
;;; ARGS: entity-or-object, point1, point2 
;;; EXAMPLE: (DSx-Copy (entlast) p1 p2) 
;;;************************************************************************* 
 
(defun dsx-copy (obj p1 p2 / o1 o2 i) 
        (dsx-princ "\n(dsx-copy)") 
        (cond 
                ( (= 'PICKSET (type obj)) 
                  (setq i 0) 
                  (repeat (sslength obj) 
                                (setq o1 (dsx-MakeObject (ssname obj i))) 
                                (setq o2 (vla-copy o1)) 
                                (vla-move o2 (vlax-3d-point p1) (vlax-3d-point p2)) 
                                (vlax-release-object o1) 
                                (vlax-release-object o2) 
                                (setq i (1+ i)) 
                        ) 
                ) 
                ( (= 'vla-object (type obj)) 
                  (setq o2 (vla-copy o1)) 
                  (vla-move o2 (vlax-3d-point p1) (vlax-3d-point p2)) 
                  (vlax-release-object o1) 
                  o2 
                ) 
                ( (= 'ename (type obj)) 
                  (setq o1 (dsx-MakeObject obj)) 
                  (setq o2 (vla-copy o1)) 
                  (vla-move o2 (vlax-3d-point p1) (vlax-3d-point p2)) 
                  (vlax-release-object o1) 
                  o2 
                ) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: dsx-Move 
;;; DESCRIPTION: Move method for picksets, entities or objects, returns nil, ignores osmode 
;;; ARGS: entity-or-object-or-pickset, point1, point2 
;;; EXAMPLE: (DSX-Move (entlast) p1 p2) 
;;;************************************************************************* 
 
(defun dsx-Move (obj p1 p2 / i o) 
        (dsx-princ "\n(dsx-move)") 
        (cond 
                ( (= 'PICKSET (type obj)) 
                  (setq i 0) 
                  (repeat (sslength obj) 
                                (setq o (dsx-MakeObject (ssname obj i))) 
                                (vla-move o (vlax-3d-point p1) (vlax-3d-point p2)) 
                                (vlax-release-object o) 
                                (setq i (1+ i)) 
                        ) 
                ) 
                ( (= 'VLA-OBJECT (type obj)) 
                        (vla-move obj (vlax-3d-point p1) (vlax-3d-point p2)) 
                ) 
                ( (= 'ENAME (type obj)) 
                        (setq o (dsx-MakeObject obj)) 
                        (vla-move o (vlax-3d-point p1) (vlax-3d-point p2)) 
                        (vlax-release-object o) 
                ) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: dsx-Rotate 
;;; DESCRIPTION: Rotate method for picksets, entities or objects, returns nil, ignores osmode 
;;; ARGS: entity-or-object-or-pickset, point, angle-degrees 
;;; EXAMPLE: (dsx-Rotate sset pt1 180) 
;;;************************************************************************* 
 
(defun dsx-Rotate (obj pt ang-deg / i o) 
        (dsx-princ "\n(dsx-rotate)") 
        (cond 
                ( (= 'VLA-OBJECT (type obj)) 
                  (if (vlax-method-applicable-p obj "rotate") 
                                (vla-rotate obj (vlax-3d-point pt) (DTR ang-deg)) 
                        ) 
                ) 
                ( (= 'ENAME (type obj)) 
                        (setq o (dsx-MakeObject obj)) 
                  (if (vlax-method-applicable-p o "rotate") 
                                (vla-rotate o (vlax-3d-point pt) (DTR ang-deg)) 
                        ) 
                        (vlax-release-object o) 
                ) 
                ( (= 'PICKSET (type obj)) 
                  (setq i 0) 
                  (repeat (sslength obj) 
                                (setq o (dsx-MakeObject (ssname obj i))) 
                                (if (vlax-method-applicable-p o "rotate") 
                                        (vla-rotate o (vlax-3d-point pt) (DTR ang-deg)) 
                                ) 
                                (vlax-release-object o) 
                                (setq i (1+ i)) 
                        ) 
                ) 
        ) 
) 
 
;;;************************************************************************* 
;;; MODULE: dsx-Mirror 
;;; DESCRIPTION: Mirror method for picksets, entities or objects, returns new object or nil 
;;; ARGS: ename/object/pickset, point1, point2, delete-flag 
;;; EXAMPLE: (dsx-Mirror sset p1 p2 T) mirrors and deletes original 
;;;************************************************************************* 
 
(defun dsx-Mirror (obj p1 p2 delete / o i out) 
        (dsx-princ "\n(dsx-Mirror)") 
        (cond 
                ( (= (type obj) 'vla-object) 
                  (if (vlax-method-applicable-p obj "mirror") 
                                (progn 
                                  (setq out (vla-mirror obj (vlax-3d-point p1) (vlax-3d-point p2))) 
                                  (if delete (vla-delete obj)) 
                                ) 
                        ) 
                ) 
                ( (= (type obj) 'ename) 
                  (setq o (vlax-ename->vla-object obj)) 
                  (if (vlax-method-applicable-p o "Mirror") 
                                (progn 
                                        (setq out (vlax-invoke-method o "Mirror" (vlax-3d-point p1) (vlax-3d-point p2))) 
                                  (if delete (vla-delete o)) 
                                ) 
                        ) 
                  (vlax-release-object o) 
                ) 
                ( (= (type obj) 'pickset) 
                  (setq i 0) 
                  (repeat (sslength obj) 
                                (setq o (vlax-ename->vla-object (ssname obj i))) 
                                (if (vlax-method-applicable-p o "Mirror") 
                                        (progn 
                                                (vlax-invoke-method o "Mirror" (vlax-3d-point p1) (vlax-3d-point p2)) 
                                                (if delete (vla-delete o)) 
                                        ) 
                                ) 
                                (vlax-release-object o) 
                                (setq i (1+ i)) 
                        ) 
                ) 
        ) 
        out 
) 
 
(princ) 
 
;;;************************************************************************* 
;;; MODULE: dsx-Scale 
;;; DESCRIPTION: Scale method for picksets, entities or objects, returns nil, ignores osmode 
;;; ARGS: entity-or-object-or-pickset, point, scalefactor 
;;; EXAMPLE: (dsx-Scale sset pt1 2) 
;;;************************************************************************* 
 
(defun dsx-Scale (obj pt scafac / i o) 
        (cond 
                ( (= 'PICKSET (type obj)) 
                  (setq i 0) 
                  (repeat (sslength obj) 
                                (setq o (dsx-MakeObject (ssname obj i))) 
                                (vla-ScaleEntity o (vlax-3d-point pt) scafac) 
                                (vlax-release-object o) 
                                (setq i (1+ i)) 
                        ) 
                ) 
                ( (= 'VLA-OBJECT (type obj)) 
                        (vla-ScaleEntity obj (vlax-3d-point pt) scafac) 
                ) 
                ( (= 'ENAME (type obj)) 
                        (setq o (dsx-MakeObject obj)) 
                        (vla-ScaleEntity obj (vlax-3d-point pt) scafac) 
                        (vlax-release-object o) 
                ) 
        ) 
) 
 
(princ)

taner · 发表于 2005-11-22 16:46:37

[php];;;*************************************************************************;;;
;;; DSX-API-Excel.LSP ;;;
;;; Visual LISP ActiveX API for Excel 97, 2000 and XP ;;;
;;; Copyright (C)2002 David M. Stein, All rights reserved ;;;
;;;*************************************************************************;;;
;;; Version 2002.22 05/15/02: Initial release ;;;
;;;*************************************************************************;;;
;;; Code provided AS-IS without warranty of any kind given for any purpose ;;;
;;; or use, either explicitly, implicitly or as a derivative work item. ;;;
;;; User assumes ANY AND ALL RISK and LIABILITY for use of any of this code ;;;
;;; for any consequential damages of any kind. These functions are defined ;;;
;;; within DSX Tools 2002.22 when loaded into AutoCAD. This document is ;;;
;;; provided for informational purposes only. ;;;
;;;*************************************************************************;;;

(vl-load-com)

;;;*************************************************************************
;;; MODULE: DSX-TypeLib-Excel
;;; DESCRIPTION: Returns typelib (olb) file for either Excel 97, 2000, or XP
;;; ARGS: none
;;; EXAMPLE: (DSX-TypeLib-Excel)
;;;*************************************************************************

(defun DSX-TypeLib-Excel ( / sysdrv tlb)
(setq sysdrv (getenv "systemdrive"))
(cond
( (setq tlb (findfile (strcat sysdrv "\\Program Files\\Microsoft Office\\Office\\Excel8.olb")))
 tlb
)
( (setq tlb (findfile (strcat sysdrv "\\Program Files\\Microsoft Office\\Office\\Excel9.olb")))
 tlb
)
( (setq tlb (findfile (strcat sysdrv "\\Program Files\\Microsoft Office\\Office\\Excel10.olb")))
 tlb
)
( (setq tlb (findfile (strcat sysdrv "\\Program Files\\Microsoft Office\\Office\\Excel.exe")))
tlb
)
( (setq tlb (findfile (strcat sysdrv "\\Program Files\\Microsoft Office\\Office10\\Excel.exe")))
 tlb
)
)
)

;;;*************************************************************************
;;; MODULE: DSX-Load-TypeLib-Excel
;;; DESCRIPTION: Loads typelib for Excel 97, 2000 or XP (whichever is found)
;;; ARGS: none
;;; EXAMPLE: (DSX-Load-TypeLib-Excel)
;;;*************************************************************************

(defun DSX-Load-TypeLib-Excel ( / tlbfile tlbver out)
 (dsx-princ "\n(DSX-Load-TypeLib-Excel)")
 (cond
( (null msxl-xl24HourClock)
 (if (setq tlbfile (DSX-TypeLib-Excel))
 (progn
(setq tlbver (substr (vl-filename-base tlbfile) 6))
(cond
( (= tlbver "9") (princ "\nInitializing Microsoft Excel 2000...") )
( (= tlbver "8") (princ "\nInitializing Microsoft Excel 97...") )
( (= (vl-filename-base tlbfile) "Excel.exe")
 (princ "\nInitializing Microsoft Excel XP...")
)
)
 (vlax-import-type-library
 :tlb-filename tlbfile
 :methods-prefix "msxl-"
 :properties-prefix "msxl-"
 :constants-prefix "msxl-"
 )
 (if msxl-xl24HourClock (setq out T))
 )
 )
)
( T (setq out T) )
 )
out
)

;;;*************************************************************************
;;; MODULE: DSX-Open-Excel-New
;;; DESCRIPTION: Opens a new session of Excel 97, 2000 or XP
;;; ARGS: display-mode ("SHOW" or "HIDE")
;;; EXAMPLE: (setq xlapp (DSX-Open-Excel-New "SHOW"))
;;;*************************************************************************

(defun DSX-Open-Excel-New (dmode / appsession)
 (dsx-princ "\n(DSX-Open-Excel-New)")
(princ "\nCreating new Excel Spreadsheet file...")
(cond
( (setq appsession (vlax-create-object "Excel.Application"))

 (vlax-invoke-method
 (vlax-get-property appsession 'WorkBooks)
 'Add
 )
 (if (= (strcase dmode) "SHOW")
 (vla-put-visible appsession 1)
(vla-put-visible appsession 0)
)
 )
 )
appsession
)

;;;*************************************************************************
;;; MODULE: DSX-Open-Excel-Exist
;;; DESCRIPTION: Gets handle to existing (running) session of Excel 97, 2000, XP
;;; ARGS: xls-filename, display-mode ("SHOW" or "HIDE")
;;; EXAMPLE: (setq xlapp (DSX-Open-Excel-Exist "myfile.xls" "SHOW"))
;;;*************************************************************************

(defun DSX-Open-Excel-Exist (xfile dmode / appsession)
 (dsx-princ "\n(DSX-Open-Excel-Exist)")
(princ "\nOpening Excel Spreadsheet file...")
 (cond
( (setq fn (findfile xfile))
(cond
( (setq appsession (vlax-get-or-create-object "Excel.Application"))
 (vlax-invoke-method
 (vlax-get-property appsession 'WorkBooks)
 'Open fn
 )
 (if (= (strcase dmode) "SHOW")
 (vla-put-visible appsession 1)
(vla-put-visible appsession 0)
)
)
)
 )
( T (alert (strcat "\nCannot locate source file: " xfile)) )
 )
appsession
)

;;;*************************************************************************
;;; MODULE: DSX-Excel-Put-ColumnList
;;; DESCRIPTION: Write each list member to a column (startcol) starting at row (startrow)
;;; ARGS: list, startrow, startcol
;;; EXAMPLE: (DSX-Excel-Put-ColumnList '("A" "B" "C") 1 2) puts members into cells (1,B) (2,B) (3,B) respectively
;;;*************************************************************************

(defun DSX-Excel-Put-ColumnList (lst startrow startcol)
 (dsx-princ "\n(DSX-Excel-Put-ColumnList)")
 (foreach itm lst
(msxl-put-value
 (DSX-Excel-Get-Cell range startrow startcol)
 itm
)
(setq startrow (1+ startrow))
 ); repeat
)

;;;*************************************************************************
;;; MODULE: DSX-Excel-Put-RowList
;;; DESCRIPTION: Write each list member to row (startrow) starting at column (startcol)
;;; ARGS: list, startrow, startcol
;;; EXAMPLE: (DSX-Excel-Put-RowList '("A" "B" "C") 2 1) puts members into cells (1,B) (1,C) (1,D) respectively
;;;*************************************************************************

(defun DSX-Excel-Put-RowList (lst startrow startcol)
 (dsx-princ "\n(DSX-Excel-Put-RowList)")
 (foreach itm lst
(msxl-put-value
 (DSX-Excel-Get-Cell range startrow startcol)
 itm
)
(setq startcol (1+ startcol))
 ); repeat
)

;;;*************************************************************************
;;; MODULE: DSX-Excel-Put-CellColor
;;; DESCRIPTION: Applies fill-color to specified cell
;;; ARGS: row, column, color (integer)
;;; EXAMPLE: (DSX-Excel-Put-CellColor 1 1 14) apply color #14 to cell (1,A)
;;;*************************************************************************

(defun DSX-Excel-Put-CellColor (row col intcol / rng)
 (setq rng (DSX-Excel-Get-Cell (msxl-get-ActiveSheet xlapp) row col))
 (msxl-put-colorindex (msxl-get-interior rng) intcol)
)

;;;*************************************************************************
;;; MODULE: DSX-Excel-Put-RowCellsColor
;;; DESCRIPTION: Applies fill-color to a row of cells
;;; ARGS: startrow, startcol, num-cols, color (integer)
;;; EXAMPLE: (DSX-Excel-Put-RowCellsColor 1 1 5 14) Start at row=1 col=1 repeat for 5 columns using color #14
;;;*************************************************************************

(defun DSX-Excel-Put-RowCellsColor
(startrow startcol cols intcol / next)
 (dsx-princ "\n(DSX-Excel-Put-RowCellsColor)")

 (setq next startcol)
 (repeat cols
(DSX-Excel-Put-CellColor startrow next intcol)
(setq next (1+ next))
 )
)

;;;*************************************************************************
;;; MODULE: DSX-Excel-Put-ColumnCellsColor
;;; DESCRIPTION: Change fill color in a column of cells
;;; ARGS: startrow, startcol, num-rows, color (integer)
;;; EXAMPLE: (DSX-Excel-Put-ColumnCellsColor 1 1 5 14) Start at row=1 col=1 repeat for 5 rows using color #14
;;;*************************************************************************

(defun DSX-Excel-Put-ColumnCellsColor
(startrow startcol rows intcol / next)
 (dsx-princ "\n(DSX-Excel-Put-ColumnCellsColor)")

 (setq next startrow)
 (repeat rows
(DSX-Excel-Put-CellColor next startcol intcol)
(setq next (1+ next))
 )
)

;;;*************************************************************************
;;; MODULE: DSX-Excel-Get-Cell
;;; DESCRIPTION: Get cell object relative to range using (relrow) and (relcol) offsets
;;; ARGS: range-object, relative-row, relative-col
;;; EXAMPLE: (DSX-Excel-Get-Cell rng1 2 2)
;;;*************************************************************************

(defun DSX-Excel-Get-Cell (rng relrow relcol)
 (dsx-princ "\n(DSX-Excel-Get-Cell)")
 (vlax-variant-value
(msxl-get-item (msxl-get-cells rng)
 (vlax-make-variant relrow)
 (vlax-make-variant relcol)
)
 )
)

;;;*************************************************************************
;;; MODULE: DSX-Excel-Get-CellValue
;;; DESCRIPTION: Return value in given cell (row, column) of active session object (xlapp)
;;; ARGS: row(int), column(int)
;;; EXAMPLE: (DSX-Excel-Get-CellValue 1 2)
;;;*************************************************************************

(defun DSX-Excel-Get-CellValue (row col)
 (dsx-princ "\n(DSX-Excel-Get-CellValue)")

 (vlax-variant-value
(msxl-get-value
 (DSX-Excel-Get-Cell
 (msxl-get-ActiveSheet xlapp)
 row col
 )
)
 )
)

;;;*************************************************************************
;;; MODULE: DSX-Excel-Get-RowValues
;;; DESCRIPTION: Returns a list of cell values within a given row
;;; ARGS: row-number(int), startcol, num-cells
;;; EXAMPLE: (DSX-Excel-Get-RowValues 3 1 20) get first 20 values in row 3
;;;*************************************************************************

(defun DSX-Excel-Get-RowValues
(row startcol numcells / next out)
 (dsx-princ "\n(DSX-Excel-Get-RowValues)")

(setq next startcol)
(repeat numcells
(setq out (if out
 (append out (list (DSX-Excel-Get-CellValue row next))); row x col
 (list (DSX-Excel-Get-CellValue row next)); row x col
)
next (1+ next)
)
); repeat
out
)

;;;*************************************************************************
;;; MODULE: DSX-Excel-Get-ColumnValues
;;; DESCRIPTION: Returns a list of cell values within a given column
;;; ARGS: column-number(int), startrow, num-cells
;;; EXAMPLE: (DSX-Excel-Get-ColumnValues 2 1 20) get top-20 entries in column 2 ("B")
;;;*************************************************************************

(defun DSX-Excel-Get-ColumnValues
(col startrow numcells / next out)
 (dsx-princ "\n(DSX-Excel-Get-ColumnValues)")

(setq next startrow)
(repeat numcells
(setq out
(if out
 (append out (list (DSX-Excel-Get-CellValue next col)))
 (list (DSX-Excel-Get-CellValue next col))
)
next (1+ next)
)
); repeat
out
)

;;;*************************************************************************
;;; MODULE: DSX-Excel-GetRangeValues-ByRows
;;; DESCRIPTION: Get range values in row order and return as nested lists
;;; ARGS: startrow, startcol, num-rows, num-cols
;;; EXAMPLE: (DSX-Excel-GetRangeValues-ByRows 1 1 5 10) get range values from 1A to 5J where each sublist is one row
;;;*************************************************************************

(defun DSX-Excel-GetRangeValues-ByRows
(startrow startcol numrows numcols / nextrow rowlst outlst)
 (dsx-princ "\n(DSX-Excel-GetRangeValues-ByRows)")
(setq nextrow startrow)
(repeat numrows
(setq rowlst (DSX-Excel-Get-RowValues nextrow startcol numcols)
outlst (if outlst (append outlst (list rowlst)) (list rowlst))
 nextrow (1+ nextrow)
)
)
outlst
)

;;;*************************************************************************
;;; MODULE: DSX-Excel-GetRangeValues-ByCols
;;; DESCRIPTION: Get range values in column order and return as nested lists
;;; ARGS: startrow, startcol, num-rows, num-cols
;;; EXAMPLE: (DSX-Excel-GetRangeValues-ByCols 1 1 5 10) get range values from 1A to 5J where each sublist is one column
;;;*************************************************************************

(defun DSX-Excel-GetRangeValues-ByCols
 (startrow startcol numrows numcols / nextrow nextcol collst outlst)
 (dsx-princ "\n(DSX-Excel-GetRangeValues-ByCols)")
(setq nextcol startcol)
(repeat numcols
(setq collst (DSX-Excel-Get-ColumnValues nextcol startrow numrows)
outlst (if outlst (append outlst (list collst)) (list collst))
 nextcol (1+ nextcol)
)
)
outlst
)

;;;*************************************************************************
;;; MODULE: DSX-Excel-Get-ActiveWorkSheet
;;; DESCRIPTION: Returns object of active worksheet in active Excel session
;;; ARGS: app (session object)
;;; EXAMPLE: (DSX-Excel-Get-ActiveWorkSheet xlapp)
;;;*************************************************************************

(defun DSX-Excel-Get-ActiveWorkSheet (xlapp)
 (dsx-princ "\n(DSX-Excel-Get-ActiveWorkSheet)")
(msxl-get-ActiveSheet xlapp)
)

;;;*************************************************************************
;;; MODULE: DSX-Excel-RangeAutoFit
;;; DESCRIPTION: Applies Auto-Fit to columns within active range
;;; ARGS: active-sheet (object)
;;; EXAMPLE: (DSX-Excel-RangeAutoFit myxlws)
;;;*************************************************************************

(defun DSX-Excel-RangeAutoFit (active-sheet)
(dsx-princ "\n(DSX-Excel-RangeAutoFit)")
(vlax-invoke-method
(vlax-get-property
(vlax-get-property
(vlax-get-property active-sheet 'UsedRange)
'Cells
)
'Columns
)
'AutoFit
)
)

(defun DSX-Excel-RangeDataFormat (active-sheet)
(dsx-princ "\n(DSX-Excel-RangeDataFormat)")
(vlax-put-property
(vlax-get-property active-sheet "Cells")
'NumberFormat "@"
)
)

;;;*************************************************************************
;;; MODULE: DSX-Excel-Quit
;;; DESCRIPTION: Quit and close Excel session (app)
;;; ARGS: app (session object)
;;; EXAMPLE: (DSX-Excel-Quit xlapp)
;;;*************************************************************************

(defun DSX-Excel-Quit (appsession)
 (dsx-princ "\n(DSX-Excel-Quit)")
(cond
( (not (vlax-object-released-p appsession))
(vlax-invoke-method appsession 'QUIT)
(vlax-release-object appsession)
)
)
)

;;;*************************************************************************
;;; MODULE: DSX-Excel-Kill
;;; DESCRIPTION: Forces any open Excel sessions to be closed
;;; ARGS: none
;;; EXAMPLE: (DSX-Excel-Kill)
;;;*************************************************************************

(defun DSX-Excel-Kill ( / eo)
(while (setq eo (vlax-get-object "Excel.Application"))
(DSX-Excel-Quit eo)
(vlax-release-object eo)
(setq eo nil)
(gc)(gc);; even this doesn't always kill the damn thing!
 )
)

;;;*************************************************************************
;;; MODULE:
;;; DESCRIPTION:
;;; ARGS:
;;; EXAMPLE:
;;;*************************************************************************
;;; Remove trailing 'nil' members from a given list

(defun DSX-TrimList (lst)
(cond
( (/= nil (last lst)) lst)
( T
 (DSX-TrimList (reverse (cdr (reverse lst))))
)
)
)

;;;*************************************************************************
;;; MODULE:
;;; DESCRIPTION:
;;; ARGS:
;;; EXAMPLE:
;;;*************************************************************************
;;; Convert a list of values into a list of string equivalents

(defun DSX-ListStr (lst / mbr out)
(setq out '())
(foreach mbr lst
(cond
( (= mbr nil) (setq out (cons "" out)) )
( (= (type mbr) 'STR)
 (if (member mbr '(" " " " " "))
(setq out (cons "" out))
 (setq out (cons mbr out))
)
)
( (= (type mbr) 'INT) (setq out (cons (itoa mbr) out)) )
( (= (type mbr) 'REAL)(setq out (cons (rtos mbr 2 6) out)))
)
)
(reverse out)
)

;;;*************************************************************************
;;; MODULE: DSX-Excel-Sheets
;;; DESCRIPTION: Returns SHEETS collection from active workbook
;;; ARGS: Excel-application
;;; EXAMPLE: (setq sheets (DSX-Excel-Sheets xlApp))
;;;*************************************************************************

(defun DSX-Excel-Sheets (xlapp)
(setq xlsheets (vlax-get-property xlapp "sheets"))
)

;;;*************************************************************************
;;; MODULE:DSX-Excel-SheetDelete
;;; DESCRIPTION: Delete sheet (tab) from active workbook sheets collection
;;; ARG: sheet-name, sheets-collection
;;; EXAMPLE: (DSX-Excel-SheetDelete "Sheet3" xlSheets)
;;;*************************************************************************

(defun DSX-Excel-SheetDelete (name xlsheets)
(vlax-for sh xlsheets
(if (= (vlax-get-property sh "Name") name)
(vlax-invoke-method sh "Delete")
)
)
)

;;;*************************************************************************
;;; MODULE: DSX-Excel-SheetAdd
;;; DESCRIPTION: Add new sheet (tab) to sheets collection in workbook, returns sheet object
;;; ARG: sheet-name, sheets-collection
;;; EXAMPLE: (setq newsheet (DSX-Excel-SheetAdd "SheetX" xlSheets))
;;;*************************************************************************

(defun DSX-Excel-SheetAdd (name xlsheets)
(setq newsheet (vlax-invoke-method xlsheets "Add"))
(vlax-put-property newsheet "Name" name)
newsheet
)

;;;*************************************************************************
;;; MODULE: DSX-Excel-WorkbookSave
;;; DESCRIPTION: Saves active workbook to specified filename, if file exists, it is overwritten if user accepts prompt
;;; ARG: workbook-object, filename
;;; EXAMPLE: (DSX-Excel-WorkbookSave objWB "myfile.xls")
;;;*************************************************************************

(defun DSX-Excel-WorkbookSave (workbook filename)
 (if (findfile filename)
(vlax-invoke-method awb "Save")
(vlax-invoke-method awb "SaveAs"
filename msxl-xlNormal "" ""
:vlax-False :vlax-False nil
)
)
)

;;;*************************************************************************
;;; MODULE: DSX-Excel-ActiveWorkbook
;;; DESCRIPTION: Returns active workbook object from given Excel application session
;;; ARG: Excel-application
;;; EXAMPLE: (setq objWB (DSX-Excel-ActiveWorkbook xlApp))
;;;*************************************************************************

(defun DSX-Excel-ActiveWorkbook (xlapp)
(vlax-get-property xlapp "ActiveWorkbook")
)

(princ)[/php]

版主加分,很受鼓舞!再贴,
[php];;;*************************************************************************;;;
;;; API-MENUS.LSP ;;;
;;; Visual LISP ActiveX Menu/Toolbar Method Utilities ;;;
;;; Copyright (C)2001 David M. Stein, All Rights Reserved. ;;;
;;;*************************************************************************;;;
;;; Version 2001.00 06/06/01: Initial release ;;;
;;;*************************************************************************;;;

(vl-load-com)
(setq $acad (vlax-get-acad-object)
 $adoc (vla-get-activedocument $acad)
)

;;;*************************************************************************
;;; DESCRIPTION: Returns vla-object to menugroups collection
;;;*************************************************************************

(defun Get-MenuGroups ()
 (vla-get-MenuGroups $acad)
)

;;;*************************************************************************
;;; DESCRIPTION: Returns menugroup object for given menugroup name (string)
;;;*************************************************************************

(defun Get-MenuGroup (mgname)
(if (menugroup mgname)
(vla-item (Get-MenuGroups) mgname)
)
)

;;;*************************************************************************
;;; DESCRIPTION: Adds new menugroup to menugroup collection, returns menugroup object
;;;*************************************************************************

(defun MenuGroup-Add (mgname)
(vla-Add (Get-MenuGroups) mgname)
)

;;;*************************************************************************
;;; DESCRIPTION: Removes named menugroup from menugroups collection
;;;*************************************************************************

(defun MenuGroup-Delete (mgname)
(if (setq mg (Get-MenuGroup mgname))
(vla-Delete mg)
)
)

;;;*************************************************************************
;;; MODULE: MenuGroups-ListAll
;;; DESCRIPTION: Returns list of all menugroup names in current application session
;;; ARGS: none
;;; EXAMPLE: (Get-MenuGroups-ListAll) --> ("ACAD" "ASW2K" "ASW2K-P" ...)
;;;*************************************************************************

(defun MenuGroups-ListAll ( / out)
 (vlax-for each (Get-MenuGroups)
(setq out (cons (vla-get-name each) out))
)
out
)

;;;*************************************************************************
;;; DESCRIPTION: Boolean test for existence of named menugroup, returns menugroup object if found
;;;*************************************************************************

(defun MenuGroup-Exists-p (name)
(Get-MenuGroup name)
)

;;;*************************************************************************
;;; DESCRIPTION: Returns vla-object to popupmenus collection for named menugroup
;;;*************************************************************************

(defun PopupMenus (mgroup / mg)
(if (setq mg (Get-MenuGroup mgroup))
(vla-get-Menus mg)
(princ (strcat "\nMenugroup not found: " mgroup))
)
)

;;;*************************************************************************
;;; DESCRIPTION: Returns list of all popup menu names for given menugroup
;;;*************************************************************************

(defun PopupMenus-ListAll (mgroup / pm out)
 (if (setq pm (ASW-PopupMenus mgroup))
(vlax-for each pm
(setq out (cons (vla-get-Name each) out))
)
)
out
)

;;;*************************************************************************
;;; DESCRIPTION: Returns popupmenu object from specified menugroup object
;;;*************************************************************************

(defun PopupMenu (mgroup popname)
(vla-item (ASW-PopupMenus mgroup) popname)
)

;;;*************************************************************************
;;; MODULE: PopupMenu-ListSubs
;;; DESCRIPTION: Returns list of submenu captions (not labels) for popupmenu object
;;; ARGS: popupmenu-object
;;; EXAMPLE: (ASW-PopupMenu myPopMenu) --> ("File" "Edit" "View" "Draw" "Modify"...)
;;;*************************************************************************

(defun PopupMenu-ListSubs (oPopupMenu / i out)
(setq i 0)
(repeat (vla-get-Count oPopupMenu)
(setq out
(cons
(vla-get-Caption (vla-Item oPopupMenu i))
out
)
i (1+ i)
)
); repeat
(if out (reverse out))
)

; IAcadPopupMenu: An AutoCAD cascading menu
;
; Property values:
; Application (RO) = #<VLA-OBJECT IAcadApplication 00a876f8>
; Count (RO) = 20
; Name = "&ShipWorks"
; NameNoMnemonic (RO) = "ShipWorks"
; OnMenuBar (RO) = -1
; Parent (RO) = #<VLA-OBJECT IAcadPopupMenus 00f648b4>
; ShortcutMenu (RO) = 0
; TagString (RO) = "ID_ASW000"
; Methods supported:
; AddMenuItem (3)
; AddSeparator (1)
; AddSubMenu (2)
; InsertInMenuBar (1)
; Item (1)
; RemoveFromMenuBar ()

; IAcadPopupMenuItem: A single menu item on an AutoCAD pull-down menu
; Property values:
; Application (RO) = #<VLA-OBJECT IAcadApplication 00a876f8>
; Caption (RO) = "File..."
; Check = 0
; Enable = -1
; EndSubMenuLevel = 0
; HelpString = ""
; Index (RO) = 0
; Label = "File..."
; Macro = ""
; Parent (RO) = #<VLA-OBJECT IAcadPopupMenu 00ecc9f8>
; SubMenu (RO) = #<VLA-OBJECT IAcadPopupMenu 00ecc998>
; TagString = ""
; Type (RO) = 2
; Methods supported:
; Delete ()

; IAcadPopupMenuItem: A single FLY-OUT menu item on an AutoCAD pull-down menu
; Property values:
; Application (RO) = #<VLA-OBJECT IAcadApplication 00a876f8>
; Caption (RO) = "Fast-Plot..."
; Check = 0
; Enable = -1
; EndSubMenuLevel = 0
; HelpString = "Execute one-click plot to selected device: FPLOT"
; Index (RO) = 5
; Label = "Fast-Plot..."
; Macro = "\003\003\020FPLOT "
; Parent (RO) = #<VLA-OBJECT IAcadPopupMenu 00ecc9f8>
; SubMenu (RO) = Exception occurred
; TagString = "ID_Print1"
; Type (RO) = 0
; Methods supported:
; Delete ()

;;;*************************************************************************
;;; MODULE: PopupMenu-SubMenu
;;; DESCRIPTION: Returns submenu object for given submenu within a PopupMenu object
;;; ARGS: popupmenu-object, submenu-name
;;; EXAMPLE: (ASW-PopupMenu-SubMenu myPopMenu "Flyout1...")
;;;*************************************************************************

(defun PopupMenu-SubMenu
(oPopupMenu subname / tries out looked found)

(setq tries (vla-get-Count oPopupMenu) looked 0)

(while
(and
(< looked tries)
(not found)
)
(if (= subname (vla-get-Label (vla-item oPopupMenu looked)))
(progn
(setq found T)
(vla-get-SubMenu (vla-item oPopupMenu looked))
)
(setq looked (1+ looked))
)
)
)

;;;*************************************************************************
;;; MODULE: Toolbars
;;; DESCRIPTION: Returns toolbars collection object for specified menugroup
;;; ARGS: menugroup-name (string)
;;; EXAMPLE: (ASW-Toolbars "ASW2K") --> [vla-object]
;;;*************************************************************************

(defun Toolbars (mgroup / mg)
(if (setq mg (ASW-MenuGroup mgroup))
(vla-get-Toolbars mg)
(princ (strcat "\nMenugroup not found: " mgroup))
)
)

;;;*************************************************************************
;;; MODULE: Toolbars-ListAll
;;; DESCRIPTION: Returns list of toolbar names for specified menugroup
;;; ARGS: menugroup-name (string)
;;; EXAMPLE: (ASW-Toolbars-ListAll "ASW2K") --> ("Toolbar1" "Toolbar2" ...)
;;;*************************************************************************

(defun Toolbars-ListAll (mgroup / tb out)
 (if (setq tb (ASW-Toolbars mgroup))
(vlax-for each tb
(setq out (cons (vla-get-name each) out))
)
)
out
)

;;;*************************************************************************
;;; MODULE: Toolbar-Exists-p
;;; DESCRIPTION: Returns T if toolbar exists within name menugroup toolbar collection
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar-Exists-p "ASW2K" "ASW: Sheets") returns T
;;;*************************************************************************

(defun Toolbar-Exists-p (mgroup tbname)
(and
(ASW-MenuGroup mgroup)
(ASW-Toolbar mgroup tbname)
)
)

;;;*************************************************************************
;;; MODULE: Toolbar
;;; DESCRIPTION: Returns vla-object to a named toolbar within a named menugroup
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar myMenuGroup "ASW: Sheets") --> [vla-object]
;;;*************************************************************************

(defun Toolbar (mgroup tbname / loc)
 (vla-item (ASW-Toolbars mgroup) tbname)
)

; Property values:
; Application (RO) = #<VLA-OBJECT IAcadApplication 00a876f8>
; Count (RO) = 0
; DockStatus (RO) = 4
; FloatingRows = 1
; Height (RO) = 52
; HelpString = ""
; LargeButtons (RO) = 0
; left = 212
; Name = "Foo"
; Parent (RO) = #<VLA-OBJECT IAcadToolbars 00f6b924>
; TagString (RO) = "ID_Foo_0"
; top = 186
; Visible = -1
; Width (RO) = 27
; Methods supported:
; AddSeparator (1)
; AddToolbarButton (5)
; Delete ()
; Dock (1)
; Float (3)
; Item (1)

;;;*************************************************************************
;;; MODULE: Toolbar-Add
;;; DESCRIPTION: Adds toolbar to given menugroup, returns toolbar object
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar-Add "ASW2K" "MyToolbar1")
;;;*************************************************************************

(defun Toolbar-Add (mgroup name)
(vla-Add (ASW-Toolbars mgroup) name)
)

;;;*************************************************************************
;;; MODULE: Toolbar-Delete
;;; DESCRIPTION: Removes named toolbar from menugroup object collection
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar-Delete "ASW2K" "MyToolbar1")
;;;*************************************************************************

(defun Toolbar-Delete (mgroup tbname / tb)
(if (setq tb (ASW-Toolbar mgroup tbname))
(vla-Delete tb)
)
)

;;;*************************************************************************
;;; MODULE: Toolbar-ButtonNames
;;; DESCRIPTION: Returns list of button names for a given toolbar object
;;; ARGS: toolbar (vla-object)
;;; EXAMPLE: (ASW-Toolbar-ButtonNames myToolbar) --> ("Button1" "Button2" ...)
;;;*************************************************************************

(defun Toolbar-ButtonNames (tbobject / i out)
(setq i 0)
(repeat (vla-get-count tbobject)
(setq out (cons (vla-get-Name (vla-Item tbobject i)) out))
(setq i (1+ i))
)
out
)

;;;*************************************************************************
;;; MODULE: Toolbar-Button
;;; DESCRIPTION: Returns button object from given toolbar using button name
;;; ARGS: toolbar (vla-object), button-name (string)
;;; EXAMPLE: (ASW-Toolbar-Button myToolbar "Button1")
;;;*************************************************************************

(defun Toolbar-Button (tbobject btname / out)
(vla-Item tbobject btname)
)

; IAcadToolbarItem: A single button item on an AutoCAD toolbar
; Property values:
; Application (RO) = #<VLA-OBJECT IAcadApplication 00a876f8>
; Flyout (RO) = AutoCAD: The toolbar item is not a flyout button
; HelpString = "Insert a plain or reducing coupling: CPL"
; Index (RO) = 0
; Macro = "\003\003\020(ASWLF (list '(c:pff07 \"pff07\")))\npff07 "
; Name = "Coupling"
; Parent (RO) = #<VLA-OBJECT IAcadToolbar 00f676bc>
; TagString = "ID_ASWP023"
; Type (RO) = 0
; Methods supported:
; AttachToolbarToFlyout (2)
; Delete ()
; GetBitmaps (2)
; SetBitmaps (2)

;;;*************************************************************************
;;; MODULE: Toolbar-ButtonAdd
;;; DESCRIPTION: Add new button to given toolbar object, returns button object
;;; ARGS: toolbar-object, button-name, macro-string, bitmap-name, tagstring, helpstring
;;; EXAMPLE: (ASW-Toolbar-ButtonAdd myToolbar "Button1" "\003\003\020\nLine" "ICON_16_LINE" "Button001" "Draws a line: LINE")
;;;*************************************************************************

(defun Toolbar-ButtonAdd
(tbobject name macro bitmap1 tagstring helpstring / newButton index)
(setq index (vla-get-Count tbobject))
(cond
( (setq newButton (vla-AddToolbarButton tbobject
(vlax-make-variant index vlax-vbInteger)
name
helpstring
macro
)
)
 (vla-put-TagString newButton tagstring)
 (vla-SetBitMaps newButton bitmap1 bitmap1)
 newButton
)
)
)

(defun C:ADDTB ( / tb buttons)
(if
(or
(setq tb (ASW-Toolbar G$APP "Foo"))
(setq tb (ASW-Toolbar-Add G$APP "Foo"))
)
(progn
(setq buttons (vla-get-Count tb))
(ASW-Toolbar-ButtonAdd tb (strcat "Button" (itoa buttons))
"\003\003\020\nLINE"
"ICON_16_LINE"
(strcat "FooButton" (itoa buttons))
"Draws a line: LINE"
)
)
)
(princ)
)

(defun C:DELTB ( / tb buttons)
(if (setq tb (ASW-Toolbar G$APP "Foo"))
(progn
(vla-Delete tb)
(vlax-release-object tb)
)
)
(princ)
)

;;;*************************************************************************
;;; MODULE: Toolbar-ButtonDelete
;;; DESCRIPTION: Removes named button from given toolbar object
;;; ARGS: toolbar-object, button-name
;;; EXAMPLE: (ASW-Toolbar-ButtonDelete myToolbar "Button1")
;;;*************************************************************************

(defun Toolbar-ButtonDelete (tbobject name / btn)
(if (setq btn (ASW-Toolbar-Button tbobject name))
(progn
(vla-Delete btn)
(vlax-release-object btn)
)
)
)

;;;*************************************************************************
;;; MODULE: Toolbar-Show
;;; DESCRIPTION: Un-Hides a named toolbar
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar-Show "ASW2K" "ASW: Sheets")
;;;*************************************************************************

(defun Toolbar-Show (mgroup tbname / tb)
 (if (setq tb (ASW-Toolbar mgroup tbname))
 (if (= (vla-get-Visible tb) :vlax-False)
(progn
(vla-put-Visible tb :vlax-True)
T
)
)
)
)

;;;*************************************************************************
;;; MODULE: Toolbar-Hide
;;; DESCRIPTION: Hides a named toolbar
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar-Hide "ASW2K" "ASW: Sheets")
;;;*************************************************************************

(defun Toolbar-Hide (mgroup tbname / tb)
 (if (setq tb (ASW-Toolbar mgroup tbname))
 (if (= (vla-get-Visible tb) :vlax-True)
(progn
 (vla-put-Visible tb :vlax-False)
T
)
)
)
)

;;;*************************************************************************
;;; MODULE: Toolbar-Dock
;;; DESCRIPTION: Dock named toolbar in one of four locations
;;; ARGS: menugroup-name, toolbar-name, location (acToolbarDockTop, acToolbarDockBottom, acToolbarDockLeft, acToolbarDockRight)
;;; EXAMPLE: (ASW-Toolbar-Dock "ASW2K" "Sheets" 2) --> docks on left side of window
;;;*************************************************************************;;;

(defun Toolbar-Dock (mgroup tbname dock / tb)
 (if (setq tb (ASW-Toolbar mgroup tbname))
 (if (= (vla-get-Visible tb) :vlax-True)
(if (member dock '(0 1 2 3))
(progn
(vla-Dock tb dock)
1
)
-2 ;; invalid parameter value
)
-1 ;; toolbar not visible
 )
0 ;; toolbar not found
)
)

;;;*************************************************************************
;;; MODULE: Toolbar-DockTop
;;; DESCRIPTION: Dock named toolbar at top of screen
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar-DockTop "ASW2K" "ASW: PowerPlot")
;;;*************************************************************************

(defun Toolbar-DockTop (mgroup tbname)
(if (setq tbobject (ASW-Toolbar mgroup tbname))
(vla-Dock tbobject acToolbarDockTop)
(princ (strcat "\nToolbar (" tbname ") not found."))
)
)

;;;*************************************************************************
;;; MODULE: Toolbar-DockBottom
;;; DESCRIPTION: Dock named toolbar at bottom of screen
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar-DockBottom "ASW2K" "ASW: PowerPlot")
;;;*************************************************************************

(defun Toolbar-DockBottom (mgroup tbname)
(if (setq tbobject (ASW-Toolbar mgroup tbname))
(vla-Dock tbobject acToolbarDockBottom)
(princ (strcat "\nToolbar (" tbname ") not found."))
)
)

;;;*************************************************************************
;;; MODULE: Toolbar-DockLeft
;;; DESCRIPTION: Dock named toolbar at left of screen
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar-DockLeft "ASW2K" "ASW: PowerPlot")
;;;*************************************************************************

(defun Toolbar-DockLeft (mgroup tbname)
(if (setq tbobject (ASW-Toolbar mgroup tbname))
(vla-Dock tbobject acToolbarDockLeft)
(princ (strcat "\nToolbar (" tbname ") not found."))
)
)

;;;*************************************************************************
;;; MODULE: Toolbar-DockRight
;;; DESCRIPTION: Dock named toolbar at right of screen
;;; ARGS: menugroup-name, toolbar-name
;;; EXAMPLE: (ASW-Toolbar-DockRight "ASW2K" "ASW: PowerPlot")
;;;*************************************************************************

(defun Toolbar-DockRight (mgroup tbname)
(if (setq tbobject (ASW-Toolbar mgroup tbname))
(vla-Dock tbobject acToolbarDockRight)
(princ (strcat "\nToolbar (" tbname ") not found."))
)
)

;;;*************************************************************************
;;; MODULE: Toolbar-Float
;;; DESCRIPTION: Position named toolbar at specified location
;;; ARGS: menugroup-name, toolbar-name, top-int, left-int, rows-int
;;; EXAMPLE: (ASW-Toolbar-Float "ASW2K" "Sheets" 200 300 1)
;;;*************************************************************************

(defun Toolbar-Float (mgroup tbname top left rows)
 (if (setq tb (ASW-Toolbar mgroup tbname))
(if (= (vla-get-Visible tb) :vlax-True)
(progn
(vla-Float tb top left rows)
1
)
-1 ;; toolbar not visible
)
0 ;; toolbar not found
)
)

;;;*************************************************************************\
;;; MODULE: Menu-Locate
;;; DESCRIPTION: Returns full path+filename for named menu file
;;; ARGS: menu-filename (without extension)
;;; EXAMPLE: (ASW-Menu-Locate "asw2k")
;;;************************************************************************;;;

(defun MENU-LOCATE (mnfn)
(DPR "\n(ASW-MENU-LOAD)")

(cond
;( (findfile (strcat mnfn ".mnc")) )
;( (findfile (strcat mnfn ".mns")) )
( (findfile (strcat mnfn ".mnu")) )
( (findfile (strcat G$MENU "\\" mnfn ".mnu")) )
( (findfile (strcat G$ASL "\\" mnfn ".mnu")) )
( (findfile (strcat G$SYS "\\Menu\\" mnfn ".mnu")) )
( T nil )
)
)

;;;********************************************************************
;;; Force menu reload/recompile
;;;********************************************************************

(if (null C:UPDATE)
(defun C:UPDATE ()
(load "update.vlx")
(C:UPDATE)
(princ)
)
)

;;;*************************************************************************
;;; MODULE: Menu-ReLoadAll
;;; DESCRIPTION: Reloads and repositions (merges) all ShipWorks menu stubs
;;; ARGS: none
;;; EXAMPLE: (ASW-Menu-ReLoadAll)
;;;********************************************************************

(defun MENU-RELOADALL ( / cmdstr appkey local_copy client-menu)
(DPR "\n(ASW-MENU-RELOADALL)")
(setq client-menu (vl-filename-base G$PRO))
(setq cmdstr (strcat "COPY " G$MENU "\\ASW2K.MNU " G$DAT "\\ASW2K.MNU"))
(vl-cmdf "SHELL" cmdstr)
(setq cmdstr (strcat "COPY " G$ASL "\\" G$APP ".MNU " G$DAT "\\" G$APP ".MNU"))
(vl-cmdf "SHELL" cmdstr)
(cond
( (findfile (strcat G$MENU "\\" client-menu ".MNU"))
 (setq cmdstr (strcat "COPY " G$MENU "\\" client-menu ".MNU " G$DAT "\\" client-menu ".MNU"))
 (vl-cmdf "SHELL" cmdstr)
)
)

(princ "\nMenus downloaded to client folder.")
(cond
( (menugroup "ASW2K")
 (DPR "\nRemoving base services menu stub...")
 (vl-cmdf "MENUUNLOAD" "ASW2K")
 )
)
(cond
( (setq local_copy (findfile (strcat G$DAT "\\asw2k.mnu")))
 (vl-cmdf "MENULOAD" local_copy)
(if (menugroup "ASW2K")
(menucmd "P4=+ASW2K.POP1")
(princ "\nFailed (1)!")
)
 )
 ( T (princ "\nFailed (2)!") )
)

(cond
( (menugroup G$APP)
 (foreach appkey '("ASW2K-S" "ASW2K-E" "ASW2K-P" "ASW2K-V")
(if (menugroup appkey)
(vl-cmdf "MENUUNLOAD" appkey)
)
)
)
)
(cond
( (setq local_copy (findfile (strcat G$DAT "\\" G$APP ".mnu")))
 (vl-cmdf "MENULOAD" local_copy)
 (if (menugroup G$APP)
 (menucmd (strcat "P5=+" G$APP ".POP1"))
(princ "\nFailed (3)!")
)
)
( T
 (princ "\nFailed (4)!")
)
)
(cond
( (menugroup client-menu)
 (DPR "\nRemoving client-specific menu stub...")
 (vl-cmdf "MENUUNLOAD" client-menu)
)
)
(cond
( (setq local_copy (findfile (strcat G$DAT "\\" client-menu ".mnu")))
 (vl-cmdf "MENULOAD" local_copy)
 (if (menugroup client-menu)
 (menucmd (strcat "P6=+" client-menu ".POP1"))
(princ "\nFailed (5)!")
)
)
( T
 (princ "\nFailed (6)!")
)
)
)

;;;*************************************************************************
;;; MODULE: MenuMerge
;;; DESCRIPTION: Loads and positions all ShipWorks menu stubs
;;; ARGS: none
;;; EXAMPLE: (ASW-MenuMerge)
;;;********************************************************************

(defun MenuMerge
( / local_copy remote_copy client-menu)
 (DPR "\n(ASW-MenuMerge)")
(cond
( (menugroup "ASW2K")
 (vl-cmdf "MENUUNLOAD" "ASW2K")
 (if (setq local_copy (findfile (strcat G$DAT "\\asw2k.mnu")))
(vl-File-Delete local_copy)
)
 (vl-File-Copy (strcat G$MENU "\\asw2k.mnu") (strcat G$DAT "\\asw2k.mnu"))
 (if (setq local_copy (findfile (strcat G$DAT "\\asw2k.mnu")))
 (progn
(vl-cmdf "MENULOAD" local_copy)
(menucmd "P4=+ASW2K.POP1")
)
(princ "\nFailed to reload new base menu update.")
)
)
;; Cond-2: Local MNU exists, load it
( (and
(not (menugroup "ASW2K"))
(setq local_copy (findfile (strcat G$DAT "\\asw2k.mnu")))
)
 (DPR "\nReloading from local directory...")
 (vl-cmdf "MENULOAD" local_copy)
 (if (menugroup "ASW2K")
(menucmd "P4=+ASW2K.POP1")
(princ "\nFailed to load local copy of ShipWorks Base menu.")
)
)
;; Cond-3: Remote MNU exists, copy to local, load local copy
( (and
(not (menugroup "ASW2K"))
(setq remote_copy (findfile (strcat G$MENU "\\asw2k.mnu")))
(vl-File-Copy remote_copy (strcat G$DAT "\\asw2k.mnu"))
(setq local_copy (findfile (strcat G$DAT "\\asw2k.mnu")))
)
 ;(vl-cmdf "delay" 400)
 (DPR "\nReloading from new download copy...")
(vl-cmdf "MENULOAD" local_copy)
 (if (menugroup "ASW2K")
(menucmd "P4=+ASW2K.POP1")
(princ "\nFailed to load remote copy of ShipWorks Base menu.")
)
)
;; Cond-4: Horrible failure, cry in shame
( T (princ "\nSystem failure: Unable to download server menu update."))
); cond
(setq remote_copy nil local_copy nil)
(cond
( (menugroup G$APP)
 (vl-cmdf "MENUUNLOAD" G$APP)
 (if (setq local_copy (findfile (strcat G$DAT "\\" G$APP ".mnu")))
(vl-File-Delete local_copy)
)
 (vl-File-Copy (strcat G$ASL "\\" G$APP ".mnu") (strcat G$DAT "\\" G$APP ".mnu"))
 (if (setq local_copy (findfile (strcat G$DAT "\\" G$APP ".mnu")))
 (progn
(vl-cmdf "MENULOAD" local_copy)
(menucmd (strcat "P5=+" G$APP ".POP1"))
)
(princ "\nFailed to reload new extended services menu update.")
)
);; Cond-2: Local MNU exists, load it
( (and
(not (menugroup G$APP))
(setq local_copy (findfile (strcat G$DAT "\\" G$DAT ".mnu")))
)
 (DPR "\nReloading from local directory...")
(vl-cmdf "MENULOAD" local_copy)
(if (menugroup G$APP)
(menucmd (strcat "P5=+" G$APP ".POP1"))
(princ "\nFailed to load local copy of extended services menu.")
)
)
;; Cond-3: Remote MNU exists, copy to local, load local copy
( (and
(not (menugroup G$APP))
(setq remote_copy (findfile (strcat G$ASL "\\" G$APP ".mnu")))
(vl-File-Copy remote_copy (strcat G$DAT "\\" G$APP ".mnu"))
(setq local_copy (findfile (strcat G$DAT "\\" G$APP ".mnu")))
)
 ;(vl-cmdf "delay" 400)
 (DPR "\nReloading from downloaded copy...")
 (vl-cmdf "MENULOAD" local_copy)
 (if (menugroup G$APP)
 (menucmd (strcat "P5=+" G$APP ".POP1"))
(princ "\nFailed to load remote copy of extended services menu.")
)
)
;; Cond-4: Oh my God, two failures? What a shame
( T (princ "\nSystem Failure: Unable to download server menu update.") )
); cond
(DPR "\nChecking for project-based client menus...")
(setq client-menu (vl-filename-base G$PRO))
(cond
( (menugroup client-menu)
 (vl-cmdf "MENUUNLOAD" client-menu)
 (if (setq local_copy (findfile (strcat G$DAT "\\" client-menu ".mnu")))
(vl-File-Delete local_copy)
)
 (vl-File-Copy (strcat G$MENU "\\" G$APP ".mnu") (strcat G$DAT "\\" client-menu ".mnu"))
 (if (setq local_copy (findfile (strcat G$DAT "\\" client-menu ".mnu")))
 (progn
(vl-cmdf "MENULOAD" local_copy)
(menucmd (strcat "P6=+" client-menu ".POP1"))
)
(princ "\nFailed to reload new client-specific menu update.")
)
);; Cond-2: Local MNU exists, load it
( (and
(not (menugroup client-menu))
(setq local_copy (findfile (strcat G$DAT "\\" client-menu ".mnu")))
)
 (DPR "\nReloading from local directory...")
(vl-cmdf "MENULOAD" local_copy)
(if (menugroup client-menu)
(menucmd (strcat "P6=+" client-menu ".POP1"))
(princ "\nFailed to load local copy of client-specific menu.")
)
)
;; Cond-3: Remote MNU exists, copy to local, load local copy
( (and
(not (menugroup client-menu))
(setq remote_copy (findfile (strcat G$MENU "\\" client-menu ".mnu")))
(vl-File-Copy remote_copy (strcat G$DAT "\\" client-menu ".mnu"))
(setq local_copy (findfile (strcat G$DAT "\\" client-menu ".mnu")))
)
 ;(vl-cmdf "delay" 400)
 (DPR "\nReloading from downloaded copy...")
 (vl-cmdf "MENULOAD" local_copy)
 (if (menugroup client-menu)
 (menucmd (strcat "P6=+" client-menu ".POP1"))
(princ "\nFailed to load remote copy of client-specific menu.")
)
)
;; Cond-4: Oh my God, two failures? What a shame
( T (princ "\nSystem Failure: Unable to download server menu update.") )
)
(DPR "\nSearching for Express Tools stub menu to load...")

 (cond
( (and
 (not (menugroup "EXPRESS"))
(or
 (setq expmn (findfile "acetmain.mnu"))
(setq expmn (findfile "express.mnu"))
)
)
 (princ "\nLoading AutoCAD Express Tools menus...")
 (vl-cmdf "_.MENULOAD" expmn)
 (if (menugroup "EXPRESS")
 (menucmd "P9=+EXPRESS.POP1")
 (alert "Failed to load Express Tools menus...")
 )
)
 )
); defun

;;;*************************************************************************
;;; MODULE: Menu-DeleteFiles
;;; DESCRIPTION: Deletes all four extension-type files for named menu file
;;; ARGS: basename (without extension), pathname
;;; EXAMPLE: (ASW-Menu-DeleteFiles "mymenu" "c:\\mystuff")
;;;*************************************************************************

(defun MENU-DeleteFiles
(menubase pathname / mnuext mnu)
(DPR "\n(ASW-MENU-DeleteFiles)")
(foreach mnuext '(".mnu" ".mns" ".mnc" ".mnr")
(if (setq mnu (findfile (strcat pathname "\\" menubase mnuext)))
(progn
(DPR (strcat "\nDeleting menu file: " mnu))
(vl-File-Delete mnu)
)
)
)
)

;;;*************************************************************************
;;; MODULE: Menu-CompareDates
;;; DESCRIPTION: Compare file dates, returns T if file1 is same or newer than file2
;;; ARGS: filename1, filename2
;;; EXAMPLE: (ASW-Menu-CompareDates localMenu serverMenu) returns T (filename1 is same or newer than filename2)
;;;*************************************************************************

(defun Menu-CompareDates (f1 f2 / st1 st2)
(if
 (and
(setq f1 (findfile f1))
(setq f2 (findfile f2))
(setq st1 (vl-file-systime f1)); (2001 2 2 13 10 53 12 855)
(setq st2 (vl-file-systime f2)); (2001 2 2 13 10 53 12 855)
)
(if (> (nth 0 st1) (nth 0 st2));; newer year?
T
(if (= (nth 0 st1) (nth 0 st2));; same year?
(if (> (nth 1 st1) (nth 1 st2));; newer month?
T
(if (> (nth 3 st1) (nth 3 st2));; newer day of month?
T
(if (= (nth 3 st1) (nth 3 st2));; same day of month?
(if (> (nth 4 st1) (nth 4 st2));; newer hour of day?
T
(if (= (nth 4 st1) (nth 4 st2));; same hour of day?
(if (>= (nth 5 st1) (nth 5 st1));; newer minutes of same hour?
T
)
)
)
)
)
)
)
)
)
)

;;;*************************************************************************
;;; MODULE: Menu-CheckDates
;;; DESCRIPTION: Compare menu filenames dates between two folders
;;; ARGS: none
;;; EXAMPLE:
;;;*************************************************************************

(defun Menu-CheckDates
(forceload / choice fail)
(DPR "\n(ASW-Menu-CheckDates)")
(cond
( (not
(ASW-Menu-CompareDates
(strcat G$DAT "\\asw2k.mnu")
(strcat G$MENU "\\asw2k.mnu")
)
)
 (setq fail 1)
)
)
(cond
( (not
(ASW-Menu-CompareDates
(strcat G$DAT "\\" G$APP ".mnu")
(strcat G$ASL "\\" G$APP ".mnu")
)
)
 (if fail
(setq fail 2)
(setq fail -1)
)
)
)
(cond
( (= fail 1) (DPR "\nBase menu failed comparison.") )
( (= fail 2) (DPR "\nBoth menus failed comparison.") )
( (= fail -1)(DPR "\nExtended menu failed comparison.") )
( T (DPR "\nMenus are up to date.") )
)
(cond
( (and fail (not forceload))
(setq choice
(DOS_MsgBox
(strcat
"One of your ShipWorks menus is out of date."
"\nYou can update it now by picking the Yes"
"\nbutton, or pick No to defer until later.\n"
"\nIf you defer now, you will be reminded each"
"\ntime you open a drawing until you update."
)
"ShipWorks Menu Update"
4 3
)
)
 (if (= 6 choice)
(ASW-MENU-RELOADALL)
(princ "\nShipWorks menu update notice deferred.")
)
)
)
)

;;;*************************************************************************
;;; MODULE: Toolbars-HideAll
;;; DESCRIPTION: Hide all toolbars related to specified menugroup
;;; ARGS: menugroup-name
;;; EXAMPLE: (ASW-Toolbars-HideAll "ASW2K")
;;;*************************************************************************

(defun Toolbars-HideAll (mgroup / tbars)
(cond
( (setq tbars (asw-toolbars-listall mgroup))
 (foreach tbar tbars
(ASW-Toolbar-Hide mgroup tbar)
)
)
)
)

;;;*************************************************************************
;;; MODULE: Toolbars-ShowAll
;;; DESCRIPTION: Show all toolbars related to specified menugroup
;;; ARGS: menugroup-name
;;; EXAMPLE: (ASW-Toolbars-ShowAll "ASW2K")
;;;*************************************************************************

(defun Toolbars-ShowAll (mgroup / tbars)
(cond
( (setq tbars (asw-toolbars-listall mgroup))
 (foreach tbar tbars
(ASW-Toolbar-Show mgroup tbar)
)
)
)
)

;;;*************************************************************************
;;; MODULE: Toolbars-Hidden
;;; DESCRIPTION: Returns list of toolbars that are hidden for a specified menugroup
;;; ARGS: menugroup-name
;;; EXAMPLE: (ASW-Toolbars-Hidden "ASW2K") returns ("toolbar1" "toolbar2"...)
;;;*************************************************************************

(defun Toolbars-Hidden (mgroup / tbars each tbar)
(cond
( (setq tbars (ASW-Toolbars-ListAll mgroup))
 (foreach each tbars
(setq tbar (ASW-Toolbar mgroup each))
(if (= :vlax-True (vla-get-Visible tbar))
(setq out (cons (vla-get-name tbar) out))
)
)
)
)
)

;;;*************************************************************************
;;; MODULE: C:TBOFF
;;; DESCRIPTION: Turns off ShipWorks toolbars
;;; ARGS: none
;;; EXAMPLE:
;;;*************************************************************************

(defun C:TBOFF ( / hbars1 hbars2)
(setq G$TBOFF1 (KWORD '("A""V") "Hide All toolbars or Visible toolbars only..." G$TBOFF1 T))
(cond
( (= G$TBOFF1 "V")
 (setq G$TBOFF2 (ASW-Toolbars-Hidden "ASW2K"))
 (setq G$TBOFF3 (ASW-Toolbars-Hidden G$APP))
)
)
(ASW-Toolbars-HideAll "ASW2K")
(ASW-Toolbars-HideAll G$APP)
(princ)
)

;;;*************************************************************************
;;; MODULE: C:TBON
;;; DESCRIPTION: Turns on ShipWorks toolbars
;;; ARGS: none
;;; EXAMPLE:
;;;*************************************************************************

(defun C:TBON ( / opt)
(cond
( (and G$TBOFF1 (= G$TBOFF1 "V") (or G$TBOFF2 G$TBOFF3))
 (setq opt (KWORD '("A""H") "Display All toolbars or only those Hidden before..." opt T))
 (cond
( (= opt "A")
(ASW-Toolbars-ShowAll "ASW2K")
(ASW-Toolbars-ShowAll G$APP)
)
( T
 (if G$TBOFF2
 (vlax-for each (ASW-Toolbars "ASW2K")
(setq tbname (vla-get-name each))
(if (member tbname G$TBOFF2)
(ASW-Toolbar-Show "ASW2K" tbname)
)
)
)
 (if G$TBOFF3
 (vlax-for each (ASW-Toolbars G$APP)
(setq tbname (vla-get-name each))
(if (member tbname G$TBOFF3)
(ASW-Toolbar-Show G$APP tbname)
)
)
)
)
); cond
)
( T
(ASW-Toolbars-ShowAll "ASW2K")
(ASW-Toolbars-ShowAll G$APP)
)
)
(princ)
)

;;;*************************************************************************
;;; MODULE: Menu-SaveAll
;;; DESCRIPTION: Saves all ShipWorks menu settings to MNS or MNC files
;;; ARGS: menu-type ("mns" or "mnc") not case sensitive, nil = "mns"
;;; EXAMPLE: (ASW-Menu-SaveAll "mnc") returns nil
;;;*************************************************************************

(defun MENU-SAVEALL (mtype)
(DPR "\n(ASW-MENU-SAVEALL)")
(vlax-for each (Get-MenuGroups)
(if (wcmatch (strcase (vla-get-name each)) "ASW2K*")
(if (= (strcase mtype) "MNC")
(vla-save each acMenuFileCompiled)
(vla-save each acMenuFileSource)
)
)
)
)

;;;*************************************************************************
;;; MODULE: MenuUpdate-LoadClientMenus
;;; DESCRIPTION: Loads client menu files as menugroups for ShipWorks session
;;; ARGS: none
;;; EXAMPLE:
;;;*************************************************************************

(defun MenuUpdate-LoadClientMenus
( / mg svclist svcmnu)
(ASW-PRINC "\n(ASW-MenuUpdate-LoadClientMenus)")
(princ "\nLoading ShipWorks menugroups from client folder...")
(setq svclist
'("ASW2K-E" "&Electrical" "ASW2K-P" "&Piping" "ASW2K-S" "&Structure" "ASW2K-V" "HVAC")
svcmnu (cadr (member G$APP svclist))
)
(cond
( (not (menugroup "asw2k"))
 (if (setq mg (asw-menu-load "asw2k" (strcat G$DAT "\\asw2k.mnu")))
(progn
(if (ASW-PopMenu-Insert "asw2k" "&ShipWorks" 4)
(princ "\nBase menubar loaded from file.")
)
(vlax-release-object mg)
)
)
)
( T
 (if (not (ASW-PopMenu-MenuBar-p "&ShipWorks"))
(if (ASW-PopMenu-Insert "asw2k" "&ShipWorks" 4)
(princ "\nBase menubar loaded.")
(princ "\nFailed to get base popmenu from menugroup collection.")
)
)
)
)
(if
(and
(/= G$APP "ASW2K-E")
(menugroup "ASW2K-E")
)
(ASW-Menu-UnLoad "ASW2K-E")
)
(if
(and
(/= G$APP "ASW2K-P")
(menugroup "ASW2K-P")
)
(ASW-Menu-Unload "ASW2K-P")
)
(if
(and
(/= G$APP "ASW2K-S")
(menugroup "ASW2K-S")
)
(ASW-Menu-Unload "ASW2K-S")
)
(if
(and
(/= G$APP "ASW2K-V")
(menugroup "ASW2K-V")
)
(ASW-Menu-Unload "ASW2K-V")
)
(cond
( (not (menugroup G$APP))
 (if (setq mg (asw-menu-load G$APP (strcat G$DAT "\\" G$APP ".mnu")))
(progn
(if (ASW-PopMenu-Insert G$APP svcmnu 5)
(princ (strcat "\nService menubar loaded from file: " G$APP))
)
(vlax-release-object mg)
)
)
)
( T
 (if (not (ASW-PopMenu-MenuBar-p svcmnu))
(if (ASW-PopMenu-Insert G$APP svcmnu 5)
(princ "\nServer menubar loaded.")
(princ "\nFailed to get service popmenu from menugroup collection.")
)
)
)
)
)

;;;*************************************************************************
;;; MODULE: MenuUpdate-DeleteClientFiles
;;; DESCRIPTION: Deletes client-side menu files for ShipWorks
;;; ARGS: none
;;; EXAMPLE:
;;;*************************************************************************

(defun MenuUpdate-DeleteClientFiles
( / mfile)
(ASW-PRINC "\n(ASW-MenuUpdate-DeleteClientFiles)")
(foreach mext '(".mnu" ".mns" ".mnc" ".mnr")
(if (setq mfile (findfile (strcat G$DAT "\\asw2k" mext)))
(if (vl-file-delete mfile)
(princ);(princ (strcat "\nDeleted menu file: " mfile))
(princ (strcat "\nFailed to delete menu file: " mfile))
)
)
)
(foreach mext '(".mnu" ".mns" ".mnc" ".mnr")
(if (setq mfile (findfile (strcat G$DAT "\\" G$APP mext)))
(if (vl-file-delete mfile)
(princ);(princ (strcat "\nDeleted menu file: " mfile))
(princ (strcat "\nFailed to delete menu file: " mfile))
)
)
)
)

;;;*************************************************************************
;;; MODULE: MenuUpdate-UnloadMenus
;;; DESCRIPTION: Unloads all ShipWorks menugroups
;;; ARGS: none
;;; EXAMPLE:
;;;*************************************************************************

(defun MenuUpdate-UnloadMenus ()
(ASW-PRINC "\n(ASW-MenuUpdate-UnloadMenus)")
(princ "\nUnloading ShipWorks menugroups...")
(ASW-Menu-Unload "asw2k")
(foreach n '("ASW2K-E" "ASW2K-P" "ASW2K-S" "ASW2K-V")
(ASW-Menu-Unload n)
)
)

;;;*************************************************************************
;;; MODULE: MenuUpdate-DownloadMenus
;;; DESCRIPTION: Downloads server files to client for all ShipWorks menus
;;; ARGS: none
;;; EXAMPLE:
;;;*************************************************************************

(defun MenuUpdate-DownloadMenus
( / msrc1 msrc2 mtarget1 mtarget2 go)
(ASW-PRINC "\n(ASW-MenuUpdate-DownloadMenus)")
(cond
( (setq msrc1 (findfile (strcat G$MENU "\\asw2k.mnu")))
 (if (setq mtarget1 (findfile (strcat G$DAT "\\asw2k.mnu")))
(if (vl-file-delete mtarget1)
(setq go T)
)
(setq go T)
)
 (if go
(if (vl-file-copy msrc1 (strcat G$DAT "\\asw2k.mnu"))
(princ "\nBase menu file downloaded successfully.")
(princ "\nFailed to download base menu file!")
)
(princ "\nFailed to remove client base menu cache, download failed.")
)
)
)
(setq go nil)
(cond
( (setq msrc2 (findfile (strcat G$MENU "\\" G$APP ".mnu")))
 (if (setq mtarget2 (findfile (strcat G$DAT "\\" G$APP ".mnu")))
(if (vl-file-delete mtarget2)
(setq go T)
)
(setq go T)
)
 (if go
(if (vl-file-copy msrc2 (strcat G$DAT "\\" G$APP ".mnu"))
(princ "\nService menu file downloaded successfully.")
(princ "\nFailed to download service menu file!")
)
(princ "\nFailed to remove client service menu cache, download failed.")
)
)
)
)

(defun ObjErr (errobj)
(princ (strcat "\nError: " (vl-catch-all-error-message errobj)))
)

(defun Obj-ReleaseAll (objects)
(foreach obj objects
(if (= (type obj) 'vla-object); symbol bound to vla-object type?
(if (not (vlax-object-released-p obj)); not already released?
(vlax-release-object obj); release it!
)
)
(set (quote obj) nil)
)
)

;;;*************************************************************************
;;; MODULE: Menu-LoadPartialMenus
;;; DESCRIPTION: Loads default menu items for ShipWorks at start-up
;;; ARGS: none
;;; EXAMPLE: (ASW-Menu-LoadPartialMenus)
;;;*************************************************************************

(defun Menu-LoadPartialMenus
( / mgroups mgnames omg mgf)
(ASW-Princ "\n(ASW-Menu-LoadPartialMenus)")
(if (not (menugroup "asw2k"))
(progn
(ASW-MenuUpdate-UnloadMenus)
(ASW-MenuUpdate-DeleteClientFiles)
(ASW-MenuUpdate-DownloadMenus)
(ASW-MenuUpdate-LoadClientMenus)
)
(ASW-MenuUpdate-LoadClientMenus)
)
(setq mgroups (Get-MenuGroups)
mgnames (Get-MenuGroups-listall)
)
(if (and C:UPDATE (null (menugroup "asw2k"))) (C:UPDATE))
(if (not (menugroup G$APP))
(progn
(princ "\nReloading extended services menu group...")
(foreach mg '("ASW2K-E" "ASW2K-P" "ASW2K-S" "ASW2K-V")
(if
(and
(member mg mgnames)
(setq omg (vla-item mg mgroups))
)
(vla-unload omg)
(vlax-release-object omg)
)
); foreach - unload
(cond
( (or
(setq mgf (findfile (strcat G$APP ".mns")))
(setq mgf (findfile (strcat G$APP ".mnc")))
)
 (princ "\nLoading ShipWorks partial menu data...")
 (vla-load mgroups mgf)
 (if (menugroup G$APP)
(menucmd (strcat "P5=+" G$APP ".POP1"))
(princ (strcat "\nUnable to load partial menu for service: " G$APP))
)
)
( T
 (C:UPDATE)
)
)
)
(princ "\nMenugroup already loaded."); menugroup already loaded, do nothing
)
(princ)
)

;;;*************************************************************************
;;; MODULE: Menu-Unload
;;; DESCRIPTION: Unloads specified menugroup, returns if successful or menugroup not loaded
;;; ARGS: menugroup-name
;;; EXAMPLE: (ASW-Menu-Unload "ASW2K")
;;;*************************************************************************

(defun Menu-Unload (name / omg)
(ASW-PRINC "\n(ASW-Menu-Unload)")
(if (menugroup name)
(if (setq omg (vla-item (Get-MenuGroups) name))
(progn
(vla-unload omg)
(vlax-release-object omg)
T
)
)
T
)
)

;;;*************************************************************************
;;; MODULE: Menu-Reload
;;; DESCRIPTION: Reloads menugroup popmenu if loaded, loads otherwise
;;; ARGS: menugroup-name, path to menufile
;;; EXAMPLE:
;;;*************************************************************************

(defun Menu-Reload (name path / mnu1)
(ASW-PRINC "\n(ASW-Menu-Reload)")
 (cond
( (menugroup name)
 (menucmd (strcat "P5=+" name ".POP1"))
)
( (or
(setq mnu1 (findfile (strcat path "\\" name ".mns")))
(setq mnu1 (findfile (strcat path "\\" name ".mnc")))
)
 (vl-cmdf "_.menuload" mnu1)
 (menucmd (strcat "P5=+" name ".POP1"))
)
( T (C:UPDATE) )
)
)

(defun PopMenu-Insert (mgroup name loc / pmnu)
(ASW-PRINC "\n(ASW-PopMenu-Insert)")
(if (not (ASW-PopMenu-MenuBar-p name))
 (if (setq pmnu (ASW-PopupMenu mgroup name))
(progn
(vla-insertinmenubar pmnu loc)
(vlax-release-object pmnu)
T
)
(princ (strcat "\nMenugroup or popmenu not loaded or defined: " name))
)
(princ (strcat "\nPopmenu already loaded: " name))
)
)

;;;*************************************************************************
;;; MODULE: PopMenu-Remove
;;; DESCRIPTION: Removes specified popmenu from menubar, returns nil
;;; ARGS: menugroup-name, pop-menu-name
;;; EXAMPLE: (ASW-PopMenu-Remove "ASW2K" "&ShipWorks")
;;;*************************************************************************

(defun PopMenu-Remove (mgname name / pmnu)
(ASW-PRINC "\n(ASW-PopMenu-Remove)")
(if (menugroup mgname)
(if (ASW-PopMenu-MenuBar-p name)
(if (setq pmnu (vla-item (vla-get-menubar (ASW-AcadObject)) name))
(progn
(vla-removefrommenubar pmnu)
(vlax-release-object pmnu)
(princ (strcat "\nPopmenu successfully removed: " name))
)
(princ (strcat "\nPopmenu not found/Unable to remove: " name))
)
(princ (strcat "\nPopmenu not loaded/Unable to remove: " name))
)
)
)

;;;*************************************************************************
;;; MODULE: PopMenu-MenuBar-p
;;; DESCRIPTION: Returns T if menubar contains specified pop-menu item
;;; ARGS: pop-menu-name (string, case sensitive, includes mnemonics if used)
;;; EXAMPLE: (ASW-PopMenu-MenuBar-p "&ShipWorks") returns T or nil
;;;*************************************************************************

(defun PopMenu-MenuBar-p (name / mbar i found)
(ASW-PRINC "\n(ASW-PopMenuLoaded)")
(setq mbar (vla-get-menubar (asw-acadobject)) i 0)
(while (and (not found) (< i (1- (vla-get-count mbar))))
(if (= (strcase name) (strcase (vla-get-name (vla-item mbar i))))
(setq found T)
)
(setq i (1+ i))
)
(vlax-release-object mbar)
found
)

;;;*************************************************************************
;;;*************************************************************************

(defun Toolbars-Backup (mgroup / tbars name show pair out $regpath)
(ASW-PRINC "\n(ASW-Toolbars-Backup)")
(setq $regpath (strcat "Menus\\Toolbars\\" mgroup))
(cond
( (setq tbars (ASW-Toolbars mgroup))
 (vlax-for each tbars
(setq name (vla-get-name each)
show (vla-get-visible each)
pair (list name (if (= show :vlax-true) "1" "0"))
out (cons pair out)
)
)
 (vlax-release-object tbars)
 (if out
(progn
(foreach tb out
(ASW-RegSet (strcat $regpath "\\" (car tb)) (cadr tb))
)
)
)
)
( T (princ (strcat "\nMenugroup (" mgroup ") has no toolbars.")) )
)
out
)

;;;*************************************************************************
;;;*************************************************************************

(defun Toolbars-Restore (mgroup / keys $regpath dat out)
(ASW-PRINC "\n(ASW-Toolbars-Restore)")
(setq $regpath (strcat G$REGROOT "\\Menus\\Toolbars\\" mgroup))
(cond
( (menugroup mgroup)
 (cond
( (setq keys (vl-registry-descendents $regpath))
 (foreach key keys
(setq dat (vl-registry-read (strcat $regpath "\\" key) nil)
out (cons (list key dat) out)
)
)
)
( T (princ (strcat "\nNo saved toolbar info to retrieve: " mgroup)) )
)
)
)
out
)

;;;*************************************************************************
;;; MODULE: Menu-Load
;;; DESCRIPTION: Loads menugroup from specified MNU, MNS or MNC file
;;; ARGS: menugroup-name, menufile
;;; EXAMPLE:
;;;*************************************************************************

(defun Menu-Load (mgroup mfile / mgroups omg)
(ASW-PRINC "\n(ASW-Menu-Load)")
(cond
( (not (menugroup mgroup))
 (setq mgroups (Get-MenuGroups))
 (if (findfile mfile)
 (setq omg (vla-load mgroups (findfile mfile)))
(princ (strcat "\nUnable to load menu file: " mfile))
)
)
( T (princ (strcat "\nMenugroup (" mgroup ") is alread loaded.")) )
)
omg
)

(princ)[/php]

再来,

[php];;;*************************************************************************;;;
;;; DSX-TableOut.LSP (VLX) ;;;
;;; Export Table Data to Excel Spreadsheet File ;;;
;;; Part of DSX Tools Suite ;;;
;;; Copyright (C)2001-2002 David M. Stein, All rights reserved. ;;;
;;;*************************************************************************;;;
;;; Version 2001.00 07/13/01: Initial release. ;;;
;;; Version 2001.30 11/07/01: Updated for 1.3 ;;;
;;; Version 2002.00 02/24/02: Updated for 2002.20 beta 5 ;;;
;;; Version 2002.21 03/24/02: Fixed bugs, Dropped typelib interfacing ;;;
;;; because of incompatabilities between Office ;;;
;;; 2000 and XP versions of Excel TypeLib sets. ;;;
;;; Version 2002.22 04/26/02: Added data formatting option and preview ;;;
;;; option for table formats ;;;
;;; Version 2002.30 07/21/02: Fixed bugs with Office XP interface ;;;
;;; Version 2002.12.22: Added XML output option ;;;
;;;*************************************************************************;;;
;;; Global Variables... ;;;
;;; ;;;
;;; G$TBXL = Imported list of formats ;;;
;;; G$TBXF = Export filename ;;;
;;; G$TBXT = Format selection (index) in formats list ;;;
;;; G$TBX1 = 1/0 toggle for Show Column Headings ;;;
;;; G$TBX2 = 1/0 toggle for Auto-Fit Columns ;;;
;;; G$TBX3 = Row height value ;;;
;;; G$TBX4 = Tab-name (worksheet name) in Excel ;;;
;;; G$TBX5 = Apply cell data format as TEXT only to all cells ;;;
;;;*************************************************************************;;;

(defun C:TABLEOUT
( / dch dloc opt ok $inifile)
(defun *error* (s)
(dsx-error s)
(if (and xlapp (not (vlax-object-released-p xlapp))) (vlax-release-object xlapp))
(setq master nil datalist nil basept nil nextpt nil)
(gc)(gc); attempt to clear stack
(dsx-undoend)
(princ)
)
(setq $inifile (dsx-regget "TableOut\\TableDefFile" "data\\tableout.ini")
 dch (load_dialog "dsx-tableout")
dloc (dsx-form-getloc "TableOutMain")
opt (dsx-regget "TableOut\\FormatType" "1")
)
(if (not (new_dialog "main" dch "" dloc))
(progn
(alert "DCL Load Failure (tableout:main)...")
(exit)
)
)
(set_tile "option" opt)
(action_tile "option" "(setq opt $value)")
(action_tile "accept" "(setq ok 1 dloc (done_dialog))")
(action_tile "cancel" "(princ)")
(start_dialog)
(unload_dialog dch)
(cond
( (= ok 1)
 (dsx-form-saveloc "TableOutMain" dloc)
 (if (= opt "1")
(dsx-tableout-excel)
(dsx-tableout-xml)
)
)
)
(princ)
)

(defun dsx-tableout-excel
( / tblforms ok master datalist basept nextpt
dch op1 op2 op3 op4 op5 op6
outfl form dloc
)

(dsx-princ "\n(dsx-tableout-excel)")

;;-------------------------------------
;; Main dialog interaction process...
;;-------------------------------------

(setq dch (load_dialog "dsx-tableout"))
(setq dloc (dsx-form-getloc "TableOut"))

;; Set default global variable settings...

(DSX-TBX-LoadForms nil); list of forms

 (dsx-princ "\nChecking default settings...")

(setq G$TBXF (dsx-regget "TableOut\\ExcelFilename" "")
G$TBXT (dsx-regget "TableOut\\FormIndex" "0")
G$TBX1 (dsx-regget "TableOut\\ShowHeadings" "1")
G$TBX2 (dsx-regget "TableOut\\AutoFitColumns" "1")
G$TBX3 (dsx-regget "TableOut\\RowHeight" "0.25")
G$TBX4 (vl-filename-base (dsx-getvar "dwgname"))
G$TBX5 (dsx-regget "TableOut\\AutoDataFormat" "0")
G$TBX6 (dsx-regget "TableOut\\ExcelRetain" "1")
)

 (if (not (new_dialog "excel" dch "" dloc))
(progn
(alert "DCL Load Failure (tableout:excel)...")
(exit)
)
)

(dsx-listbox-fill1 "form" G$TBXL 0); fill popup-list with form names

;; Set tiles to default values/settings...

(set_tile "1" G$TBX1)
(set_tile "2" G$TBX2)
(set_tile "3" G$TBX3)
(set_tile "filename" G$TBXF)
(set_tile "form" G$TBXT)
 (set_tile "4" G$TBX4)
(set_tile "5" G$TBX5)
(set_tile "6" G$TBX6)

;; Get actions from user...

(action_tile "select" "(DSX-TBX-SelectFile)")
(action_tile "filename" "(DSX-TBX-ValidateFilename $value)")
(action_tile "form" "(setq form $value)")
(action_tile "1" "(setq op1 $value)")
(action_tile "2" "(setq op2 $value)")
(action_tile "3" "(setq op3 $value)")
 (action_tile "4" "(setq op4 $value)")
(action_tile "5" "(setq op5 $value)")
(action_tile "6" "(setq op6 $value)")
 (action_tile "edit" "(DSX-TBX-EditForms)")
(action_tile "show" "(DSX-TBX-FormInfo)")

(action_tile "help" "(DSX-TBX-ShowHelp)")
(action_tile "accept" "(setq ok 1 dloc (done_dialog))")
(action_tile "cancel" "(princ)")
(start_dialog)
(unload_dialog dch)

;; Check action results, save global variable changes
;; Execute process to extract data from table...

(cond
( (= ok 1)
 (dsx-form-saveloc "TableOut" dloc)
 (if outfl (setq G$TBXF outfl))
 (if form (setq G$TBXT form))
 (if op1 (setq G$TBX1 op1))
 (if op2 (setq G$TBX2 op2))
 (if op3 (setq G$TBX3 op3))
 (if op4 (setq G$TBX4 op4))
 (if op5 (setq G$TBX5 op5))
 (if op6 (setq G$TBX6 op6))

(dsx-regset "TableOut\\ExcelFilename" G$TBXF)
(dsx-regset "TableOut\\FormIndex" G$TBXT)
(dsx-regset "TableOut\\ShowHeadings" G$TBX1)
(dsx-regset "TableOut\\AutoFitColumns" G$TBX2)
(dsx-regset "TableOut\\RowHeight" G$TBX3)
 (dsx-regset "TableOut\\AutoDataFormat" G$TBX5)
 (dsx-regset "TableOut\\ExcelRetain" G$TBX6)

 ;(DSX-TBX-SaveOutputFilename G$TBXF)

 (setq G$TBXX (nth (atoi G$TBXT) G$TBXL))
 (if (setq G$TBXROW (cdr G$TBXX))
 (DSX-TBX-ExportTable)
(alert "System error: Rowset not defined...")
)
)
)
(dsx-undoend);; close Undo block
)

;|
[9090-600 Electrical Install BOM]
Item=0.75
Qty=0.75
Description=5.0
MatlSpec=2.0
Material=1.25
PartNum=2.0
Source=0.75
APL=1.25
UnitWt=0.75
Remarks=5.5
|;

; Each sublist in the form of...

; ("9090-600 Electrical Install BOM" ("Item" "0.75") ("Qty" "0.75") ("Description" "5.0") ("MatlSpec" "2.0") ("Material" "1.25") ("PartNum" "2.0") ("Source" "0.75") ("APL" "1.25") ("UnitWt" "0.75") ("Remarks" "5.5"))

(defun DSX-TBX-FormInfo
( / fid fname fcols)
(dsx-princ "\n(DSX-TBX-FormInfo)")
(cond
( form
 (setq fid (nth (atoi form) G$TBXL)
fname (car fid); form name
fcols (cdr fid); column pairs (name width)
)
 (dos_proplist fname "Table Structure" fcols)
)
)
)

;;;*************************************************************************
;;; MODULE: DSX-TBX-ExportTable
;;; DESCRIPTION: Prompt to window table, then fetch row data into list and export
;;; ARGS: none
;;; EXAMPLE:
;;;*************************************************************************

(defun DSX-TBX-ExportTable
(mode / rowh top-left bot-left top-right bot-right rownum nextpt datalist master)
(dsx-princ "\n(DSX-TBX-ExportTable)")

(setq rowh (atof (DSX-RegGet "TableOut\\RowHeight" G$TBX3));; row height
 osm (dsx-getvar "osmode");; save!
)
(DSX-SetVar "osmode" 1)

(cond
( (and
(setq top-left (getpoint "\nPick top-left of grid region: "))
(setq bot-right (getcorner top-left "\nPick bottom-right of grid region: "))
)

 (dsx-setvar "osmode" 0)

 (dsx-princ "\nSetting up region boundary points...")

 (setq top-right (list (car bot-right) (cadr top-left) 0);; top-right
 bot-left (list (car top-left) (cadr bot-right) 0);; bottom-left
 rownum (fix (/ (distance top-left bot-left) rowh));; number of rows in region
 nextpt (dsx-ptoff top-left 0 (- rowh));; first row basepoint
); setq

 (princ (strcat "\n" (itoa rownum) " rows detected in region."))
 (princ "\nScanning table region from top to bottom...")

 (repeat rownum
(setq datalist (DSX-TBX-GetRowData nextpt);; row data list as string
 master (if master ;; master list
 (append master (list datalist))
 (list datalist)
 )
 nextpt (dsx-ptoff nextpt 0 (- rowh));; increment row basepoint
); setq
); repeat

 (dsx-princ "\nProcessing master list to prepare output...")

(cond
( (and master (listp master) (> (length master) 0))
 (cond
( (= mode 1)
 (DSX-TBX-ExportExcel master)
 (alert
(strcat
"Spreadsheet file updated and saved:\n\n"
(dsx-regget "TableOut\\ExcelFilename" G$TBXF);G$TBXF
)
)
)
( (= mode 2)
 (DSX-TBX-ExportXML master)
 (dos_htmlbox "TableOut XML Report" G$TBXF 500 300)
)
)
)
( T (alert "Failed to collect master table list...") )
); cond
)
( T (alert "Incomplete selection, operation cancelled.") )
); cond
); defun

;;;*************************************************************************
;;; MODULE: DSX-TBX-ExportExcel
;;; DESCRIPTION: Exports data list to Excel spreadsheet
;;; ARGS: datalist (list of lists)
;;; EXAMPLE:
;;;*************************************************************************

(defun DSX-TBX-ExportExcel
(datlst
 / xlapp ash range cursor out xlsheets newsheet awb xlFilename oldSht dwg
 exists rang1 rang1s rang1x rang1f span rng
)
(dsx-princ "\n(DSX-TBX-ExportExcel)")
(cond
( (dsx-load-typelib-excel)
 (cond
( (setq xlapp (vlax-create-object "Excel.Application"))
 (vlax-put-property xlapp "visible" :vlax-true)
;(setq xlFilename G$TBXF dwg G$TBX4)

 (if (setq fn (findfile G$TBXF))
(progn
(setq exists T)
(princ (strcat "\nOpening file: " fn))
(vlax-invoke-method
(vlax-get-property xlapp "WorkBooks")
"Open" fn
)
)
(progn
(setq wbooks (vlax-get-property xlapp "workbooks")
newbook (vlax-invoke-method wbooks "add")
)
)
)

 (setq awb (vlax-get-property xlapp "ActiveWorkbook"))
 (setq xlsheets (vlax-get-property xlapp "sheets"))

 ; Note: I can't figure out why using the Item and Select methods
 ; on the Sheets collection won't accept the <dwg> string value
 ; even when it has been cast as an object of any type. Therefore,
 ; I resort to iterating the collection until I find the sheet
 ; with a matching name and invoke the Delete method on it.

 ; Epilogue: I figured this out. The ITEM method is actually not
 ; a 'method' but a property. This only applies to worksheets,
 ; not to sheets, and you have to retrieve it by using the form
 ; (vlax-get-property worksheets "item" "name") Due to laziness,
 ; nice weather and excessive beer intake, I am not up to modifying
 ; this section as such. You can do that if you care to. - DMS

(vlax-for sh xlsheets
(if (= (vlax-get-property sh "Name") G$TBX4)
(vlax-invoke-method sh "Delete")
)
)

(princ "\nAdding new worksheet to workbook...")
 (setq newsheet (vlax-invoke-method xlsheets "Add"))
 (vlax-put-property newsheet "Name" G$TBX4)

 (setq ash (vlax-get-property xlapp "activesheet")
rng (vlax-get-property xlapp "activecell")
cursor 1
)

 (if (= "1" G$TBX1); show column headings?
(setq datlst
(cons (DSX-TBX-FieldNames G$TBXROW) datlst)
)
)

 (if (= G$TBX5 "1") (dsx-excel-rangedataformat ash))

 (foreach row datlst
(dsx-excel-rowput newsheet "A" (itoa cursor) row); function defined below
(setq cursor (1+ cursor))
)
 ;; The following section of code allows you to specify the
 ;; font properties for a selected range by first selecting
 ;; the range with given cell references, and then applying
 ;; the desired font properties to the selection object...

 ;; Select top-row if headings are shown and apply BOLD font...

 (cond
( (= G$TBX1 "1")
 ;; Note: the "Rows" property will not accept a parameter
 ;; of "1:1" as does the "Range" property, when invoked from
 ;; Vlisp for some stupid ass reason. Rows("1:1") selects
 ;; row 1 infinite columns, whereas Range("A1:_1") must be
 ;; calculated to select a finite range of columns.
 (setq span (strcat "A1:"
(chr
(+ 64 (length G$TBXROW))
)
"1"
)
rang1 (vlax-get-property xlapp "Range" span)
 rang1s (vlax-invoke-method rang1 "Select")
 rang1x (vlax-get-property xlapp "Selection")
 rang1f (vlax-get-property rang1x "Font")
)
 (dsx-princ "\nApplying formatting to heading columns...")
(foreach prop
(list
(list "Name" "Verdana"); Arial, Tahoma, etc.
(list "Size" 10); 8, 10, 12, 14, etc.
(list "Bold" :vlax-True)
(list "ColorIndex" -4105);msxl-xlAutomatic
(list "Strikethrough" :vlax-False)
(list "Superscript" :vlax-False)
(list "Subscript" :vlax-False)
(list "OutlineFont" :vlax-False)
(list "Underline" -4142);msxl-xlUnderlineStyleNone
(list "Shadow" :vlax-False)
)
(vlax-put-property rang1f (car prop) (cadr prop))
); foreach
 (setq rang1 (vlax-get-property xlapp "Range" "A1:A1"))
 (vlax-invoke-method rang1 "Select")
)
)
 (dsx-princ "\nApplying column formatting...")
 (if (= G$TBX2 "1") (dsx-excel-rangeautofit ash))

 (dsx-princ "\nSelecting range to apply formatting...")
 (vlax-invoke-method
(vlax-get-property ash "Cells")
"Select"
)
 (dsx-princ "\nApplying formatting to range...")
 (vlax-put-property
(vlax-get-property xlapp "Selection")
"VerticalAlignment" -4160;msxl-xlTop
)
 (dsx-princ "\nSelecting range A1:A1 for default scope...")
 (vlax-invoke-method
(vlax-get-property xlapp "Range" "A1:A1")
"Select"
)
 (dsx-princ "\nSaving workbook...")
 (if exists
(vlax-invoke-method awb "Save")
 (vlax-invoke-method awb "SaveAs" G$TBXF
-4143;|msxl-xlNormal|; "" "" :vlax-False :vlax-False nil)
)
;(dsx-excel-kill)
 (dsx-princ "\nReleasing objects...")
 (vlax-release-object rng)
 (vlax-release-object ash)
 (if (= G$TBX6 "0") (vlax-invoke-method xlapp "Quit"))
 (foreach obj
 (list rng ash range rang1 rang1x rang1s rang1f xlsheets newsheet awb xlapp)
 (if (= 'VLA-OBJECT (type obj))
 (if (not (vlax-object-released-p obj))
 (vlax-release-object obj)
 )
 )
 )
 ;(vlax-release-object xlapp)
 ;(setq range nil ash nil xlapp nil)
 (gc);; Explicit clean-up after killing Excel is required!!!!!!!!!!!!!
 (gc);; Double-ensure garbage collection on Win2K and XP systems using Office XP!!!!!
 (princ (strcat "\nData saved to spreadsheet file: " G$TBXF))
 )
 )
)
( T (alert "Failed to initialize type library for MS-Excel...") )
)
 (princ)
)

;;;*************************************************************************
;;; MODULE:
;;; DESCRIPTION:
;;; ARGS:
;;; EXAMPLE:
;;;*************************************************************************

(defun DSX-TBX-DwgInfo ()
(dsx-princ "\n(DSX-TBX-DwgInfo)")
(strcat
"Exported From: "
(dsx-get-dwgname nil)
" Username: " (getenv "username")
" Date: " (Date)
" Time: " (Time)
)
)

;;;*************************************************************************
;;; MODULE: DSX-TBX-GetRowData
;;; DESCRIPTION: Fetch text string data for one row, return data as list of strings (each member denotes one cell in the row)
;;; ARGS: basepoint (bottom-left of row)
;;; EXAMPLE:
;;;*************************************************************************
;;; Fetch text data from row and return as a list of strings. If a cell is
;;; empty, it's cell value is set to "" in the returned list.
;;;*************************************************************************

(defun DSX-TBX-GetRowData
(pa / pb txlist cell cw tx ts)
(dsx-princ "\n(DSX-TBX-GetRowData)")
;(SaveSnaps)

(cond
( (and pa (listp pa));; if point was selected
 (foreach cell G$TBXROW
(setq cw (atof (cadr cell));; current cell width
pb (dsx-ptoff pa cw rowh);; top-right of current cell
 ts (DSX-TBX-GetCellData pa pb)
txlist (if txlist (append txlist (list ts)) (list ts));; append to return list
pa (dsx-ptoff pa cw 0);; step over to next cell
)
(setq tx nil ts nil)
); foreach
)
( T (princ) )
); cond
;(SetSnaps);; restore osnap setting
txlist
)

;;;*************************************************************************
;;; MODULE: DSX-TBX-GetCellData
;;; DESCRIPTION: Fetches string values from a given cell defined by diagonal window points
;;; ARGS: point1, point2
;;; EXAMPLE:
;;;*************************************************************************
;;; Retrieve text data from one cell in a table row. If multiple lines are
;;; collected, sort them from top-down and return as a single string using
;;; a special delimiter to denote line separation. Delimiter is "^"
;;;*************************************************************************

(defun DSX-TBX-GetCellData
(p1 p2 / sstxt return index txstr txdat yloc sortlst newsort item)
(dsx-princ "\n(DSX-TBX-GetCellData)")
(cond
( (setq sstxt (ssget "c" p1 p2 '((0 . "TEXT"))));; any text objects?
(dsx-princ "\nFound text objects in cell.")
 (cond
( (> (sslength sstxt) 1);; more than one found?
 (dsx-princ "\nMultiple text objects in cell.")
 (setq index 0 return "")

 (repeat (sslength sstxt)
(setq txdat (entget (ssname sstxt index));; properties list
 txstr (dxf 1 txdat);; string value
 yloc (cadr (dxf 10 txdat));; y-coordinate
 sortlst (if sortlst
(append sortlst (list (list yloc txstr)))
(list (list yloc txstr))
); if
 index (1+ index);; increment index
); setq
); repeat

 (dsx-princ "\nSorting cell data list...")
 (setq newsort (listsort 0 sortlst));; sort from bottom to top

 (foreach item (reverse newsort);; step thru in reverse order
(setq return
(if (= return "")
(cadr item)
 (strcat return " " (cadr item))
); if
); setq
); foreach

 (setq sstxt nil)
 (dsx-princ " Done.")
)
( T
 (dsx-princ "\nSingle text object in cell.")
 (setq return (DXF 1 (entget (ssname sstxt 0)))
 sstxt nil
)
)
); cond
)
( T
 (dsx-princ "\nCell is empty.")
 (setq return "")
)
); cond

return

); defun

;;;*************************************************************************
;;; MODULE: DSX-TBX-FieldNames
;;; DESCRIPTION: Returns field names from column data list
;;; ARGS: column-data-list
;;; EXAMPLE:
;;;*************************************************************************

(defun DSX-TBX-FieldNames (lst / out)
(dsx-princ "\n(DSX-TBX-FieldNames)")
(foreach mbr lst
(setq out (cons (car mbr) out))
)
(reverse out)
)

;;;*************************************************************************
;;; MODULE: DSX-TBX-ColumnJustify
;;; DESCRIPTION: Apply horizontal and vertical justifications to given column
;;; ARGS: column-letter, horiz-just-letter, vert-just-letter
;;; EXAMPLE: (DSX-TBX-ColumnJustify "B" "C" "T") justify column "B" as Top-Center
;;;*************************************************************************

(defun DSX-TBX-ColumnJustify (colltr hJust vJust / rang rangs rangx justH justV)
(dsx-princ "\n(DSX-TBX-ColumnJustify)")
(cond
( (setq rang (vlax-get-property xlapp "Columns" (strcat colltr ":" colltr)))
 (setq rangs (vlax-invoke-method rang "Select"))
 (setq rangx (vlax-get-property xlapp "Selection"))
 (cond
( (= hJust "R") (setq justH -4152) );msxl-xlRight) )
( (= hJust "C") (setq justH -4108) );msxl-xlCenter) )
( T (setq justH 1) );msxl-xlGeneral) )
)
 (cond
( (= vJust "T") (setq justV -4160) );msxl-xlTop) )
( (= vJust "M") (setq justV -4143) );msxl-xlDefault) )
( T (setq justV -4107) ); msxl-xlBottom) )
)
 (vlax-put-property rangx "HorizontalAlignment" justH)
 (vlax-put-property rangx "VerticalAlignment" justV)
)
)
)

;;;*************************************************************************
;;; MODULE: DSX-TBX-Column-SetWidth
;;; DESCRIPTION: Apply column widths and text-wrapping to a given column
;;; ARGS: column-letter, width-value, wrap-text-flag
;;; EXAMPLE: (DSX-TBX-Column-SetWidth "B" 0.50 T) set column "B" width to 0.50 and apply text-wrapping
;;;*************************************************************************

(defun DSX-TBX-Column-SetWidth (colltr width wraptext / rang rangs rangx)
(dsx-princ "\n(DSX-TBX-Column-SetWidth)")
(cond
( (setq rang (vlax-get-property xlapp "Columns" (strcat colltr ":" colltr)))
 (setq rangs (vlax-invoke-method rang "Select")
 rangx (vlax-get-property xlapp "Selection")
)
 (vlax-put-property rangx ColumnWidth width)
 (if wraptext
(vlax-put-property rangx "WrapText" :vlax-True)
)
)
)
)

;;;*************************************************************************
;;; MODULE: Concat_NthStrings
;;; DESCRIPTION: Returns a string out of (nth) member of multiple lists
;;; ARGS: nested-list-of-lists-of-strings, nth-value
;;; EXAMPLE: (Concat_NthStrings '(("A" "B" "C")("D" "E" "F")) 1) returns "BE"
;;;*************************************************************************

(defun Concat_NthsStrings (ts n / out)
(dsx-princ "\n(Concat_NthsStrings)")
(setq out "")
(foreach m ts
(setq out (strcat out (nth n m)))
)
out
)

;;-------------------------------------
;; Load formats from INI file into list.
;; Load list into listbox for selection.
;;-------------------------------------

(defun DSX-TBX-LoadForms
(reload / ff forms fieldnames colwidth fields fieldset formslist)
(dsx-princ "\n(DSX-TBX-LoadForms)")
(cond
( (setq ff (findfile $inifile))
(cond
( (setq forms (dos_getini nil nil ff))
 (foreach formname forms
;; get field names for this table form...
 (setq fieldnames (dos_getini formname nil ff))
;; get each field column width...
 (foreach fieldname fieldnames
 (setq colwidth (dos_getini formname fieldname ff)
fieldset (list fieldname colwidth)
 fields (cons fieldset fields)
;; fieldset=(fieldname width)
;; fields=((fieldname width) (fieldname width)...)
 )
 ); foreach

(setq fields (cons formname (reverse fields)))
; fields list= (formname (fieldname width) (fieldname width)...)

 (setq formslist (if formslist
(append formslist (list fields))
(list fields)
)
fields nil
)
 )
 ;(setq formslist (reverse formslist))
 (setq G$TBXL formslist)
 (if reload
 (DSX-ListBox-Fill1 "form" G$TBXL 0)
G$TBXL
)
)
( T (alert "Unable to load table list...") )
)
)
( (setq ff (findfile (strcat G$DATA $inifile)))
 (dsx-regset "TableOut\\TableDefFile" ff)
(cond
( (setq forms (dos_getini nil nil ff))
 (foreach formname forms
;; get field names for this table form...
 (setq fieldnames (dos_getini formname nil ff))
;; get each field column width...
 (foreach fieldname fieldnames
 (setq colwidth (dos_getini formname fieldname ff)
fieldset (list fieldname colwidth)
 fields (cons fieldset fields)
;; fieldset=(fieldname width)
;; fields=((fieldname width) (fieldname width)...)
 )
 ); foreach

(setq fields (cons formname (reverse fields)))
; fields list= (formname (fieldname width) (fieldname width)...)

 (setq formslist (if formslist
(append formslist (list fields))
(list fields)
)
fields nil
)
 )
 ;(setq formslist (reverse formslist))
 (setq G$TBXL formslist)
 (if reload
 (dsx-listbox-fill1 "form" G$TBXL 0)
G$TBXL
)
)
( T (alert "Unable to load table list...") )
)
)
( T (alert "Unable to locate table list file...") )
)
); defun

(defun DSX-TBX-SelectFile ( / ff)
(dsx-princ "\n(DSX-TBX-SelectFile)")
(cond
( (setq ff (getfiled "Spreadsheet File" (if G$TBXF G$TBXF "") "XLS" 1))
(setq outfl ff)
(set_tile "filename" outfl)
)
)
)

(defun DSX-TBX-ShowHelp ()
(dsx-help "tableout.txt" "TABLEOUT: Exporting Table Data to Excel")
)

;;--------------------------------
;; Verify keyed-in filename is valid
;;--------------------------------

(defun DSX-TBX-ValidateFilename (name)
(dsx-princ "\n(DSX-TBX-ValidateFilename)")
 (cond
( (not (member name '("" " " " ")))
(if (= (strcase (substr name (- (strlen name) 3)) ".XLS"))
(progn
(setq outfl name)
)
(progn
(alert "Filename must have .XLS extension...")
(mode_tile "filename" 2)
)
)
)
( T
(alert "Filename cannot be blank...")
(DSX-TBX-SelectFile)
)
); cond
); defun

;;-------------------------------------
;; Open INI file in Notepad to edit.
;; Reload formats in listbox when done.
;;-------------------------------------

(defun DSX-TBX-EditForms ( / fn)
(dsx-princ "\n(DSX-TBX-EditForms)")
(cond
( (setq fn (findfile $inifile))
(DOS_ExeWait (strcat "notepad.exe " fn))
(DSX-TBX-LoadForms T)
)
( T (alert "No table forms loaded...") )
)
); defun

(defun DSX-Excel-RowPut (worksheet col row datalist)
(foreach val datalist
(dsx-excel-cellput worksheet
(strcat col row)
val
)
(setq col (chr (1+ (ascii col))))
)
(strcat col row)
)

(defun DSX-Excel-CellPut (worksheet range value)
 (vlax-put-property
 (DSX-Excel-RangeSelect worksheet range)
 "value2"
 value
 )
)

(defun DSX-Excel-RangeSelect (worksheet range)
 (vlax-get-property worksheet "range" range);; returns vla-object
)

(defun DSX-Excel-Worksheet (worksheets name)
(vlax-get-property worksheets "item" name);; returns vla-object
)

(defun DSX-tableout-xml
( / tblforms ok master datalist basept nextpt
dch op1 op2 op3 op4 op5 op6
outfl form dloc tmp
)
(dsx-princ "\n(dsx-tableout-xml)")

;;-------------------------------------
;; Main dialog interaction process...
;;-------------------------------------

(setq dch (load_dialog "dsx-tableout"))
(setq dloc (dsx-Form-GetLoc "TableOut"))

;; Set default global variable settings...

(DSX-TBX-LoadForms nil); list of forms

 (dsx-princ "\nChecking default settings...")
(setq tmp
 (strcat
 (dsx-getvar "dwgprefix")
 (vl-filename-base (dsx-get-dwgname t)) ".xml")
)
(setq G$TBXF tmp;(dsx-regget "TableOut\\XMLFilename" tmp)
G$TBXT (dsx-regget "TableOut\\FormIndex" "0")
G$TBX3 (dsx-regget "TableOut\\RowHeight" "0.25")
)

 (if (not (new_dialog "xmlout" dch "" dloc))
(progn
(alert "DCL Load Failure (tableout:xmlout)...")
(exit)
)
)

(dsx-listbox-fill1 "form" G$TBXL 0); fill popup-list with form names

;; Set tiles to default values/settings...

(set_tile "3" G$TBX3)
(set_tile "filename" G$TBXF)
(set_tile "form" G$TBXT)

;; Get actions from user...

(action_tile "select" "(DSX-TBX-SelectFile)")
(action_tile "filename" "(DSX-TBX-ValidateFilename $value)")
(action_tile "form" "(setq form $value)")
(action_tile "3" "(setq op3 $value)")
 (action_tile "edit" "(DSX-TBX-EditForms)")
(action_tile "show" "(DSX-TBX-FormInfo)")
(action_tile "help" "(DSX-TBX-ShowHelp)")
(action_tile "accept" "(setq ok 1 dloc (done_dialog))")
(action_tile "cancel" "(princ)")
(start_dialog)
(unload_dialog dch)

;; Check action results, save global variable changes
;; Execute process to extract data from table...

(cond
( (= ok 1)
 (dsx-form-saveloc "TableOut" dloc)
 (if outfl (setq G$TBXF outfl))
 (if form (setq G$TBXT form))
 (if op3 (setq G$TBX3 op3))

(dsx-regset "TableOut\\FormIndex" G$TBXT)
(dsx-regset "TableOut\\RowHeight" G$TBX3)

 (setq G$TBXX (nth (atoi G$TBXT) G$TBXL))
 (if (setq G$TBXROW (cdr G$TBXX))
 (DSX-TBX-ExportTable 2)
(alert "System error: Rowset not defined...")
)
)
)
)

(defun DSX-TBX-ExportXML
(datlst / fieldnames fl row itm)
(dsx-princ "\n(DSX-tbx-exportXML)")

(setq fieldnames (DSX-TBX-FieldNames G$TBXROW))
(cond
( (setq fl (open G$TBXF "w"))
 (write-line "<?xml version=\"1.0\" standalone=\"yes\"?>" fl)
(write-line "<document>" fl)
 (write-line " <document-info>" fl)
(write-line " <title>DSX Tools TableOut XML Report</title>" fl)
(write-line " <comment>Generated by DSX Tools 2002</comment>" fl)
(write-line (strcat " <author>" (getenv "username") "</author>") fl)
(write-line " <comment>Web: http://www.dsxcad.com</comment>" fl)
(write-line " <drawing>" fl)
(write-line (strcat " <filename>" (dsx-get-dwgname t) "</filename>") fl)
(write-line " </drawing>" fl)
 (write-line " </document-info>" fl)
 (write-line " <material-table>" fl)
 (foreach row datlst
(write-line " <material-row>" fl)
(setq count (1- (length row)) i 0); number of fields in row
(foreach itm row
(setq fieldname (nth i fieldnames))
(if (= (stripstr itm) "")
(write-line (strcat " <" fieldname ">$NULL$</" fieldname ">") fl)
(progn
(setq itm (DSX-TBX-Ampersand itm))
(write-line (strcat " <" fieldname ">" itm "</" fieldname ">") fl)
)
)
(setq i (1+ i))
)
(write-line " </material-row>" fl)
)
 (write-line " </material-table>" fl)
 (write-line "</document>" fl)
 (close fl)
)
( T (alert "Unable to open XML document for output...") )
)
 (princ)
)

(defun DSX-TBX-Ampersand (string / newstr)
(setq newstr (dsx-string->list string " "))
(setq out (mapcar
'(lambda (x)
 (if (= x "&")
 "& "
 (strcat x " ")
 )
)
newstr
))
(apply 'strcat out)
)

;;;*************************************************************************;;;
(princ)[/php]

dsx-api用法說明:
[php]

DSX Tools
API Reference
All Functions and Documentation: U.S. Copyright (C) 2001-2002 David M. Stein, All Rights Reserved.
Version 2002.08.09.00 Dated: 08/09/2002
Public License Hereby Granted for reuse upon acceptance of terms below in their entirety without modification.
Legal Notice and License for General Non-Profit Public Use:
Users may develop derivative works based upon the information provided herein, but only if they agree not to sell said derivative works for profit without first obtaining explicit prior written consent of the author. In addition, users agree not to hold liable the author of this work for any subsequent damages or loss of business profit, productivity, whether said damages occur as a result of derivative works or the information provided herein. The author of this work gives NO WARRANTY or GARANTEE of any kind whatsoever as to the fitness or functionality of the information or examples provided herein. This information is provided solely for informational purposes and is not intended to coerce, convince or otherwise invite anyone to make use of this information for their own benefit or the benefit of others.

TERMS OF ACCEPTANCE: Users agree to accept and claim all risks and responsibilities for any use of this information in any form whatsoever. Users that do not wish to accept these conditions are hereby NOT granted permission to use, adapt, derive or base any derivative or parallel works upon the information provided herein. Any and all derivative works must clearly display the copyright notice as follows in all forms of the derived work, whether electronic, printed or otherwise:

Portions of this application are based upon DSX Tools 2002, Copyright (C) 2001-2002 David M. Stein, All Rights Reserved.

In addition, developers that create derivative works for public use must clearly state to all recipients of said work the complete terms and conditions stated herein. In the event that users of derivative works are not properly notified of these conditions and terms of use, and/or have not agreed to them in their entirety, are hereby NOT authorized to use said derivative works for any reason whatsoever.

AutoCAD, Visual LISP, and AutoLISP are registered trademarks of Autodesk. Autodesk is a registered trademark. Office, XP, Excel, Word, Access, PowerPoint, Outlook and Windows are registered trademarks of Microsoft corp. All other trademarks are the property of their respective owners. DSX Tools is not affiliated with or endorsed by Autodesk or Microsoft in any respect.

Introduction
With the release of DSX Tools 2002, the underlying API library has evolved and matured somewhat to a point of being of potential benefit to external use. Once DSX Tools is loaded into a given AutoCAD session (via the DSX.VLX component), all of the functions defined below are exposed and readily available for use. These can be derived upon to build yet even more complex API functions or libraries, as well as specialized applications. The advantage of this is that there is no license royalty fee required, provided that usage is in compliance with terms and conditions stated herein. Why do I bother? Why do I do all this? Why no charge? Because I'm a nice guy.

Basic Functions
(DSX-AcadObject)
Returns the vla-object to the base AcadApplication object.

(DSX-ActiveDoc)
Returns the vla-object to the ActiveDocument object.

(DSX-MSpace)
Returns the vla-object to the ModelSpace collection object for the active document.

(DSX-PSpace)
Returns the vla-object to the PaperSpace collection object for the active document.

(DSX-ActiveSpace)
Returns the vla-object of the active working space (either ModelSpace or PaperSpace object).

(DSX-ActiveSpaceName)
Returns the name of the active space as either "Model" or "Paper".

(DSX-ActiveLayout)
Returns vla-object of the active layout in the active drawing.

(DSX-AcadPrefs)
Returns the vla-object to the AcadPreferences collection object for the AcadApplication object. This applies to all preferences settings that are applied to the AcadApplication object and are persistent throughout all drawing sessions.

(DSX-DocPrefs)
Returns the vla-object collection for the DatabasePreferences collection. This comprises preferences settings that apply to the document object only, as opposed to the AcadPreferences object, which applies to all documents by way of AutoCAD itself.

(DSX-Profiles)
Returns the vla-object collection of profiles within the AcadPreferences collection. Instead of using (vla-get-Profiles (DSX-AcadPrefs)), this shortens to simply (dsx-profiles).

(DSX-AcadPrefs-Output)
Returns the vla-object to the Output collection within the AcadPreferences collection. This relates to the Plotting tab of the OPTIONS dialog for those settings that are not drawing-specific.

(DSX-SetPlotStyleDefault-Objects stylename)
Sets the default plot style name the same way as is done via the OPTIONS dialog within the Plotting tab.

(DSX-SetPlotPolicy mode)
Defines plot style mode as either 0 (Named or STB), or 1 (Color-based or CTB) within the AcadPreferences/Output collection. This is identical to setting it in OPTIONS within the Output tab.

(DSX-PlotConfigs)
Returns vla-object to pagesetups collection in active drawing.

(DSX-PlotConfigs-Space name)
Returns name of working space for given specified pagesetup in active drawing. Returns "Model" or "Layout" (case sensitive!) as result. If pagesetup is not found, returns nil.

(DSX-PlotConfig-ListActive)
Returns a list of all pagesetup names in active drawing that are associated with the active working space (modelspace or paperspace). Ignores those associated with opposite working space.

(DSX-Delete-PageSetup name)
Deletes specified pagesetup from active drawing collection.

(DSX-SetPlotStyleDefault-Layer stylename)
(DSX-Load-PageSetup name source reload)
Imports a pagesetup name from a remote source drawing using ObjectDBX interface. If reload is non-nil, the import will overwrite an existing pagesetup of the same name if found.

(DSX-List-PlotConfigs)
Returns a list of all defined pagesetups in the active drawing. To return a list of pagesetups filtered by the active working space, use the (DSX-PlotConfig-ListActive) function.

(DSX-PlotConfig-Exists-p name)
Returns T or nil to verify that specified named pagesetup exists in the active drawing.

(DSX-SetPlotStyleTable stylename)

Entity Creation Functions
(DSX-AddArc point radius startangle endangle layer color linetype)
(DSX-AddCircle point radius layer color linetype)
(DSX-AddLine startpoint endpoint layer color linetype)
Creates LINE (AcDbLine) object with the specified properties: startpoint is a points list, as is endpoint. layer is the string value of the layer name. color is an integer or vla value (e.g. acRed, or 1 will do the same), linetype is the name of the linetype. Note that when specifying a linetype that is not defined, this function will attempt to load it from the default linetype definition file (either ACAD.LIN or ACADISO.LIN).

(DSX-AddLineC points-list closed layer color linetype)
Works the same as DSX-AddLine except that it accepts a list of points with an option to close the final segment or leave it open. The DSX-AddPline function is nearly identical in function except that it not only creates a single polyline object, but offers additional parameters (lineweight, linetype-generation).

(DSX-AddPline points-list closed layer color linetype linewidth ltypegen)
Creates a LWPOLYLINE (AcDb2dPolyline) object using a list of points and specified properties. The properties (parameters) are as follows:

points-list is the list of points to connect
closed is a boolean (T or nil) flag to close or leave the polyline open
layer is the string name of the layer to assign
color is the integer or vla color to assign (or acByLayer)
linetype
lineweight
ltypegen is a boolean (T or nil) flag to apply linetype generation to the object (or not)

(DSX-AddText string point justification stylename height widthfactor rotation layername color)
Creates TEXT (AcDbText) object with specified properties: string is the string value of the text. point is the insertion point, which is a point list value. stylename is the style name, which is a string value. height is the actual height (not scale), which is a real number. widthfactor is a real number value. rotation is the rotation angle in degrees (not radians), which is also a real number. layername is a string value and must be defined, otherwise the text is put on layer "0" by default or the active layer. color is an integer value for the color number, use acBylayer for default.

Example:

(DSX-AddText "THE DOG" pt1 "MC" "Standard" 0.125 1.0 90 "Text" acByLayer)

(DSX-AddPolygon ...)
(DSX-AddPoint point layername)
Creates a POINT (AcDbPoint) object at the specified point location, on the specified layer.

(DSX-AddEllipse ...)
(DSX-AddEllipseArc1 ...)
(DSX-AddEllipseArc2 ...)
(DSX-AddSolid ...)
(DSX-AddRectangle point1 point2 layer color linetype)
More coming soon...
Layer Functions
(DSX-AddLayer name color linetype lineweight plottable current)
Creates a new layer if the layer does not exist. If layer is created, returns name as result. If layer already exists, simply returns name as result. If current is non-nil, the layer is set active. Color is either an enumeration or integer. Linetype is a string. Lineweight is an enumeration or integer. Plottable is T, :vlax-true or something non-nil. If set to :vlax-false, defines layer to not plot.

(DSX-LayerTable)
Returns vla-object to layers collection of active drawing document.

(DSX-LayActive name)
Sets layer name active, if defined.

(DSX-Layer-Frozen-p name)
Verifies if layer name is frozen. Returns T (is frozen) or nil (not frozen or not defined).

(DSX-ListLayers-Frozen)
Returns a list of layer names that are currently frozen in the current drawing. Returns nil if no layers are frozen.

String Manipulation Functions
(DSX-String->List string char)
Parses a string into a list of substrings (words) using the specified delimiter character char to define the breakpoints in the given string. If no instances of the delimiter char exist in the string, the string itself is returned unchanged. For example (DSX-String->List "THE DOG RAN" " ") would return ("THE" "DOG" RAN").

(DSX-List->String list char)
Assembles a list of characters into a single string result using the specified delimiter char in between each character or substring being assembled. For example (DSX-List->String '("A" "B" "C") ",") would return "A,B,C".

More coming soon...
Selection Set Manipulation
(SSINTER pickset1 pickset2)
Returns the Boolean intersection of common entities found in both selection sets (pickset1 and pickset2).

(SSUNION pickset1 pickset2)
Returns the Boolean union of combined entities from both selection sets.

(SSDIFF pickset1 pickset2)
Returns a selection set of entities in pickset1 that are NOT also in pickset2.

(SSTYP pickset entity-type)
Returns subset of selection set of only those entities that are of the same type as entity-type. For example, to fetch circle objects from a selection named "myset" you could use (SSTYP myset "CIRCLE")

(SSNOT pickset dxf-field dxf-value)
Returns subset of selection of all entities that do not match the criteria specified by dxf-field (DXF number code) and the corresponding dxf-value (e.g. "CIRCLE"). For example, to return all entities excluding text entities, you could use (SSNot myset 0 "TEXT").

(SSNOTList pickset dxf-field dxf-values-list)
Returns a subset of selection set of only those items that are not members of the criteria list. In this case, the dxf-field is the DXF number code (eg. 0 is entity-type), and dxf-values-list is a list of entity types that you would not want returned. To exclude circle and arc entities from selection set "myset", you could use (SSNotList myset 0 '("ARC" "CIRCLE")).

(SSLAY pickset layername)
Returns a new selection of only those objects within a given selection set pickset that are assigned to the specified layer layername. Otherwise, returns nil.

(SSCOLOR pickset colornumber)
Returns a new selection of only those objects within a given selection set pickset that are assigned the specified color colornumber (integer value). Returns matching objects regardless of whether they are the matching color by virtue of ByLayer assignment or are overriden with a specific (matching) color.

More coming soon...
Microsoft® Office® Interfaces (97,2000,XP)
Open dsx-api-excel.lsp to view source code and make your own notes!

(DSX-Open-Excel-New show)
Opens Excel© with a new spreadsheet document. If show is not nil, the Excel application is shown on the users desktop normally. If show is nil, the Excel session is hidden (only available in the processes list in Task Manager).

(DSX-Open-Excel-Exist filename show)
Opens Excel and requests for spreadsheet file filename to be opened. If show is not nil, the Excel application is shown on the users desktop normally. If show is nil, the Excel session is hidden (only available in the processes list in Task Manager).

(DSX-Excel-Get-ActiveWorksheet appsession)
Returns vla-object to active worksheet in active Excel application session object appsession.

(DSX-Excel-Put-ColumnList values startingrow startingcolumn)
Inserts data from list values into spreadsheet currently opened via (dsx-open-excel-new) or (dsx-open-excel-exist). Inserts list in a top-down order beginning at row startingrow and column and incrementing down to the next cell (row) for each remaining value in the list.

For example, (DSX-Excel-Put-ColumnList '("A" "B" "C") 1 2) puts members into cells (1,B) (2,B) (3,B) respectively in the active spreadsheet document.

(DSX-Excel-Put-RowList values startingcolumn row)
Inserts data from list values into spreadsheet currently opened via (dsx-open-excel-new) or (dsx-open-excel-exist). Inserts list in a left-to-right order in row beginning in column startingcolumn and stepping over to the next cell (column) for each remaining list value.

For example, (DSX-Excel-Put-RowList '("A" "B" "C") 2 1) puts members into cells (1,B) (1,C) (1,D) respectively in the active spreadsheet document.

(DSX-Excel-Put-CellColor row column color)
Applies color to background of specified cell in active worksheet (Excel). All parameters are integer values.

(DSX-Excel-Put-RowCellsColor startrow startcolumn columns color)
Applies color to background of specifed cells within a defined row within the active worksheet (Excel). All parameters are integer values. Begins applying color change at row startrow, column startcolumn and repeats for the number of columns stated.

(DSX-Excel-Put-ColumnCellsColor)
(DSX-Excel-Get-Cell)
(DSX-Excel-Get-CellValue)
(DSX-Excel-Get-RowValues)
(DSX-Excel-Get-ColumnValues)
(DSX-Excel-GetRangeValues-ByCols startrow startcolumn num-rows num-columns)
Returns an array of cell values as a nested column-based list of lists starting with cell at (startrow, startcolumn) and ending at an offset of rows (num-rows) and columns (num-columns).

For example, (DSX-Excel-GetRangeValues-ByCols 1 1 5 10) get range values from 1A to 5J where each sublist is one column.

(DSX-Excel-GetRangeValues-ByRows startrow startcolumn num-rows num-columns)
Returns an array of cell values as a nested row-based list of lists starting with cell at (startrow, startcolumn) and ending at an offset of rows (num-rows) and columns (num-columns).

For example, (DSX-Excel-GetRangeValues-ByRows 1 1 5 10) get range values from 1A to 5J where each sublist is one row.

More coming soon...
Utility Functions
(dsx-princ message)
Debug princ function that displays string message only if $DBG is non-nil. The function (dsx-debug-enabled) returns T or nil as a test function if desired.

Example: (dsx-princ "\nThis is a debugging message only.") If $DBG is non-nil, the string is displayed, otherwise it is not.

(dsx-debug-enabled)
Returns T if debugging/diagnostics are enabled, otherwise returns nil. Helps to use for multiple (princ) calls instead of using multiple (dsx-princ) calls.

Example: (if (dsx-debug-enabled) (progn (princ "1") (princ "2") (princ "3")...)) instead of (dsx-princ "1")(dsx-princ "2")(dsx-princ "3")

(DSX-Vsave (varnames))
Defines a global list of paired sublists, each containing the specified system variable name and its related current setting value. This list (G$VARS) is saved until restored and cleared by the DSX-Vrestore function call.

(DSX-Vrestore)
Reads global list of system variables and their respective settings (G$VARS) saved previously using DSX-Vsave, and restores them to the saved settings. Following this process, it then clears the global list from memory (sets it to nil).

(DSX-MakeObject ename-or-object)
Returns a vla-object from a specified vla-object or ename symbol value. Ensures functions that expect vla-object input are properly referencing the entity/object.

(DSX-RegSet regkey value)
Defines or updates registry with string value provided. Nested or sub-level registry keys must be defined as double-backslashes (e.g. "MyRegistryKeys\\RegKey1").

(DSX-RegGet regkey default)
Returns the current registry key value if found. If not found, the registry key is defined and set to the given default value, which is then returned as the result.

(DSX-DimVar 'symbol expression)
Validates quoted global symbol to return current value. If symbol is not defined (evaluates to nil), it is defined and assigned the value resulting from expression. Example: (ASW-DimVar 'G$MYVAR '(1 2 3)) would either return the current value of global symbol G$MYVAR or define G$MYVAR as list (1 2 3) and return it as the result.

(DSX-PtOff point x-value y-value)
Returns a new point list by applying x and y offset distance values to specified point.

(DSX-UndoBegin)
Defines an UNDO marker beginning in the current drawing. This is used to start a mark before performing multiple operations, and then ending the operations with a call to DSX-UndoEnd to close the UNDO group as one operation. This enables a single U (undo) to undo the entire collection of operations back to the initial (DSX-UndoBegin) call.

(DSX-UndoEnd)
Closes an open UNDO marker to enable single U (undo) reversal of multiple operations performed since the last (DSX-UndoBegin) call.

(DSX-Delete objects)
Deletes (erases) an entity, a vla-object or a selection set (pickset) without having to convert or iterate first. Can be used to easily delete objects without having to convert them or worry about being the result of (entsel) or (ssget) either.

(DSX-HighLight object mode)
Toggles highlighting on or off on given objects. object may be an ename, vla-object or a selection set (pickset). Mode is T (or non-nil) for "on", or nil for "off".

(DSX-Collect ename)
Returns a selection set (pickset) of all objects in the current drawing that were created after the occurence of ename in the drawing database. In most cases, you would set ename to an arbitrary entity via (entlast) prior to performing multiple entity operations that create new entites. Then you would collect those new entities by using this function with the initial arbitrary entity as the marker. The result is a pickset or nil.

(DSX-PurgeAllDocs)
Performs complete PURGE on all currently opened drawings.

(DSX-AuditAllDocs)
Performs AUDIT with data recovery enabled on all currently opened drawings.

(DSX-SaveAllDocs)
Performs QSAVE on all currently opened drawings.

(DSX-ZoomExtents)
Zooms to current drawing extents.

(DSX-ZoomAll)
Zooms to ALL display.

(DSX-ZoomPrevious)
Zooms to previous display if any.

(DSX-ZoomWindow point1 point2)
Zooms current display to specified window based upon provided points point1 and point2.

(DSX-ZoomIn)
Zooms current display in 2x

(DSX-ZoomOut)
Zooms current display out .5x

Collection Objects
(DSX-Table name mode)
Returns a list of member names for a given table. If mode is non-nil, each member is returned as a sub-list of its table properties in detail. For example, (DSX-Table "layer" nil) would return a list of layer names in the active drawing. Using (DSX-Table "layer" T) would return the list as sublists as if using (tblsearch "layer" name) on each member.

(DSX-TextStyles)
Returns vla-object to text styles collection in current drawing.

(DSX-LineTypes)
Returns vla-object to linetypes collection in current drawing.

(DSX-DimStyles)
Returns vla-object to dimension styles collection in current drawing.

(DSX-LayerTable)
Returns vla-object to layers collection in current drawing.

(DSX-BlockDefs)
Returns vla-object to block definitions collection in current drawing.

(DSX-PlotConfigs)
See description above.

For more information or to send feedback, send e-mail to davidmstein@yahoo.com[/php]

Jackie119119 · 发表于 2006-4-9 09:52:23

有些基本涵数没有定义，只有说明。比如DSX-MAKEOBJECT　能不能请版主再发上来

bridgewind · 发表于 2006-9-25 23:38:11

请朋友们地道些，别把一些坏代码贴上来。。。

huahuashao66 · 发表于 2007-2-5 09:34:47

好难过，我的现金和积分怎么就没了呢，

Free-Lancer · 发表于 2013-6-19 09:20:30

参数太齐全了反而用起来麻烦，有些可以用当前设置，不必弄那么多属性的

ycao · 发表于 2013-6-19 13:14:38

英文不好，这个程序主要的作用是什么呢？

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

[转贴]：DSX-API-Objects.LSP

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

本帖被以下淘专辑推荐:

相关帖子