# Get and Set Hatch Pattern Data Example (VBA)

This example shows how to get and set Hatch pattern data.

    '--------------------------------------------------------------
    ' 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 install_dir\bin\dsAutomation.dll.
    ' 4. Make sure that C:\ProgramData\Dassault Systemes\DraftSight\Examples
    '    exists.
    ' 5. Copy all .dxf and .dwg files in this folder to a backup folder.
    ' 6. Set all .dxf and .dwg files in
    '    C:\ProgramData\Dassault Systemes\DraftSight\Examples
    '    to read/write.
    ' 7. Start DraftSight.
    ' 8. Open the Immediate window.
    ' 9. Run the macro.
    '
    ' Postconditions:
    ' 1. Each .dxf or .dwg file in
    '    C:\ProgramData\Dassault Systemes\DraftSight\Examples is
    '    filtered for Hatch patterns.
    ' 2. Hatch patterns are changed in the .dxf and .dwg files
    '    that have them.
    ' 3. Copy all .dxf and .dwg files from back up folder to
    '    C:\ProgramData\Dassault Systemes\DraftSight\Examples.
    '----------------------------------------------------------------
    Option Explicit

            Public i As Long

    Sub main()

            Dim dsApp As DraftSight.Application
            Dim drawings() As String

            'Connect to DraftSight application
            Set dsApp = GetObject(, "DraftSight.Application")
            If dsApp Is Nothing Then
                End
            End If

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

            'Check if the specified folder with drawings exists
            Dim folderName As String
            folderName = "C:\ProgramData\Dassault Systemes\DraftSight\Examples\"

            'Get drawing files in the folder
            drawings = GetDrawings(folderName)

            If LBound(drawings) >= UBound(drawings) Then
                MsgBox ("There are no DWG/DXF files in """ & folderName & """ directory.")
                End
            End If

            'Iterate through all drawings
            Dim docName As String
            Dim j As Long
            For j = 0 To (i - 1)
                docName = drawings(j)
                docName = folderName & docName
                    'Open document
                    Dim dsDoc As DraftSight.Document
                    Set dsDoc = dsApp.OpenDocument2(docName, dsDocumentOpen_Default, dsEncoding_Default)
                    If Not dsDoc Is Nothing Then

                        ' Print name of document
                        Debug.Print ("Name of document: " & dsDoc.GetPathName)

                        'Change Hatch pattern for all hatch entities in the drawing
                        ChangeHatchPattern dsDoc

                        'Save document
                        dsDoc.Save

                        'Close document
                        dsApp.CloseDocument docName, True
                    Else
                        MsgBox ("""" & docName & """ document could not be opened.")
                        Return
                    End If
            Next j
        End Sub

        Public Sub ChangeHatchPattern(ByVal dsDoc As Document)
            '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 Selection Manager
            Dim dsSelectionMgr As DraftSight.SelectionManager
            Set dsSelectionMgr = dsDoc.GetSelectionManager

            'Get selection filter
            Dim dsSelectionFilter As DraftSight.SelectionFilter
            Set dsSelectionFilter = dsSelectionMgr.GetSelectionFilter

            'Clear selection filter
            dsSelectionFilter.Clear

            'Add Hatch entity to the selection filter
            dsSelectionFilter.AddEntityType dsObjectType_e.dsHatchType

            'Activate selection filter
            dsSelectionFilter.Active = True

            'Get all layer names
            Dim layerNames As Variant
            layerNames = GetLayers(dsDoc)

            Dim entityTypes As Variant
            Dim entityObjects As Variant
            Dim entityItem As Variant

            'Get Hatch entities
            dsSketchMgr.GetEntities dsSelectionFilter, layerNames, entityTypes, entityObjects

            If Not IsArray(entityObjects) Then
                Debug.Print ("   Document does not have Hatch patterns.")
                Debug.Print (" ")
            Else
                Debug.Print ("   Document has Hatch patterns.")

                'Iterate through hatch entities
                For Each entityItem In entityObjects

                    'Cast to Hatch entity
                    Dim dsHatch As DraftSight.Hatch
                    Set dsHatch = entityItem

                    'Get hatch pattern
                    Dim patternName As String
                    patternName = ""

                    Dim angle As Double
                    angle = 0#

                    Dim hatchScale As Double
                    hatchScale = 0#

                    Dim patternType As Long
                    patternType = dsHatchPatternType_Predefined

                    Dim spacing As Double
                    spacing = 1#

                    Dim dsHatchPattern As DraftSight.HatchPattern
                    Set dsHatchPattern = dsHatch.GetHatchPattern

                    dsHatchPattern.GetHatchOrSolidData patternName, angle, hatchScale, patternType, spacing
                    Debug.Print ("   Pattern name, angle, scale, pattern types, spacing: " & patternName & ", " & angle & ", " & hatchScale & ", " & patternType & ", " & spacing)

                    'Update pattern
                    patternName = "HOUND"
                    angle = 0#
                    hatchScale = 1#
                    patternType = dsHatchPatternType_e.dsHatchPatternType_Predefined
                    spacing = 1#
                    dsHatchPattern.SetHatchOrSolidData patternName, angle, hatchScale, patternType, spacing
                Next
                Debug.Print (" ")
            End If
        End Sub

        Public Function GetLayers(ByVal dsDoc As Document) As String()
            'Get Layer Manager
            Dim dsLayerManager As DraftSight.LayerManager
            Set dsLayerManager = dsDoc.GetLayerManager

            Dim dsLayers() As Object
            dsLayers = dsLayerManager.GetLayers()

            Dim dslayerNames() As String
            Dim nbrLayers As Long
            nbrLayers = UBound(dsLayers)
            ReDim dslayerNames(nbrLayers)

            Dim index As Long

            For index = 0 To nbrLayers
                Dim dsLayer As DraftSight.Layer
                Set dsLayer = dsLayers(index)
                dslayerNames(index) = dsLayer.Name
            Next

            GetLayers = dslayerNames

        End Function

        Public Function GetDrawings(ByVal folderName As String) As String()

            'Get DWG files
            'Dim i As Long
            i = 0
            Dim dsfile As String
            Dim dsDrawings() As String

            dsfile = Dir$(folderName + "\*.dwg", vbNormal)
            ReDim dsDrawings(i)
            dsDrawings(i) = dsfile
            Do Until dsfile = vbNullString
                If dsfile <> "." Then
                    i = i + 1
                End If
                dsfile = Dir$
                ReDim Preserve dsDrawings(i)
                dsDrawings(i) = dsfile
            Loop

            'Get DXF files
            dsfile = Dir$(folderName + "\*.dxf", vbNormal)
            If dsfile <> "" Then
                dsDrawings(i) = dsfile
            Else
                ReDim Preserve dsDrawings(i - 1)
            End If
            Do Until dsfile = vbNullString
                'ReDim drawings(i)
                If dsfile <> "." Then
                        i = i + 1
                End If
                dsfile = Dir$
                If dsfile <> "" Then
                    ReDim Preserve dsDrawings(i)
                    dsDrawings(i) = dsfile
                End If
            Loop

            GetDrawings = dsDrawings

        End Function