Insert Hatch by Entities or Internal Points Example (VBA)

This example shows how to insert a Hatch either by selecting sketch entities that form the Hatch boundary or by selecting internal points of enclosed areas of a drawing.

'-----------------------------------------------------------------------------
' 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 drawing document with sketch entities.
' 5. Start debugging the project.
'
' In the DraftSight command window, specify how the Hatch should be inserted:
'    1. Type Entities.
'    2. Select the sketch entities that form the boundary of the area to be hatched.
'    3. Press Enter.
'    -or-
'    1. Type InternalPoints.
'    2. Select three points that are in enclosed areas of the drawing.
'
' Postconditions: A Hatch is inserted, and the drawing document
' is zoomed to fit.
'----------------------------------------------------------------
Option Explicit
Dim dsApp As DraftSight.Application
Dim dsDoc As DraftSight.Document

Sub Main()
    'Connect to DraftSight
    Set dsApp = GetObject(, "DraftSight.Application")

    'Get active document
    Set dsDoc = dsApp.GetActiveDocument()
    If dsDoc Is Nothing Then
        MsgBox ("There are no open documents in DraftSight.")
        Return
    End If

    'Abort any command currently running in DraftSight
    'to avoid nested commands
    dsApp.AbortRunningCommand

    'Get model space
    Dim dsModel As DraftSight.Model
    Set dsModel = dsDoc.GetModel()

    'Get sketch manager
    Dim dsSketchMgr As DraftSight.SketchManager
    Set dsSketchMgr = dsModel.GetSketchManager()

    'Get command message object
    Dim dsCommandMessage As DraftSight.CommandMessage
    Set dsCommandMessage = dsApp.GetCommandMessage()

    'Display a prompt at the command line to create Hatch by entities or by internal points
    Dim keywords(0 To 2) As String
    keywords(0) = "Entities"
    keywords(1) = "InternalPoints"
    Dim selectedKeyword As String
    selectedKeyword = ""
    Dim promptResult As Boolean
    promptResult = dsCommandMessage.PromptForKeyword("Insert Hatch by:", keywords, keywords(0), selectedKeyword)
   

    If promptResult Then
        'The user selected "By Entities" option
        If selectedKeyword = "_" + UCase(keywords(0)) Then
            Dim selectedEntities() As Object
            selectedEntities = SelectEntities(dsCommandMessage)

            Call InsertHatchByEntities(dsSketchMgr, selectedEntities)
        End If

        'The user selected "By Internal Points" option
        If selectedKeyword = "_" + UCase(keywords(1)) Then
            'Select three internal points
            Dim pointsCount As Integer
            pointsCount = 3

            dsCommandMessage.PrintLine ("Select three internal points for a Hatch")

            Dim internalPoints() As Double
            internalPoints = SelectPoints(dsCommandMessage, pointsCount)

            Call InsertHatchByInternalPoints(dsSketchMgr, internalPoints)
        End If
    End If
End Sub

Sub InsertHatchByInternalPoints(dsSketchMgr As DraftSight.SketchManager, internalPoints() As Double)
    'Hatch parameters
    Dim patternName As String
    patternName = "ANSI31"
    Dim patternScale As Double
    patternScale = 1
    Dim patternAngle As Double
    patternAngle = 0

    'Insert Hatch
    Dim dsHatch As DraftSight.Hatch
    Set dsHatch = dsSketchMgr.InsertHatchByInternalPoints(internalPoints, patternName, patternScale, patternAngle)
    If Not dsHatch Is Nothing Then
        'Change color of Hatch
        Dim dsColor As DraftSight.Color
        Set dsColor = dsHatch.Color
        dsColor.SetNamedColor (dsNamedColor_e.dsNamedColor_Green)
        dsHatch.Color = dsColor

        'Zoom to fit
        dsApp.Zoom dsZoomRange_e.dsZoomRange_Fit, Nothing, Nothing
    Else
        MsgBox ("Hatch entity was not added to the current drawing.")
    End If
End Sub

Function SelectPoints(dsCommandMessage As DraftSight.CommandMessage, internalPointsCount As Integer) As Double()
    Dim internalPoints(0 To 5) As Double

    'Run prompt for point
    Dim x As Double, y As Double, z As Double
    Dim i As Long
    For i = 0 To 2
        If dsCommandMessage.PromptForPoint("Specify internal point", x, y, z) Then
            internalPoints(2 * i) = x
            internalPoints(2 * i + 1) = y
        End If
    Next

    SelectPoints = internalPoints
End Function

Sub InsertHatchByEntities(dsSketchMgr As DraftSight.SketchManager, dsEntities() As Object)
    'Hatch parameters
    Dim patternName As String
    patternName = "GRASS"
    Dim patternScale As Double
    patternScale = 1
    Dim patternAngle As Double
    patternAngle = 0

    'Insert Hatch
    Dim dsHatch As DraftSight.Hatch
    Set dsHatch = dsSketchMgr.InsertHatchByEntities(dsEntities, patternName, patternScale, patternAngle)
    If Not dsHatch Is Nothing Then
        'Change color of Hatch
        Dim dsColor As Color
        Set dsColor = dsHatch.Color
        dsColor.SetNamedColor (dsNamedColor_e.dsNamedColor_Blue)
        dsHatch.Color = dsColor

        'Zoom to fit
        dsApp.Zoom dsZoomRange_e.dsZoomRange_Fit, Nothing, Nothing
    Else
        MsgBox ("Hatch entity was not added to the current drawing.")
    End If
End Sub

Function SelectEntities(dsCommandMessage As DraftSight.CommandMessage) As Object()
    Dim selectedEntities() As Object

    'Prompt for multiple selection of entities
    If dsCommandMessage.PromptForSelection(False, "Specify entities", "It is not an entity") Then
        'Get selection manager
        Dim dsSelectionMgr As DraftSight.SelectionManager
        Set dsSelectionMgr = dsDoc.GetSelectionManager()

        'Get count of selected entities
        Dim selectionType As dsSelectionSetType_e
        selectionType = dsSelectionSetType_e.dsSelectionSetType_Previous
        Dim count As Long
        count = dsSelectionMgr.GetSelectedObjectCount(selectionType)
        Debug.Print ("Number of entities selected: " & count)
        ReDim selectedEntities(0 To count - 1) As Object
        Dim index As Long
        If count > 0 Then
            For index = 0 To (count - 1)
                Dim entityType As dsObjectType_e
                Set selectedEntities(index) = dsSelectionMgr.GetSelectedObject(selectionType, index, entityType)
            Next
        End If
    End If

    SelectEntities = selectedEntities
End Function