Manage Custom Coordinate Systems Example (VBA)
This example shows how to manage World, default, and named custom coordinate systems.
'-----------------------------------------------------------------------------
' Preconditions:
' 1. Create a VBA macro in a software product in which VBA is
' embedded.
' 2. Copy and paste this example into the Visual Basic IDE.
' 3. Add a reference to the DraftSight type library,
' install_dir\bin\dsAutomation.dll.
' 5. Start DraftSight and open a new document.
' 6. Set a breakpoint in Main() and step through the macro.
'
' Postconditions:
' 1. Inspect the Immediate Window.
' 2. A new named custom coordinate system is created, renamed, and removed.
'---------------------------------------------------------------------------
Dim dsApp As DraftSight.Application
Dim dsDoc As Document
Option Explicit
Sub Main()
'Connect to DraftSight
Set dsApp = GetObject(, "DraftSight.Application")
'Abort any command currently running in DraftSight
'to avoid nested commands
dsApp.AbortRunningCommand
'Get active
document
Set dsDoc = dsApp.GetActiveDocument()
If dsDoc Is Nothing Then
MsgBox
("There are no opened documents in DraftSight.")
Return
End If
'Get custom
coordinate system manager
Dim dsCCSMgr As
DraftSight.CustomCoordinateSystemManager
Set dsCCSMgr = dsDoc.GetCustomCoordinateSystemManager()
Call
UsageOfDefaultCustomCoordinateSystems(dsCCSMgr)
Call
UsageOfNamedCustomCoordinateSystems(dsCCSMgr)
End Sub
Sub
UsageOfDefaultCustomCoordinateSystems(dsCCSMgr As
DraftSight.CustomCoordinateSystemManager)
'Get World Coordinate System
Dim dsWorldCCS As
DraftSight.CustomCoordinateSystem
Set dsWorldCCS = dsCCSMgr.GetWorldCustomCoordinateSystem()
Debug.Print (" ")
Debug.Print ("Get WCS.")
Call
PrintCoordinateSystemParameters(dsWorldCCS)
'Get default
Bottom custom coordinate system
Dim dsBottomCCS As
DraftSight.CustomCoordinateSystem
Set dsBottomCCS = dsCCSMgr.GetDefaultCustomCoordinateSystem(dsDefaultCustomCoordinateSystem_e.dsDefaultCustomCoordinateSystem_Bottom)
Debug.Print (" ")
Debug.Print ("Get default bottom
CCS.")
Call
PrintCoordinateSystemParameters(dsBottomCCS)
'Activate default
bottom custom coordinate system
dsBottomCCS.Activate
'Get previous CCS;
it should be WCS.
Dim dsPreviousCCS As
DraftSight.CustomCoordinateSystem
Set dsPreviousCCS = dsCCSMgr.GetPreviousCustomCoordinateSystem()
Debug.Print (" ")
Debug.Print ("Get previous CCS.")
Call
PrintCoordinateSystemParameters(dsPreviousCCS)
'Get active CCS; it should be
bottom CCS.
Dim dsActiveCCS As
DraftSight.CustomCoordinateSystem
Set dsActiveCCS = dsCCSMgr.GetActiveCustomCoordinateSystem()
Debug.Print (" ")
Debug.Print ("Get active CCS.")
Call
PrintCoordinateSystemParameters(dsActiveCCS)
'The active custom
coordinate system can be modified
'Change origin of active custom
coordinate system
Dim originX As Double
originX = 2
Dim originY As Double
originY = 3
Dim originZ As Double
originZ = 1
dsCCSMgr.SetActiveCustomCoordinateSystemOrigin
originX, originY, originZ
Debug.Print (" ")
Debug.Print ("Origin of active CCS
has been changed.")
Call
PrintCoordinateSystemParameters(dsActiveCCS)
'Align custom
coordinate system by entity
Call AlignActiveCCSByEntity(dsCCSMgr)
Debug.Print (" ")
Debug.Print ("The active CCS has been
aligned by line entity.")
Call
PrintCoordinateSystemParameters(dsActiveCCS)
End Sub
Sub AlignActiveCCSByEntity(dsCCSMgr As
DraftSight.CustomCoordinateSystemManager)
'Get model space
Dim dsModel As DraftSight.Model
Set dsModel = dsDoc.GetModel()
'Get sketch
manager
Dim dsSketchMgr As
DraftSight.SketchManager
Set dsSketchMgr = dsModel.GetSketchManager()
'Draw a line
entity
Dim startPoint(0 To 2) As Double
startPoint(0) = 5
startPoint(1) = 5
startPoint(2) = 0
Dim endPoint(0 To 2) As Double
endPoint(0) = 12
endPoint(1) = 15
endPoint(2) = 0
Dim dsLine As DraftSight.Line
Set dsLine = dsSketchMgr.InsertLine(startPoint(0),
startPoint(1), startPoint(2), endPoint(0), endPoint(1), endPoint(2))
'Align active CCS
by the created line entity
dsCCSMgr.AlignActiveCustomCoordinateSystemByEntity
dsLine, startPoint
End Sub
Sub
UsageOfNamedCustomCoordinateSystems(dsCCSMgr As
DraftSight.CustomCoordinateSystemManager)
'Get view manager
Dim dsViewManager As
DraftSight.ViewManager
Set dsViewManager = dsDoc.GetViewManager()
'Set isometric
view
dsViewManager.SetPredefinedView (dsPredefinedView_e.dsPredefinedView_SWIsometric)
'Zoom extents
dsApp.Zoom
dsZoomRange_e.dsZoomRange_Fit, Nothing, Nothing
'Create a new
named CCS by saving the active view as new CCS
Dim name As String
name = "newCCS"
Dim dsNewCCS As
DraftSight.CustomCoordinateSystem
Dim saveViewResult As
dsCreateObjectResult_e
saveViewResult = dsCCSMgr.SaveActiveViewAs(name,
dsNewCCS)
Debug.Print (" ")
Debug.Print ("New named CCS has been
created by saving active view as new CCS.")
Call
PrintCoordinateSystemParameters(dsNewCCS)
'Rename new CCS
Dim newName As String
newName = name & "_Changed"
If RenameCCS(dsNewCCS, newName) Then
Debug.Print
(" ")
Debug.Print
("The CCS has been renamed.")
Call PrintCoordinateSystemParameters(dsNewCCS)
'Print named CCS list
Call
PrintNamedCCSList(dsCCSMgr)
'Remove the created CCS
dsCCSMgr.RemoveCustomCoordinateSystem
(newName)
'Print named CCS list
Call
PrintNamedCCSList(dsCCSMgr)
End If
End Sub
Sub PrintNamedCCSList(dsCCSMgr As
DraftSight.CustomCoordinateSystemManager)
Dim namedCCSObj As Variant
namedCCSObj = dsCCSMgr.GetNamedCustomCoordinateSystemList
Dim i As Long
If IsEmpty(namedCCSObj) Then
Debug.Print
(" ")
Debug.Print
("There are no named custom coordinate systems.")
Else
Debug.Print
(" ")
Debug.Print
("Named custom coordinate systems:")
For i = 0 To
UBound(namedCCSObj)
Debug.Print (namedCCSObj(i))
Next
End If
End Sub
Function RenameCCS(dsNewCCS As
DraftSight.CustomCoordinateSystem, newName As String)
Dim renameResult As
dsCreateObjectResult_e
renameResult = dsNewCCS.Rename(newName)
If dsCreateObjectResult_Success <>
renameResult Then
MsgBox
("Failed to rename custom coordinate system. New name should be " + newName + "
Renaming result: " + renameResult)
RenameCCS =
False
End If
RenameCCS = True
End Function
Sub
PrintCoordinateSystemParameters(dsCustomCoordinateSystem As
DraftSight.CustomCoordinateSystem)
Debug.Print ("Custom Coordinate
System Parameters:")
Debug.Print ("Name
= " & dsCustomCoordinateSystem.GetName())
Dim isDefault As
Boolean
Dim defaultFlag As
dsDefaultCustomCoordinateSystem_e
dsCustomCoordinateSystem.GetDefaultCustomCoordinateSystemFlag
isDefault, defaultFlag
Debug.Print ("IsDefault = " &
isDefault)
Debug.Print ("DefaultCustomCoordinateSystemFlag
= " & defaultFlag)
Dim x As Double, y
As Double, z As Double
dsCustomCoordinateSystem.GetOrigin
x, y, z
Debug.Print ("Origin: " & x & ", " &
y & ", " & z)
dsCustomCoordinateSystem.GetXAxisDirection x, y, z
Debug.Print ("X-Axis Direction: " & x
& ", " & y & ", " & z)
dsCustomCoordinateSystem.GetYAxisDirection x, y, z
Debug.Print ("Y-Axis Direction: " & x
& ", " & y & ", " & z)
dsCustomCoordinateSystem.GetZAxisDirection x, y, z
Debug.Print ("Z-Axis Direction: " & x
& ", " & y & ", " & z)
End Sub