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