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