Create and Change EntityGroups Example (VBA)
This example shows how to create and change EntityGroups.
'--------------------------------------------------------------
' 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.
' 4. Start DraftSight and open a document.
' 5. Run the macro.
'
' Postconditions:
' 1. Inserts entities, two lines and two circles, in the drawing.
' 2. Creates two EntityGroups:
' * SampleGroup1 contains two lines, line1 and line2.
' * SampleGroup2 contains two circles, circle1 and circle2.
' 3. Changes the color of the lines from white to red.
' 4. Removes an entity, circle1, from SampleGroup2.
' 5. Adds an entity, circle2, to SampleGroup1.
' 6. Reorders SampleGroup1.
' 7. Explodes SampleGroup2, which removes the definition
' from the drawing; however, circle1 remains as an entity
' in the drawing.
' 8. Renames SampleGroup1 and changes its description.
'
' NOTE: There are several Stop statements in the macro. Follow
' the instructions in the macro at each Stop statement.
'----------------------------------------------------------------
Option Explicit
Dim dsApp As DraftSight.Application
Dim dsDoc As DraftSight.Document
Dim dsGroup1 As DraftSight.Group
Dim dsGroup2 As DraftSight.Group
Sub main()
'Connect to DraftSight application
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 open documents in DraftSight.")
Return
End If
'Insert entities
Dim dsSketchMgr As DraftSight.SketchManager
Set dsSketchMgr = dsApp.GetActiveDocument().GetModel().GetSketchManager()
Dim line1 As DraftSight.Line
Set line1 = dsSketchMgr.InsertLine(0, 0, 0, 10, 10, 0)
Dim line2 As DraftSight.Line
Set line2 = dsSketchMgr.InsertLine(5, 0, 0, 15, 10, 0)
Dim circle1 As DraftSight.Circle
Set circle1 = dsSketchMgr.InsertCircle(5, 5, 0, 10)
Dim circle2 As DraftSight.Circle
Set circle2 = dsSketchMgr.InsertCircle(10, 5, 0, 10)
Dim EntitiesArray1(1) As DraftSight.Line
Set EntitiesArray1(0) = line1
Set EntitiesArray1(1) = line2
Dim EntitiesArray2(1) As DraftSight.Circle
Set EntitiesArray2(0) = circle1
Set EntitiesArray2(1) = circle2
Set dsGroup1 = dsDoc.CreateGroup("SampleGroup1", False, "This is my first sample group.", EntitiesArray1)
Dim dsEntities As Variant
Dim dsEntityTypes As Variant
dsEntities = dsGroup1.GetEntities(dsEntityTypes)
Debug.Print ("Size of dsEntities: " & UBound(dsEntities))
'Change color of lines from white to red
Dim dsEntityHelper As DraftSight.EntityHelper
Set dsEntityHelper = dsApp.GetEntityHelper()
Dim dsColor As DraftSight.Color
Set dsColor = dsApp.GetNamedColor(dsNamedColor_e.dsNamedColor_Red)
Dim dsEntity As Object
Dim i As Long
For i = 0 To UBound(dsEntities)
Set dsEntity = dsEntities(i)
dsEntityHelper.SetColor dsEntity, dsColor
Next
Set dsGroup2 = dsDoc.CreateGroup("SampleGroup2", False, "This is my second sample group.", EntitiesArray2)
Stop
'Type GROUP at the command window
'to verify that two EntityGroups, SampleGroup1
'and SampleGroup2, were created
'Press OK to close the dialog
'Press F5 in the IDE to continue
'Get SampleGroup2 and remove circle2
Set dsGroup2 = dsDoc.GetGroup("SampleGroup2")
If dsGroup2.HasEntity(circle2) Then
Dim index As Long
index = dsGroup2.GetIndex(circle2)
dsGroup2.RemoveEntityAt (index)
End If
'Get SampleGroup1 and add circle1 at last position
Set dsGroup1 = dsDoc.GetGroup("SampleGroup1")
Dim EntitiesArray(0) As Object
Set EntitiesArray(0) = circle1
Dim count As Long
count = dsGroup1.GetEntitiesCount()
dsGroup1.InsertEntitiesAt count, EntitiesArray
Dim newCount As Long
newCount = dsGroup1.GetEntitiesCount()
If newCount <> count + 1 Then
MsgBox ("Circle1 was not inserted.")
End If
'Move circle1 to second position (index 1)
Dim circleIndex As Long
circleIndex = dsGroup1.GetIndex(circle1)
If circleIndex <> count Then
MsgBox ("Circle1 inserted at wrong position.")
End If
dsGroup1.Reorder circleIndex, 1, 1
circleIndex = dsGroup1.GetIndex(circle1)
If circleIndex <> 1 Then
MsgBox ("Circle1 inserted at wrong position.")
End If
'Explode SampleGroup2
dsGroup2.Explode
Stop
'Type GROUP at the command window
'to verify that only SampleGroup1 exists
'Press OK to close the dialog
'Press F5 in the IDE to continue
Dim dsGroups() As DraftSight.Group
dsGroups = dsDoc.GetGroups()
Dim nbrGroups As Long
nbrGroups = UBound(dsGroups)
If nbrGroups <> 0 Then
MsgBox ("Group2 was not exploded.")
End If
'Rename SampleGroup1 and change description
dsGroup1.Rename ("SampleGroup")
dsGroup1.Description = "My sample group."
Stop
'Type GROUP at the command window
'to verify that SampleGroup1 was renamed
'to SampleGroup and its description
'changed to "My sample group"
'Press OK to close the dialog
'Press F5 in the IDE to continue
End Sub