---

Hallo zusammen,
wie zeige ich mit folgendem Code alle xdaten im gewählten sset an?
irgendwas fehlt hier noch, aber was?

Sub Kanal_Berechnung()
    ' Suchen der im vorherigen Beispiel erstellten Auswahl
    On Error GoTo Hell

   
    Dim awss As AcadSelectionSet
    Set awss = ThisDrawing.SelectionSets.Add("310")
    awss.SelectOnScreen
    Dim sset As Object
    Set sset = ThisDrawing.SelectionSets.item("310")
 

 
    ' Definieren der XDaten-Variablen zum Erfassen der XDaten-Informationen
    Dim xdataType(0 To 9) As Integer
    Dim xdata(0 To 9) As Variant
    Dim xreals3(0 To 2) As Double
    Dim xworldPos(0 To 2) As Double
    Dim xd As Variant
   
   
 
    'Dim xDataType As Variant
    'Dim xdata As Variant
   
   
    'Definieren des Indexzählers
    Dim xdi As Integer
    xdi = 0
   
    ' Durchlaufen der Objekte im Auswahlsatz
    ' und Abrufen der XDaten für das Objekt
    Dim msgstr As Variant
    Dim appName As Variant
    Dim ent As AcadEntity
    appName = "pit-cup"
    For Each ent In sset
        msgstr = ""
        xdi = 0

 
   

       
        ' Abrufen von XDatentyp und -wert für appName
        ent.GetXData appName, xdataType, xdata
       
        'Wenn die Variable xdataType nicht initialisiert wurde, dann
        ' waren keine appName-XDaten für dieses Element abrufbar
        If VarType(xdataType) <> vbEmpty Then
            For Each xd In xdata
                msgstr = msgstr & vbCrLf & xdataType(xdi) & ": " & xd
                xdi = xdi + 1
            Next xd
        End If
       
        ' Hat die Variable msgstr den Wert NULL, waren keine XDaten vorhanden
        If msgstr = "" Then msgstr = vbCrLf & "NONE"
        MsgBox appName & " xdata on " & ent.ObjectName & _
                                      ":" & vbCrLf & msgstr
    Next ent
   
   
   
Hell:
sset.Delete
Debug.Print Err.Description
Err.Clear
On Error GoTo 0

End Sub

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hi Dan,

als Ansatz ...

HTH Nancy
--

Code:

---

Sub asdf()
  On Error GoTo Hell
  Dim i%, x%, y%, s$
  Dim sset As AcadSelectionSet
  Dim entry As AcadEntity
  Dim a, b
  Set sset = ThisDrawing.SelectionSets.Add("set07")
  sset.SelectOnScreen
  For Each entry In sset
    entry.GetXData "", a, b
    If Not IsEmpty(a) Then
      For i = LBound(b) To UBound(b)
        If IsArray(b(i)) Then
          y = y + 1
          For x = LBound(b(i)) To UBound(b(i))
            s = s & i & "(" & x & ")" & ": " & b(x) & Chr(13)
          Next
        Else
        s = s & i & ": " & b(i) & Chr(13)
        End If
      Next
      MsgBox "Gesamt: " & i + 1 + y & " Arrays: " & y & Chr(13) & s
    Else
      MsgBox "NONE"
    End If
  Next entry
  sset.Delete
  Exit Sub
Hell:
  sset.Delete
  Debug.Print Error(Err)
  Err.Clear
  On Error GoTo 0
End Sub

---

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Danke Danke Danke Nancy!!!!!
Funktioniert Prima

Gruß Dan

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Arrgh,
...neeenee kann nich so richtig tun,

sorry, kleiner Lapsus ... 
dim c as variant und diesen Part ändern:

Code:

---

If IsArray(b(i)) Then
          y = y + 1
          c = b(i)
          For x = LBound(c) To UBound(c)
            s = s & i & "(" & x & ")" & ": " & c(x) & Chr(13)
          Next
        Else
        s = s & i & ": " & b(i) & Chr(13)
        End If

---

CU Nancy
--
Absolutum obsoletum (if it works, it's out of date)

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Danke nochmal,

weißt Du eventuell auch wie ich das ganze nun nach excel rüberbekomme?

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hi Dan,

ich ahnte es  , zwei Wege ...

1. Du schreibst Dir die Dinger in eine csv,
macht jetzt wohl am wenigsten Umstände, also irgendsowas:

Code:

---

Sub aaa()
  On Error GoTo Hell
  Dim i%, x%, s$
  Dim sset As AcadSelectionSet
  Dim entry As AcadEntity
  Dim a, b, c
  Set sset = ThisDrawing.SelectionSets.Add("set07")
  sset.SelectOnScreen
  Dim ff%
  ff = FreeFile
  Open "c:\temp\mydata.csv" For Output As #ff
  For Each entry In sset
    entry.GetXData "", a, b
    If Not IsEmpty(a) Then
      For i = LBound(b) To UBound(b)
        If IsArray(b(i)) Then
          c = b(i)
          s = ""
          For x = LBound(c) To UBound(c)
            s = s & c(x) & ";"
          Next
          Print #ff, s
        Else
        Print #ff, b(i)
        End If
      Next
    Else
      MsgBox "NONE"
    End If
  Next entry
  sset.Delete
  Close #ff
  Exit Sub
Hell:
  Close #ff
  sset.Delete
  Debug.Print Error(Err)
  Err.Clear
  On Error GoTo 0
End Sub

---

2. Schau Dir unter F1 mal das 'GetObject' an,
sowas müsstest Du halt einbinden und dann
(unprobiert) innerhalb der i-Schleife irgendsowas,
wobei xl mal für dein Objekt steht:

Code:

---

For i = LBound(b) To UBound(b)
  If IsArray(b(i)) Then
    xl.Sheets(1).Range(Cells(i + 1, 1), Cells(i + 1, 1 + UBound(b(i)))) = b(i)
  Else
    xl.Sheets(1).Cells(i + 1, 1) = b(i)
  End If
Next i

---

lg Nancy

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

thanks a lot Nancy 

gruß dan

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP