I'm trying to extract a list of texts and its position to Excel but I do not knwo how to use the GetPosition()
Option Explicit
Sub Main()
Dim dsApp As DraftSight.Application
Dim dsDoc As DraftSight.Document
Dim dsModel As DraftSight.Model
Dim dsSketchManager As DraftSight.SketchManager
Dim dsViewManager As DraftSight.ViewManager
'Connect to DraftSight
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()
'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 filter to get only SimpleNotes
dsSelectionFilter.AddEntityType (dsObjectType_e.dsSimpleNoteType)
'Activate selection filter
dsSelectionFilter.Active = True
If Not dsDoc Is Nothing Then
'Get model space
Set dsModel = dsDoc.GetModel()
'Get Sketch Manager
Set dsSketchManager = dsModel.GetSketchManager()
Dim dsSheet As DraftSight.Sheet
Dim dsVarSheets As Variant
dsVarSheets = dsDoc.GetSheets
Set dsSheet = dsVarSheets(1)
If dsSheet Is Nothing Then
Return
End If
'Get View Manager
Set dsViewManager = dsDoc.GetViewManager()
'Else
End If
'Limpeza dos dados
Range("Ttexto").ClearContents
Range("Xx").ClearContents
Range("Yy").ClearContents
Range("Zz").ClearContents
Range("Llayer").ClearContents
Range("Ttexto").Cells(1, 1).value = "Texto"
Range("Xx").Cells(1, 1).value = "X"
Range("Yy").Cells(1, 1).value = "Y"
Range("Zz").Cells(1, 1).value = "Z"
Range("Llayer").Cells(1, 1).value = "Layer"
'Get all Layer names
Dim layerNames As Variant
layerNames = GetLayers(dsDoc)
Dim entityTypes As Variant
Dim entityObjects As Variant
Dim entityItem As Variant
'Get SimpleNote entities
dsSketchManager.GetEntities dsSelectionFilter, layerNames, entityTypes, entityObjects
Dim i As Integer
i = 2 'linha inicial do texto do excel
For Each entityItem In entityObjects
'If entityItem = SimpleNote Then
Dim dsSimpleNote As DraftSight.SimpleNote
Dim Pposition As Variant
Set dsSimpleNote = entityItem
'Get position of embedded object
Dim x As Double, y As Double, z As Double
Range("Ttexto").Cells(i, 1).value = dsSimpleNote.Contents
'Range("Xx").Cells(1, 1).value = dsSimpleNote.GetPosition()
Range("Yy").Cells(i, 1).value = Pposition
Range("Zz").Cells(1, 1).value = "Z"
Range("Llayer").Cells(i, 1).value = dsSimpleNote.Layer
i = i + 1
'End If
Next
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
'Get Layers
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
