Hot News:

Unser Angebot:

  Foren auf CAD.de (alle Foren)
  Inventor VBA
  Exportiern der Punktkoordinaten mit den Bauteilnamen

Antwort erstellen  Neues Thema erstellen
CAD.de Login | Logout | Profil | Profil bearbeiten | Registrieren | Voreinstellungen | Hilfe | Suchen

Anzeige:

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen nächster neuer Beitrag | nächster älterer Beitrag
  
Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte
Autor Thema:  Exportiern der Punktkoordinaten mit den Bauteilnamen (2005 mal gelesen)
SifiCAD
Mitglied
Konstrukteur


Sehen Sie sich das Profil von SifiCAD an!   Senden Sie eine Private Message an SifiCAD  Schreiben Sie einen Gästebucheintrag für SifiCAD

Beiträge: 27
Registriert: 25.04.2016

Revit, Rhinocerur, Auto
Cad, Solid Works, Catia,
NX Siemens, Inventor

erstellt am: 05. Okt. 2017 12:08    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities


FramegeneratorPunkte.JPG

 
Hallo liebe CAD Gemeinde,

ich habe wieder mal eine Frage bezüglich VBA. Ich habe ein Script der mir die Koordinaten aus den Punkten zu Excel rauslist. Was mir noch fehlt bei diesen Script, ist das die Ganzen Dateinamen aus den Teilen, wo die Punkte eingebaut sind, auch mit exportiert werden. Unten füge ich den Skript ein.

Die Punkte sind in verschiedenen Bauteilen eingebaut, die ich mit Framegenerator erzeugt habe. Da ich mit Inventor VBA erst angefangen habe zu arbeiten, bitte ich euch, liebe CAD Gemeinde, mir zu helfen.

Mit Vielen lieben Grüßen          

Alex

Sub ExportWorkpoints_iam()
    ' Get the active Assembly document.
    Dim AssemblyDoc As AssemblyDocument
    If ThisApplication.ActiveDocumentType = kAssemblyDocumentObject Then
        Set AssemblyDoc = ThisApplication.ActiveDocument
    Else
        MsgBox "Eine Baugruppe (*.iam) muss geöffnet bzw. aktiv sein."
        Exit Sub
    End If
   
    ' Check to see if any work points are selected.
    Dim points() As WorkPoint
    Dim pointCount As Long
    pointCount = 0
    If AssemblyDoc.SelectSet.Count > 0 Then
        ' Dimension the array so it can contain the full
        ' list of selected items.
        ReDim points(AssemblyDoc.SelectSet.Count - 1)
       
        Dim selectedObj As Object
        For Each selectedObj In AssemblyDoc.SelectSet
            If TypeOf selectedObj Is WorkPoint Then
                Set points(pointCount) = selectedObj
                pointCount = pointCount + 1
            End If
        Next
       
        ReDim Preserve points(pointCount - 1)
    End If
   
    ' Ask to see if it should operate on the selected points
    ' or all points.
    Dim getAllPoints As Boolean
    getAllPoints = True
    If pointCount > 0 Then
        Dim result As VbMsgBoxResult
        result = MsgBox("Einige Arbeitspunkte sind ausgewählt.  " & _
                "Sollen nur die ausgewählten Arbeitspunkte " & _
                "exportiert werden?  " & Chr(13) & Chr(13) & _
                "(Antwort ""Nein"" exportiert alle Arbeitspunkte)", _
                vbQuestion + vbYesNoCancel)
        If result = vbCancel Then
            Exit Sub
        End If
   
        If result = vbYes Then
            getAllPoints = False
        End If
    Else
        If MsgBox("Es sind keine Arbeitspunkte ausgewählt.  Alle Arbeitspunkte" & Chr(13) & _
                  " werden exportiert.  " & Chr(13) & Chr(13) & "Möchten Sie fortfahren?", _
                  vbQuestion + vbYesNo) = vbNo Then
            Exit Sub
        End If
    End If
   
    Dim AssemblyDef As AssemblyComponentDefinition
    Set AssemblyDef = AssemblyDoc.ComponentDefinition
    If getAllPoints Then
        ReDim points(AssemblyDef.WorkPoints.Count - 1)                  'um den Mittelpunkt auszulassen muss anstelle von -1 hier -2 stehen
       
        ' Get all of the workpoints.
        ' for skipping the first, which is the origin point, i must start with 2
        Dim i As Integer
        For i = 1 To AssemblyDef.WorkPoints.Count                      'um den Mittelpunkt auszulassen muss für anstelle von 1 hier 2 stehen
            Set points(i - 1) = AssemblyDef.WorkPoints.Item(i)          'um den Mittelpunkt auszulassen muss anstelle von -1 hier -2 stehen
        Next
    End If
   
   
   
'-----------------------------------------------------------------------
'  Abfrage Weltkoordinaten
'-----------------------------------------------------------------------
   
    Dim WeltKoorDia As VbMsgBoxResult
    WeltKoorDia = MsgBox("Wollen Sie Werte für Weltkoordinaten eingeben?  " & Chr(13) & Chr(13) & _
                "Die einzugebenden Werte entsprechen den Weltkoordinaten des Mittelpunktes " & Chr(13) & _
                "und werden zu den ausgelesenen Koordinatenwerten der Arbeitspunkte hinzuaddiert.", _
                vbQuestion + vbYesNoCancel)
    If WeltKoorDia = vbCancel Then
        Exit Sub
    End If
   
    If WeltKoorDia = vbYes Then
   
        Dim xCoordWelt As Double
        Dim yCoordWelt As Double
        Dim zCoordWelt As Double
        Dim Welt_Winkel_Wert As Double, Welt_Winkel As Double
   
        WeltKoor.Show
   
        xCoordWelt = WeltKoor.txt_x
        yCoordWelt = WeltKoor.txt_y
        zCoordWelt = WeltKoor.txt_z
           
        Welt_Winkel_Wert = WeltKoor.txt_grd
        Welt_Winkel = Welt_Winkel_Wert * 3.14159265359 / 180
           

    End If
 
   
   
'-----------------------------------------------------------------------
'  Dialog zum Erstellen der Dateien
'-----------------------------------------------------------------------
    ' Get the filename to write to.
    Dim dialog As FileDialog
    Dim Dateiname_xls As String
   
    Dateiname_xls = Left(ThisApplication.ActiveDocument.FullFileName, _
    Len(ThisApplication.ActiveDocument.FullFileName) - 4) + ".xls"
   
    Call ThisApplication.CreateFileDialog(dialog)
    With dialog
        .DialogTitle = "Ausgabedatei *.XLS-Format"
        .Filter = "Microsoft Office Excel-Datei (*.xls)|*.xls"
        .FilterIndex = 0
        .OptionsEnabled = False
        .MultiSelectEnabled = False
        .CancelError = False
        .filename = Dateiname_xls
        .ShowSave
        Dateiname_xls = .filename
    End With


'-----------------------------------------------------------------------
'  Erstellen der Excel-Datei im *.csv-Format
'-----------------------------------------------------------------------
   
    Dim filename_csv As String
   
   
    If Dateiname_xls <> "" And Len(Dateiname_xls) >= 4 Then
        Dateiname_csv = Left(Dateiname_xls, Len(Dateiname_xls) - 4) + ".csv"
       
        ' Write the work point coordinates out to a csv file.
        On Error Resume Next
        Open Dateiname_csv For Output As #1
        If Err.Number <> 0 Then
            MsgBox "Die angegebene Datei kann nicht geöffnert werden. " & _
                  "Die Datei ist eventuell durch einen anderen Prozess geöffnet."
            Exit Sub
        End If
       
        ' Get a reference to the object to do unit conversions.
        Dim uom As UnitsOfMeasure
        Set uom = AssemblyDoc.UnitsOfMeasure
       
        ' Write the points, taking into account the current default
        ' length units of the document.
        Print #1, "Bezeichnung" & "    " & _
                "X-Koordinate" & "    " & _
                "Y-Koordinate" & "    " & _
                "Z-Koordinate"
       
        For i = 0 To UBound(points)
            Dim xCoord As Double
            xCoord = uom.ConvertUnits(points(i).Point.X, _
                kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
                   
            Dim yCoord As Double
            yCoord = uom.ConvertUnits(points(i).Point.Y, _
                kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
                   
            Dim zCoord As Double
            zCoord = uom.ConvertUnits(points(i).Point.Z, _
                kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
                   
            Print #1, points(i).Name & "    " & _
                Format(Cos(Welt_Winkel) * xCoord - Sin(Welt_Winkel) * yCoord + xCoordWelt, "0.000") & "    " & _
                Format(Sin(Welt_Winkel) * xCoord + Cos(Welt_Winkel) * yCoord + yCoordWelt, "0.000") & "    " & _
                Format(zCoord + zCoordWelt, "0.000")
        Next
       
        Close #1
   
    Else

        Exit Sub
       
    End If


'-----------------------------------------------------------------------
'  Erstellen der Excel-Datei im *.xls-Format
'-----------------------------------------------------------------------
    'Create a new Excel instance
    Dim oExcelApplication As Excel.Application
    Set oExcelApplication = New Excel.Application

    'create a new excel workbook
    Dim oBook As Excel.Workbook
    Set oBook = oExcelApplication.Workbooks.Add()
    Dim oSheet As Excel.WorkSheet
    Set oSheet = oBook.ActiveSheet
 
    Dim nRow As Integer
    nRow = 2

    'Spaltenüberschriften
        oSheet.Cells(1, 1) = "Bezeichnung"
        oSheet.Cells(1, 1).Font.Bold = True
       
        oSheet.Cells(1, 2) = "X-Koordinate"
        oSheet.Cells(1, 2).Font.Bold = True
       
        oSheet.Cells(1, 3) = "Y-Koordinate"
        oSheet.Cells(1, 3).Font.Bold = True
       
        oSheet.Cells(1, 4) = "Z-Koordinate"
        oSheet.Cells(1, 4).Font.Bold = True
       
    'write the coordinates into separate columns, one workpoint each row
        For i = 0 To UBound(points)
            xCoord = uom.ConvertUnits(points(i).Point.X, _
                kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
                   
            yCoord = uom.ConvertUnits(points(i).Point.Y, _
                kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
                   
            zCoord = uom.ConvertUnits(points(i).Point.Z, _
                kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
                   
       
        oSheet.Cells(nRow, 1) = points(i).Name
        oSheet.Cells(nRow, 2) = Cos(Welt_Winkel) * xCoord - Sin(Welt_Winkel) * yCoord + xCoordWelt
        oSheet.Cells(nRow, 3) = Sin(Welt_Winkel) * xCoord + Cos(Welt_Winkel) * yCoord + yCoordWelt
        oSheet.Cells(nRow, 4) = zCoord + zCoordWelt
        nRow = nRow + 1
       
        Next
   
    oSheet.Columns(1).EntireColumn.AutoFit
    oSheet.Columns(2).EntireColumn.AutoFit
    oSheet.Columns(3).EntireColumn.AutoFit
    oSheet.Columns(4).EntireColumn.AutoFit
   
    oSheet.Cells(nRow + 1, 1) = ThisApplication.ActiveDocument.FullFileName
     
     
    On Error Resume Next
    oBook.SaveAs (Dateiname_xls)
    oBook.Close
    Set oBook = Nothing
    Set oSheet = Nothing
    Set oExcelApplication = Nothing
 

'-----------------------------------------------------------------------
       
       
    MsgBox "Das Schreiben der Dateien ist beendet. " & Chr(13) & Chr(13) & _
          "Die Daten befinden sich in den beiden Dateien: " & Chr(13) & Chr(13) & _
          "- """ & Dateiname_xls & "" & Chr(13) & _
          "- """ & Dateiname_csv & """"

'Microsoft Excel starten und ein bestehendes
' Worksheet-Objekt öffnen.
    Set ExcelWorkSheet = GetObject("Dateiname_xls")

End Sub

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

Tacker
Mitglied
TZ, Tech. MB, Softwareentwickler


Sehen Sie sich das Profil von Tacker an!   Senden Sie eine Private Message an Tacker  Schreiben Sie einen Gästebucheintrag für Tacker

Beiträge: 175
Registriert: 23.09.2010

IV 2017 Pro
i7-7700K 4x4.2GHz
32GB DDR4-2400
GTX 1060 6GB DDR5

erstellt am: 09. Okt. 2017 13:49    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für SifiCAD 10 Unities + Antwort hilfreich

Hallo 

Naja, Name = selectedObj.ContainingOccurrence.Name

So kommst an den Namen. Achtung! Es gibt nicht immer ein ContainingOccurrence, ergo sollte da noch eine IF Abfrage rein ob der Punkt auch wirklich verknüpft ist.

If not selectedObj.ContainingOccurrence is Nothing then
Name = selectedObj.ContainingOccurrence.Name
Else
Name = ""
End if

Wie und wo du den Wert dann in deine Excel Datenbank haben willst musst du selbst wissen.

BTW, das hätte man recht einfach herausgefunden wenn man beim Debugging im Lokal Fenster sich das Objekt genauer angesehen hätte.
Debugging: im VBA-Editor: Ansicht→Lokal Fenster aktivieren
Haltemarken an zu untersuchenden Momenten setzen (graue Spalte neben dem Code oder per F9)
Schrittweise Code durchlaufen lassen F8

Im Lokal Fenster siehst du dann die wie das Fenster schon sagt: Lokalen Objekte von einfachen Variablen wie ein Integer bis hin zur kompletten Inventor Application kannst da alles sehen (vorausgesetzt du hast sie definiert)

MFG

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

Ticky72
Mitglied



Sehen Sie sich das Profil von Ticky72 an!   Senden Sie eine Private Message an Ticky72  Schreiben Sie einen Gästebucheintrag für Ticky72

Beiträge: 35
Registriert: 17.02.2016

Inventor 2019
Win7 64Bit

erstellt am: 09. Okt. 2017 16:20    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für SifiCAD 10 Unities + Antwort hilfreich

Hi Alex,

du kannst dir zum Thema Lokal Fenster einfach mal dieses Video anschauen:

https://www.youtube.com/watch?v=2ZnR8xBMBpg

Schöne Grüße
Helmut

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

SifiCAD
Mitglied
Konstrukteur


Sehen Sie sich das Profil von SifiCAD an!   Senden Sie eine Private Message an SifiCAD  Schreiben Sie einen Gästebucheintrag für SifiCAD

Beiträge: 27
Registriert: 25.04.2016

Revit, Rhinocerur, Auto
Cad, Solid Works, Catia,
NX Siemens, Inventor

erstellt am: 11. Okt. 2017 17:25    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Hallo Tacker,

vielen Dank für den Tipp. Werde mal morgen ausprobieren.

Schöne Grüße

Alex  

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

FroSte
Mitglied
Bauingenieur


Sehen Sie sich das Profil von FroSte an!   Senden Sie eine Private Message an FroSte  Schreiben Sie einen Gästebucheintrag für FroSte

Beiträge: 20
Registriert: 09.06.2009

Inventor 2021

erstellt am: 26. Okt. 2017 15:24    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für SifiCAD 10 Unities + Antwort hilfreich

Hallo zusammen,

ich habe mich der Thematik von meinem Kollegen Alex mal angenommen.
Allerdings bin ich auch noch dabei mich in VBA einzuarbeiten.

Den ursprünglichen Code habe ich erweitert. Soweit funktioniert das auch. Aber ich würde gerne den Namen des Bauteils entsprechend zu jedem Arbeitspunkt abspeichern.
Deshalb habe ich dem "Bauteilnamen" einen Index gegeben und möchte ihn mit "PointCount" hochzählen.

Aber das funktioniert so nicht. Ich bekomme eine Fehlermeldung, dass der Index außerhalb des Bereichs liegt.
"Run-time errror '9'
Subscribt out of range"


Sub test2()

    Dim AssemblyDoc As AssemblyDocument
    If ThisApplication.ActiveDocumentType = kAssemblyDocumentObject Then
        Set AssemblyDoc = ThisApplication.ActiveDocument
    Else
        MsgBox "Eine Baugruppe (*.iam) muss geöffnet bzw. aktiv sein."
        Exit Sub
    End If
   
    ' Prüfen, ob Arbeitspunkte ausgewählt sind
    Dim points() As WorkPoint
   
    Dim PointCount As Long
    PointCount = 0
    If AssemblyDoc.SelectSet.Count > 0 Then
        ReDim points(AssemblyDoc.SelectSet.Count - 1)
       
        Dim selectedObj As Object
        For Each selectedObj In AssemblyDoc.SelectSet
            If TypeOf selectedObj Is WorkPoint Then
               
                Dim Bauteilname() As String
                Bauteilname(PointCount) = selectedObj.ContainingOccurrence.Name
                    If Not selectedObj.ContainingOccurrence Is Nothing Then
                        Bauteilname(PointCount) = selectedObj.ContainingOccurrence.Name
                    Else
                        Bauteilname(PointCount) = ""
                    End If
               
                Set points(PointCount) = selectedObj
                PointCount = PointCount + 1
            End If
        Next
       
        ReDim Preserve points(PointCount - 1)
    End If
End Sub


Was mach ich denn falsch? 
Was muss ich denn anders machen? 

Vielen Dank schon mal für eure Antworten. 

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

Tacker
Mitglied
TZ, Tech. MB, Softwareentwickler


Sehen Sie sich das Profil von Tacker  an!   Senden Sie eine Private Message an Tacker  Schreiben Sie einen Gästebucheintrag für Tacker

Beiträge: 175
Registriert: 23.09.2010

IV 2017 Pro
i7-7700K 4x4.2GHz
32GB DDR4-2400
GTX 1060 6GB DDR5

erstellt am: 26. Okt. 2017 17:48    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für SifiCAD 10 Unities + Antwort hilfreich

Hallo,

Soweit schon sehr gut, jedoch muss man beachten dass Arrays zwar dynamisch sein können, jedoch immer in ihrer Größe definiert werden müssen.
Werden sie bei der Initialisierung festgelegt sind sie in der Größe fest. Wird die Größe nicht festgelegt können sie beliebig oft in der Größe verändert werden mithilfe von Redim. In deinem Fall ist das Array zwar initialisiert, jedoch ohne Größe.

Die Arrays werden Anfang der Schleife auf 0 definiert weil PointCount = 0, anschließend erhöht sich der Counter und die Arrays mit ihm.
Die Werte innerhalb des Arrays werden behalten (da sie größer werden funktioniert das).

Preserve ist bequem, bei größeren Geschichten allerdings lässt die Performance deutlich zu wünschen übrig. Müsstest mal testen aber denke bei kleineren Sachen geht das schon.


Code:

Sub test2()

    Dim AssemblyDoc As AssemblyDocument
    If ThisApplication.ActiveDocumentType = kAssemblyDocumentObject Then
        Set AssemblyDoc = ThisApplication.ActiveDocument
    Else
        MsgBox "Eine Baugruppe (*.iam) muss geöffnet bzw. aktiv sein."
        Exit Sub
    End If
   
    ' Prüfen, ob Arbeitspunkte ausgewählt sind
    Dim points() As WorkPoint
   
    Dim PointCount As Long
    PointCount = 0
    If AssemblyDoc.SelectSet.Count > 0 Then

        Dim Bauteilname() As String

        Dim selectedObj As Object
        For Each selectedObj In AssemblyDoc.SelectSet
            If TypeOf selectedObj Is WorkPoint Then
           
                ReDim Preserve Bauteilname(PointCount)
                ReDim Preserve points(PointCount)
               
                Bauteilname(PointCount) = selectedObj.ContainingOccurrence.Name
               
                If Not selectedObj.ContainingOccurrence Is Nothing Then
                    Bauteilname(PointCount) = selectedObj.ContainingOccurrence.Name
                Else
                    Bauteilname(PointCount) = ""
                End If
               
                Set points(PointCount) = selectedObj
                PointCount = PointCount + 1
               
            End If
        Next
       
       
    End If
End Sub



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

FroSte
Mitglied
Bauingenieur


Sehen Sie sich das Profil von FroSte an!   Senden Sie eine Private Message an FroSte  Schreiben Sie einen Gästebucheintrag für FroSte

Beiträge: 20
Registriert: 09.06.2009

Inventor 2021

erstellt am: 27. Okt. 2017 16:41    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für SifiCAD 10 Unities + Antwort hilfreich

Hallo,

vielen Dank für die schnelle Antwort mit der Erklärung und der Code-Unterstützung.
Das hat so weit sehr gut geklappt.

Jetzt habe ich aber noch ein anderes Problem, bei dem ich nicht so recht weiter kommen.

Auch hier wäre eine Unterstüzung schön.

Mit dem Code unten möchte ich eigentlich alle Arbeitspunkte auslesen. Allerdings lese ich so nur Arbeitspunkte in der Baugruppe und nicht zusätzlich die Arbeitspunkte in den Bauteilen innerhalb der Baugruppe aus.
Wie komm ich denn mit "getAllPoints" auch in die bauteile in der Baugruppe?
Ich find einfach keine Lösung.

Vielen Dank schon mal für die Unterstützung.


Sub Test4()
    ' Verwende das aktive Dokument.
    Dim AssemblyDoc As AssemblyDocument
    If ThisApplication.ActiveDocumentType = kAssemblyDocumentObject Then
        Set AssemblyDoc = ThisApplication.ActiveDocument
    Else
        MsgBox "Eine Baugruppe (*.iam) muss geöffnet bzw. aktiv sein."
        Exit Sub
    End If
   
    Dim getAllPoints As Boolean
    getAllPoints = True
 
    Dim AssemblyDef As AssemblyComponentDefinition
    Set AssemblyDef = AssemblyDoc.ComponentDefinition
       
    If getAllPoints Then
       
        ReDim points(AssemblyDef.WorkPoints.Count)
       
        ' Berücksichtige alle Arbeitspunte.
        Dim i As Integer
        For i = 1 To AssemblyDef.WorkPoints.Count
            Set points(i - 1) = AssemblyDef.WorkPoints.Item(i)
        Next
    End If

End Sub


p.s.: Wie funktioniert das mit der Code-Eingabe hier im Forum?

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

Tacker
Mitglied
TZ, Tech. MB, Softwareentwickler


Sehen Sie sich das Profil von Tacker  an!   Senden Sie eine Private Message an Tacker  Schreiben Sie einen Gästebucheintrag für Tacker

Beiträge: 175
Registriert: 23.09.2010

IV 2017 Pro
i7-7700K 4x4.2GHz
32GB DDR4-2400
GTX 1060 6GB DDR5

erstellt am: 28. Okt. 2017 15:18    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für SifiCAD 10 Unities + Antwort hilfreich

Moin,

Also beim Erstellen eines Beitrags gibts links neben dem Textfenster Hyperlinks die per Javascript Befehle einfügen.

https://ww3.cad.de/foren/ubb/ubbcode.html

Zum eigentlichen Problem:

Code:

Sub Initialize()

Dim oApp As Inventor.Application

Set oApp = ThisApplication

Dim oObject As Inventor.AssemblyDocument

If oApp.Documents.Count = 0 Then
    MsgBox ("Es muss eine Baugruppe oder ein Bauteil geöffnet sein.")
    Exit Sub
Else
    If oApp.Documents.VisibleDocuments.Count > 0 Then
        If oApp.ActiveDocument.DocumentType = Inventor.kAssemblyDocumentObject Then
            Set oObject = oApp.ActiveDocument
        ElseIf oApp.ActiveDocument.DocumentType = Inventor.kPartDocumentObject Then
            Set oObject = oApp.ActiveDocument
        End If
    End If
End If

If oObject Is Nothing Then
    MsgBox ("Es muss eine Baugruppe oder ein Bauteil geöffnet sein.")
End If

Call Loop_through(oObject)


End Sub

'Public points() As WorkPoint

Function Loop_through(ByVal oObject As Object) As Object

If oObject Is Nothing Then
    Loop_through = Nothing
    Exit Function
End If
Dim oComponentoccurrence As Inventor.ComponentOccurrence
Dim oBaugruppe As Boolean

If oObject.Type = Inventor.kDocumentObject Then
    If oObject.DocumentType = kAssemblyDocumentObject Then
        Call Collect_Workpoints(oObject.ComponentDefinition)
        oBaugruppe = True

    For Each oComponentoccurrence In oObject.ComponentDefinition.Occurrences
        If oComponentoccurrence.DefinitionDocumentType = Inventor.kAssemblyDocumentObject Then
            Call Collect_Workpoints(oComponentoccurrence.Definition)
            Call Loop_through(oComponentoccurrence)
        ElseIf oComponentoccurrence.DefinitionDocumentType = Inventor.kPartDocumentObject Then
            Call Collect_Workpoints(oComponentoccurrence.Definition)
        End If
    Next
Else
    Call Collect_Workpoints(oObject.ComponentDefinition)
End If
ElseIf oObject.Type = kComponentOccurrenceObject Then
    If oObject.DefinitionDocumentType = kAssemblyDocumentObject Then
        Call Collect_Workpoints(oObject.Definition)
        oBaugruppe = True
       
        For Each oComponentoccurrence In oObject.Definition.Occurrences
            If oComponentoccurrence.DefinitionDocumentType = Inventor.kAssemblyDocumentObject Then
                Call Collect_Workpoints(oComponentoccurrence.Definition)
                Call Loop_through(oComponentoccurrence)
            ElseIf oComponentoccurrence.DefinitionDocumentType = Inventor.kPartDocumentObject Then
                Call Collect_Workpoints(oComponentoccurrence.Definition)
            End If
        Next
    Else
        Call Collect_Workpoints(oObject.ComponentDefinition)
    End If
End If

End Function
Function Collect_Workpoints(ByVal oObject As Object)


Debug.Print (oObject.Document.DisplayName)
'Hier die Workpoints erfassen -> in Public Variable speichern

End Function


Das ganze ist ein bisschen aufwändiger, aber naja, hab das nur grob getestet, ich garantier da nicht für Fehler.

Die oPoints Variable musst entweder Global anlegen oder per Byref mit in die Funktionen übergeben. (Ist nicht in meinem Code drin)

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

FroSte
Mitglied
Bauingenieur


Sehen Sie sich das Profil von FroSte an!   Senden Sie eine Private Message an FroSte  Schreiben Sie einen Gästebucheintrag für FroSte

Beiträge: 20
Registriert: 09.06.2009

Inventor 2021

erstellt am: 31. Mai. 2022 14:39    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für SifiCAD 10 Unities + Antwort hilfreich

Hallo Tacker,

vielen Dank zuerst noch für Deinen Code. Leider bin ich seiner Zeit nicht mehr dazugekommen, den Code zu übernehmen und zu vervollständigen bzw. nach unseren Bedürfnissen anzupassen.
Jetzt ist das Thema aber wieder aktuell geworden und ich müsste den Code fertigstellen.
Der Code funktioniert so weit prima. Allerdings habe ich Probleme mit den Koordinaten der Arbeitspunkte in der Funktion Collect_Workpoints auszulesen.
Mir ist auch noch nicht ganz klar, wie ich die gelesenen Koordinaten in der Funktion Collect_Workpoints in eine Variable scheiben, diese übergeben und mit den abgefragten Weltkoordinaten verrechnen kann um diese dann in eine Exceldatei zu schreiben.

Hier mein ergänzter Code:

Code:

Public Sub Neu_ExportWorkpoints_iam()
   
    'Public points() As WorkPoint
   
    Dim oApp As Inventor.Application

    Set oApp = ThisApplication

    Dim oObject As Inventor.AssemblyDocument

    If oApp.Documents.Count = 0 Then
        MsgBox ("Es muss eine Baugruppe oder ein Bauteil geöffnet sein.")
        Exit Sub
    Else
        If oApp.Documents.VisibleDocuments.Count > 0 Then
            If oApp.ActiveDocument.DocumentType = Inventor.kAssemblyDocumentObject Then
                Set oObject = oApp.ActiveDocument
            ElseIf oApp.ActiveDocument.DocumentType = Inventor.kPartDocumentObject Then
                Set oObject = oApp.ActiveDocument
            End If
        End If
    End If

    If oObject Is Nothing Then
        MsgBox ("Es muss eine Baugruppe oder ein Bauteil geöffnet sein.")
    End If

'-----------------------------------------------------------------------
'   Abfrage Weltkoordinaten
'-----------------------------------------------------------------------
   
    Dim WeltKoorDia As VbMsgBoxResult
    WeltKoorDia = MsgBox("Wollen Sie Werte für Weltkoordinaten eingeben?  " & Chr(13) & Chr(13) & _
                "Die einzugebenden Werte entsprechen den Weltkoordinaten des Mittelpunktes " & Chr(13) & _
                "und werden zu den ausgelesenen Koordinatenwerten der Arbeitspunkte hinzuaddiert.", _
                vbQuestion + vbYesNoCancel)
    If WeltKoorDia = vbCancel Then
        Exit Sub
    End If
   
    If WeltKoorDia = vbYes Then
   
        Dim xCoordWelt As Double
        Dim yCoordWelt As Double
        Dim zCoordWelt As Double
        Dim Welt_Winkel_Wert As Double, Welt_Winkel As Double
   
        WeltKoor.Show
   
        xCoordWelt = WeltKoor.txt_x
        yCoordWelt = WeltKoor.txt_y
        zCoordWelt = WeltKoor.txt_z
           
        Welt_Winkel_Wert = WeltKoor.txt_grd
        Welt_Winkel = Welt_Winkel_Wert * 3.14159265359 / 180
           

    End If
  
  
'-----------------------------------------------------------------------
'   Funktionsaufruf Schleife durch Baugruppen und Bauteile
'-----------------------------------------------------------------------

    Call Loop_through(oObject)


End Sub

Function Loop_through(ByVal oObject As Object) As Object

    If oObject Is Nothing Then
        Loop_through = Nothing
        Exit Function
    End If
   
    Dim oComponentoccurrence As Inventor.ComponentOccurrence
    Dim oBaugruppe As Boolean

    If oObject.Type = Inventor.kDocumentObject Then
        If oObject.DocumentType = kAssemblyDocumentObject Then
            Call Collect_Workpoints(oObject.ComponentDefinition)                                        'Funktionsaufruf "Collect_Workpoints"
            oBaugruppe = True

        For Each oComponentoccurrence In oObject.ComponentDefinition.Occurrences
            If oComponentoccurrence.DefinitionDocumentType = Inventor.kAssemblyDocumentObject Then
                Call Collect_Workpoints(oComponentoccurrence.Definition)                                'Funktionsaufruf "Collect_Workpoints"
                Call Loop_through(oComponentoccurrence)                                                 'Funktionsaufruf "Loop_through"
            ElseIf oComponentoccurrence.DefinitionDocumentType = Inventor.kPartDocumentObject Then
                Call Collect_Workpoints(oComponentoccurrence.Definition)                                'Funktionsaufruf "Collect_Workpoints"
            End If
        Next
    Else
        Call Collect_Workpoints(oObject.ComponentDefinition)                                            'Funktionsaufruf "Collect_Workpoints"
    End If
    ElseIf oObject.Type = kComponentOccurrenceObject Then
        If oObject.DefinitionDocumentType = kAssemblyDocumentObject Then
            Call Collect_Workpoints(oObject.Definition)                                                 'Funktionsaufruf "Collect_Workpoints"
            oBaugruppe = True
      
            For Each oComponentoccurrence In oObject.Definition.Occurrences
                If oComponentoccurrence.DefinitionDocumentType = Inventor.kAssemblyDocumentObject Then
                    Call Collect_Workpoints(oComponentoccurrence.Definition)                                'Funktionsaufruf "Collect_Workpoints"
                    Call Loop_through(oComponentoccurrence)                                                 'Funktionsaufruf "Loop_through"
                ElseIf oComponentoccurrence.DefinitionDocumentType = Inventor.kPartDocumentObject Then
                    Call Collect_Workpoints(oComponentoccurrence.Definition)                                'Funktionsaufruf "Collect_Workpoints"
                End If
            Next
        Else
            Call Collect_Workpoints(oObject.ComponentDefinition)                                'Funktionsaufruf "Collect_Workpoints"
        End If
    End If

End Function


Function Collect_Workpoints(ByVal oObject As Object)

    'Dim points() As WorkPoint


    Debug.Print (oObject.Document.DisplayName)
   
    'Hier die Workpoints erfassen -> in Public Variable speichern
   
   
    ' Referenz auf das Objekt abrufen, um Einheitenumrechnung durchzuführen
        Dim uom As UnitsOfMeasure
        Set uom = oObject.UnitsOfMeasure
   
        For i = 0 To UBound(points)
            Dim xCoord As Double
            xCoord = uom.ConvertUnits(points(i).Point.X, _
                 kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
                    
            Dim yCoord As Double
            yCoord = uom.ConvertUnits(points(i).Point.Y, _
                 kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
                    
            Dim zCoord As Double
            zCoord = uom.ConvertUnits(points(i).Point.Z, _
                 kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
                    
        Next
       
       
    Debug.Print (xCoord)
    Debug.Print (yCoord)
    Debug.Print (zCoord)
   
   
    MsgBox ("Das Bauteil heißt:" & oObject.Document.DisplayName & " und enthält die folgenden Arbeitspunkte:" & Chr(13) & Chr(13) & _
                "x-Koordinate: " & xCoord & Chr(13) & _
                "y-Koordinate: " & yCoord & Chr(13) & _
                "z-Koordinate: " & zCoord)
   
End Function



Probleme gibt es bei der in der Funktion Collect_Workpoints bei der Zeile

Code:
Set uom = oObject.UnitsOfMeasure

Laufzeitfehler '438' - Objekt unterstützt diese Eigenschaft oder Methode nicht


Ich bin halt doch kein Programmierer.....


Danke für Deine Unterstützung.

[Diese Nachricht wurde von FroSte am 15. Jun. 2022 editiert.]

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

KraBBy
Mitglied
Maschinenbau-Ingenieur


Sehen Sie sich das Profil von KraBBy an!   Senden Sie eine Private Message an KraBBy  Schreiben Sie einen Gästebucheintrag für KraBBy

Beiträge: 601
Registriert: 19.09.2007

Inventor Professional 2020
WinX

erstellt am: 23. Jun. 2022 17:32    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für SifiCAD 10 Unities + Antwort hilfreich

Mit dem Code habe ich nun ein wenig  herum probiert. Einige Anmerkungen in den Kommentaren im Code. Ich habe versucht, Deine Fragen zu beantworten.

Kann aber nicht sagen, dass ich "das große Ganze" kapiert hab. So wie die Punkte hier ausgewertet werden, bekommt man die Koordinaten im jeweiligen KS (KoordinatenSystem) des Einzelteils. Ist das so gewollt?  Es erscheint mir sinnvoller, die Punkte im Kontext der aktiven Bgr. auszuwerten.

Code:

Dim points() As WorkPoint
Dim Bauteilname() As String
'Deklaration hier auf Modulebene -> dann haben alle Prozeduren in diesem Modul Zugriff
'die Arrays werden im Gleichlauf befüllt: gleiche Indizes gehören zusammen


Option Explicit 'erzwingt die Deklaration von Variablen (vermeidet Fehler durch Tippfehler in VarNamen)


Public Sub Neu_ExportWorkpoints_iam()
 
   
 
    Dim oApp As Inventor.Application
    Set oApp = ThisApplication

    Dim oObject As Inventor.AssemblyDocument    '[KraBBy] Inventor.Document besser? s. nächster Kommentar

    If oApp.Documents.Count = 0 Then
        MsgBox ("Es muss eine Baugruppe oder ein Bauteil geöffnet sein.")
        Exit Sub
    Else
        If oApp.Documents.VisibleDocuments.Count > 0 Then
            If oApp.ActiveDocument.DocumentType = Inventor.kAssemblyDocumentObject Then
                Set oObject = oApp.ActiveDocument
            ElseIf oApp.ActiveDocument.DocumentType = Inventor.kPartDocumentObject Then
                Set oObject = oApp.ActiveDocument  '[KraBBy] das schlägt fehl, wegen Deklaration von oObject als AssemblyDocument!
            End If
        End If
    End If

    If oObject Is Nothing Then
        MsgBox ("Es muss eine Baugruppe oder ein Bauteil geöffnet sein.")
    End If

'-----------------------------------------------------------------------
'  Abfrage Weltkoordinaten
'-----------------------------------------------------------------------
 
    Dim WeltKoorDia As VbMsgBoxResult
    WeltKoorDia = MsgBox("Wollen Sie Werte für Weltkoordinaten eingeben?  " & Chr(13) & Chr(13) & _
                "Die einzugebenden Werte entsprechen den Weltkoordinaten des Mittelpunktes " & Chr(13) & _
                "und werden zu den ausgelesenen Koordinatenwerten der Arbeitspunkte hinzuaddiert.", _
                vbQuestion + vbYesNoCancel)
    If WeltKoorDia = vbCancel Then
        Exit Sub
    End If
 
    If WeltKoorDia = vbYes Then
 
        Dim xCoordWelt As Double
        Dim yCoordWelt As Double
        Dim zCoordWelt As Double
        Dim Welt_Winkel_Wert As Double, Welt_Winkel As Double
 
'        WeltKoor.Show  '[KraBBy] ist vmtl ein Formular, das ich nicht habe -> auskommentiert
'
'        xCoordWelt = WeltKoor.txt_x
'        yCoordWelt = WeltKoor.txt_y
'        zCoordWelt = WeltKoor.txt_z
'
'        Welt_Winkel_Wert = WeltKoor.txt_grd
        Welt_Winkel = Welt_Winkel_Wert * 3.14159265359 / 180
         

    End If


'-----------------------------------------------------------------------
'  Funktionsaufruf Schleife durch Baugruppen und Bauteile
'-----------------------------------------------------------------------
   
    '[KraBBy] Array initialisieren (sonst schlägt die erste Zuweisung fehl)
    ReDim points(0)
    ReDim Bauteilname(0)
   
    Call Loop_through(oObject)
   
    ' [KraBBy] jetzt sollten die beiden Arrays befüllt sein
    ' jetzt an ein Sub übergeben, das die Auswertung macht
    Call Points_auswerten(points, Bauteilname)


End Sub

Function Loop_through(ByVal oObject As Object) As Object

    If oObject Is Nothing Then
        Loop_through = Nothing
        Exit Function
    End If
 
    Dim oComponentoccurrence As Inventor.ComponentOccurrence
    Dim oBaugruppe As Boolean

    If oObject.Type = Inventor.kDocumentObject Then
        If oObject.DocumentType = kAssemblyDocumentObject Then
            Call Collect_Workpoints(oObject.ComponentDefinition)                                        'Funktionsaufruf "Collect_Workpoints"
            oBaugruppe = True

            For Each oComponentoccurrence In oObject.ComponentDefinition.Occurrences
                If oComponentoccurrence.DefinitionDocumentType = Inventor.kAssemblyDocumentObject Then
                    Call Collect_Workpoints(oComponentoccurrence.Definition)                                'Funktionsaufruf "Collect_Workpoints"
                    Call Loop_through(oComponentoccurrence)                                                'Funktionsaufruf "Loop_through"
                    '[KraBBy] Unterbgr. werden doppelt verarbeitet (Collect_Workpoints): 2 Z. und 7 Z. höher beim Loop_through
                ElseIf oComponentoccurrence.DefinitionDocumentType = Inventor.kPartDocumentObject Then
                    Call Collect_Workpoints(oComponentoccurrence.Definition)                                'Funktionsaufruf "Collect_Workpoints"
                End If
            Next
        Else
            Call Collect_Workpoints(oObject.ComponentDefinition)                                            'Funktionsaufruf "Collect_Workpoints"
        End If
    ElseIf oObject.Type = kComponentOccurrenceObject Then
        If oObject.DefinitionDocumentType = kAssemblyDocumentObject Then
            Call Collect_Workpoints(oObject.Definition)                                                'Funktionsaufruf "Collect_Workpoints"
            oBaugruppe = True
   
            For Each oComponentoccurrence In oObject.Definition.Occurrences
                If oComponentoccurrence.DefinitionDocumentType = Inventor.kAssemblyDocumentObject Then
                    Call Collect_Workpoints(oComponentoccurrence.Definition)                                'Funktionsaufruf "Collect_Workpoints"
                    Call Loop_through(oComponentoccurrence)                                                'Funktionsaufruf "Loop_through"
                ElseIf oComponentoccurrence.DefinitionDocumentType = Inventor.kPartDocumentObject Then
                    Call Collect_Workpoints(oComponentoccurrence.Definition)                                'Funktionsaufruf "Collect_Workpoints"
                End If
            Next
        Else
            Call Collect_Workpoints(oObject.ComponentDefinition)                                'Funktionsaufruf "Collect_Workpoints"
        End If
    End If

End Function


Function Collect_Workpoints(ByVal oObject As Object)


    Debug.Print (oObject.Document.DisplayName)
 
    'Hier die Workpoints erfassen -> in Public Variable speichern
   
   
    ' [KraBBy]
    Dim PointCount As Long
    PointCount = UBound(points)    'höchster Index vom Array
   
   
   
    Dim selectedObj As WorkPoint
    For Each selectedObj In oObject.WorkPoints
   
   
        If TypeOf selectedObj Is WorkPointProxy Then
            If Not selectedObj.ContainingOccurrence Is Nothing Then
            '[KraBBy]das schlägt fehl, Workpoint hat keine Cont.Occ.
            ' deshalb die If aussen rum gezimmert mit type ? wpProxy
            ' soll hier mit Proxies gearbeitet werden? https://help.autodesk.com/view/INVNTOR/2020/ENU/?guid=GUID-6A540540-CA8A-40AD-8EBF-C4BB1F3E7288
            ' in diese Fkt hier werden aber die Definitions geworfen...
            ' -> es werden Punkte geliefert im lokalen Koordinatensystem (des jew. Bauteils)
                Bauteilname(PointCount) = selectedObj.ContainingOccurrence.Name
            Else
                Bauteilname(PointCount) = ""
            End If
        Else 'kein Proxy
            Bauteilname(PointCount) = oObject.Document.DisplayName
        End If
       
        Set points(PointCount) = selectedObj
   
        'für die nächste Runde vorbereiten; Arrays vergrößern
        PointCount = PointCount + 1
       
        ReDim Preserve Bauteilname(PointCount)
        ReDim Preserve points(PointCount)
    Next
   
End Function

Private Sub Points_auswerten(myPoints() As WorkPoint, myNames() As String)
'[KraBBy] die Auswertung der Punkte abgetrennt in eigenes Sub
' dabei die Punkte (bzw. das entspr. Array) als Parameter übergeben
' auch die zugehörigen Namen

    Debug.Print "---- Sub: Points_auswerten ---"

    ' Referenz auf das Objekt abrufen, um Einheitenumrechnung durchzuführen
        Dim uom As UnitsOfMeasure
        Set uom = ThisApplication.ActiveDocument.UnitsOfMeasure '[KraBBy] nur Dokumente haben das UnitsOfMeasure
       
        Dim i As Long
        For i = 0 To (UBound(myPoints) - 1) '-1 weil das letzte Element der Arrays immer leer bleibt, in Fkt. 'Collect_Workpoints'
            Dim xCoord As Double
            xCoord = uom.ConvertUnits(myPoints(i).Point.X, _
                kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
                 
            Dim yCoord As Double
            yCoord = uom.ConvertUnits(myPoints(i).Point.Y, _
                kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
                 
            Dim zCoord As Double
            zCoord = uom.ConvertUnits(myPoints(i).Point.Z, _
                kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
                 
       
     
            Debug.Print myNames(i)
            Debug.Print myPoints(i).Name
            Debug.Print (xCoord)
            Debug.Print (yCoord)
            Debug.Print (zCoord)
  Next
 
 
'    MsgBox ("Das Bauteil heißt:" & oObject.Document.DisplayName & " und enthält die folgenden Arbeitspunkte:" & Chr(13) & Chr(13) & _
'                "x-Koordinate: " & xCoord & Chr(13) & _
'                "y-Koordinate: " & yCoord & Chr(13) & _
'                "z-Koordinate: " & zCoord)
 
End Sub

Private Sub Test_points_auswerten()
    'Testaufruf für das obige Sub
   
    Dim oDoc As AssemblyDocument
    Set oDoc = ThisApplication.ActiveDocument
   
    'Arrays mit Dummy-Daten befüllen
    Dim myPnts(3) As WorkPoint, i As Integer
    Dim myStrings(3) As String
    For i = 0 To 2
        Set myPnts(i) = oDoc.ComponentDefinition.WorkPoints.Item(i + 1)
        'aktive Bgr muss mindestens 3 WorkPoints enthalten
        myStrings(i) = "Name xy " & CStr(i)
    Next i
   
    'das Sub damit aufrufen, das ich eigentlich ausprobieren will
    Call Points_auswerten(myPnts, myStrings)
   
End Sub


------------------
Gruß KraBBy

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

FroSte
Mitglied
Bauingenieur


Sehen Sie sich das Profil von FroSte an!   Senden Sie eine Private Message an FroSte  Schreiben Sie einen Gästebucheintrag für FroSte

Beiträge: 20
Registriert: 09.06.2009

Inventor 2021

erstellt am: 28. Jun. 2022 20:03    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für SifiCAD 10 Unities + Antwort hilfreich


Pack-and-Go-Koordinaten.zip

 
Hallo KraBBy,

vielen herzlichen Dank für Deine Unterstützung und den Code. Der Code funktioniert so weit prima.
Ich habe den Code noch etwas an unsere Belange angepasst und schreibe die Daten nun in eine CSV-Datei. Eigentlich möchte ich die Daten auch in eine Excel-Datei schrieben aber das funktioniert nicht. Da bekomme ich die gleichen Probleme und Fehlermeldungen wie in diesem und anderen Posts: https://forums.autodesk.com/t5/inventor-ilogic-and-vb-net-forum/create-a-excel-file-using-vba-inventor-2021-excel2016-not-works/td-p/9822537
Da habe ich noch keine Lösung gefunden.

Mit Deiner Anmerkung, dass man die Koordinaten der Punkte in den einzelnen Bauteile besser im Kontext der Baugruppe auswertet, hast Du recht. Ich brauche eigentlich die Koordinaten der einzelnen Bauteile in Bezug auf den Ursprung der Baugruppe. Dann unterschieden sich auch die Koordinaten aus den einzelnen Bauteilen, auch wenn es im Bauteil der gleiche Punkt ist. Somit macht es auch wieder Sinn, dass alle Bauteile in der Baugruppe aufgelistet werden, auch wenn das Bauteil mehrfach verbaut wird.
Da fehlt mir aber jegliche Vorstellung, wie das funktionieren kann. Sicher gibt es aber hier noch ein paar Profis, die dazu eine Lösung finden können. Wäre prima, wenn sich da jemand reinfuchsen könnte und mir behilflich ist.

Ich hänge eine Baugruppe und die zugehörigen Bauteile mit an. Darin ist der Code (siehe auch unten) und das Formular für die Eingabe von Additive Koordinatenwerte enthalten.

Hier ist mein vollständiger Code.

Code:

Dim points() As WorkPoint
Dim Bauteilname() As String
'Deklaration hier auf Modulebene -> dann haben alle Prozeduren in diesem Modul Zugriff
'die Arrays werden im Gleichlauf befüllt: gleiche Indizes gehören zusammen

Dim Dateiname_Excel As String
Dim Dateiname_Text As String
Dim Dateiname_xls As String
Dim Dateiname_csv As String

Option Explicit 'erzwingt die Deklaration von Variablen (vermeidet Fehler durch Tippfehler in VarNamen)


Public Sub Neu_ExportWorkpoints_iam()

 

    Dim oApp As Inventor.Application
    Set oApp = ThisApplication

    Dim oObject As Inventor.AssemblyDocument    '[KraBBy] Inventor.Document besser? s. nächster Kommentar

    If oApp.Documents.Count = 0 Then
        MsgBox ("Es muss eine Baugruppe oder ein Bauteil geöffnet sein.")
        Exit Sub
    Else
        If oApp.Documents.VisibleDocuments.Count > 0 Then
            If oApp.ActiveDocument.DocumentType = Inventor.kAssemblyDocumentObject Then
                Set oObject = oApp.ActiveDocument
            ElseIf oApp.ActiveDocument.DocumentType = Inventor.kPartDocumentObject Then
                Set oObject = oApp.ActiveDocument  '[KraBBy] das schlägt fehl, wegen Deklaration von oObject als AssemblyDocument!
            End If
        End If
    End If

    If oObject Is Nothing Then
        MsgBox ("Es muss eine Baugruppe oder ein Bauteil geöffnet sein.")
    End If

'-----------------------------------------------------------------------
'  Abfrage Weltkoordinaten
'-----------------------------------------------------------------------

    Dim WeltKoorDia As VbMsgBoxResult
    WeltKoorDia = MsgBox("Wollen Sie Werte für Weltkoordinaten eingeben?  " & Chr(13) & Chr(13) & _
                "Die einzugebenden Werte entsprechen den Weltkoordinaten des Mittelpunktes " & Chr(13) & _
                "und werden zu den ausgelesenen Koordinatenwerten der Arbeitspunkte hinzuaddiert.", _
                vbQuestion + vbYesNoCancel)
    If WeltKoorDia = vbCancel Then
        Exit Sub
    End If

    If WeltKoorDia = vbYes Then

        Dim xCoordWelt As Double
        Dim yCoordWelt As Double
        Dim zCoordWelt As Double
        Dim Welt_Winkel_Wert As Double
        Dim Welt_Winkel As Double

        WeltKoor.Show  'Aufruf des Formulars zur Eingabe von Koordinaten

        xCoordWelt = WeltKoor.txt_x
        yCoordWelt = WeltKoor.txt_y
        zCoordWelt = WeltKoor.txt_z

        Welt_Winkel_Wert = WeltKoor.txt_grd
        Welt_Winkel = Welt_Winkel_Wert * 3.14159265359 / 180
       

    End If


'-----------------------------------------------------------------------
'  Funktionsaufruf Schleife durch Baugruppen und Bauteile
'-----------------------------------------------------------------------
 
    '[KraBBy] Array initialisieren (sonst schlägt die erste Zuweisung fehl)
    ReDim points(0)
    ReDim Bauteilname(0)
 
    Call Loop_through(oObject)
 
    ' [KraBBy] jetzt sollten die beiden Arrays befüllt sein
    ' jetzt an ein Sub übergeben, das die Auswertung macht
    Call Points_auswerten(points, Bauteilname, xCoordWelt, yCoordWelt, zCoordWelt, Welt_Winkel)
   
   
   
    '-----------------------------------------------------------------------
    '  Dialog zum Erstellen der Dateien
    '-----------------------------------------------------------------------
    ' Abrufen des Dateinamens der Datei, in die geschrieben werden soll
    Dim dialog As FileDialog
    Dim Dateiname_Excel As String
   
    Dateiname_Excel = Left(ThisApplication.ActiveDocument.FullFileName, _
    Len(ThisApplication.ActiveDocument.FullFileName) - 4) + ".xls"
   
    Call ThisApplication.CreateFileDialog(dialog)
    With dialog
        .DialogTitle = "Ausgabedatei *.XLS-Format"
        .Filter = "Microsoft Office Excel-Datei (*.xls)|*.xls"
        .FilterIndex = 0
        .OptionsEnabled = False
        .MultiSelectEnabled = False
        .CancelError = False
        .filename = Dateiname_Excel
        .ShowSave
        Dateiname_Excel = .filename
    End With

   
    '-----------------------------------------------------------------------
    '  Festlegen der Dateinamen der Excel-Datei im *.csv-Format
    '-----------------------------------------------------------------------
   
'    Dim filename_Text As String
   
    If Dateiname_Excel <> "" And Len(Dateiname_Excel) >= 4 Then
        Dateiname_Text = Left(Dateiname_Excel, Len(Dateiname_Excel) - 4) + ".csv"
    Else
        MsgBox "das Programm wird beendet ohne eine Excel-Datei oder CSV-Datei zu erstellen."
        Exit Sub
    End If
   
   
    '-----------------------------------------------------------------------
    '  Erstellen der Excel-Datei im *.csv-Format
    '-----------------------------------------------------------------------
   
    Call CSV_Datei_Erstellen(points, Bauteilname, xCoordWelt, yCoordWelt, zCoordWelt, Welt_Winkel, Dateiname_Text)
   
   
   
    '-----------------------------------------------------------------------
    '  Erstellen der Excel-Datei im *.xls-Format
    '-----------------------------------------------------------------------
   
    Call Excel_Datei_Erstellen(points, Bauteilname, xCoordWelt, yCoordWelt, zCoordWelt, Welt_Winkel, Dateiname_Excel)
   
   
   
   
   
    'Microsoft Excel starten und ein bestehendes
    ' Worksheet-Objekt öffnen.
'    Set ExcelWorkSheet = GetObject("Dateiname_Excel")


End Sub

Function Loop_through(ByVal oObject As Object) As Object

    If oObject Is Nothing Then
        Loop_through = Nothing
        Exit Function
    End If

    Dim oComponentoccurrence As Inventor.ComponentOccurrence
    Dim oBaugruppe As Boolean

    If oObject.Type = Inventor.kDocumentObject Then
        If oObject.DocumentType = kAssemblyDocumentObject Then
            Call Collect_Workpoints(oObject.ComponentDefinition)                                        'Funktionsaufruf "Collect_Workpoints"
            oBaugruppe = True

            For Each oComponentoccurrence In oObject.ComponentDefinition.Occurrences
                If oComponentoccurrence.DefinitionDocumentType = Inventor.kAssemblyDocumentObject Then
                    Call Collect_Workpoints(oComponentoccurrence.Definition)                                'Funktionsaufruf "Collect_Workpoints"
                    Call Loop_through(oComponentoccurrence)                                                'Funktionsaufruf "Loop_through"
                    '[KraBBy] Unterbgr. werden doppelt verarbeitet (Collect_Workpoints): 2 Z. und 7 Z. höher beim Loop_through
                ElseIf oComponentoccurrence.DefinitionDocumentType = Inventor.kPartDocumentObject Then
                    Call Collect_Workpoints(oComponentoccurrence.Definition)                                'Funktionsaufruf "Collect_Workpoints"
                End If
            Next
        Else
            Call Collect_Workpoints(oObject.ComponentDefinition)                                            'Funktionsaufruf "Collect_Workpoints"
        End If
    ElseIf oObject.Type = kComponentOccurrenceObject Then
        If oObject.DefinitionDocumentType = kAssemblyDocumentObject Then
            Call Collect_Workpoints(oObject.Definition)                                                'Funktionsaufruf "Collect_Workpoints"
            oBaugruppe = True
 
            For Each oComponentoccurrence In oObject.Definition.Occurrences
                If oComponentoccurrence.DefinitionDocumentType = Inventor.kAssemblyDocumentObject Then
                    Call Collect_Workpoints(oComponentoccurrence.Definition)                                'Funktionsaufruf "Collect_Workpoints"
                    Call Loop_through(oComponentoccurrence)                                                'Funktionsaufruf "Loop_through"
                ElseIf oComponentoccurrence.DefinitionDocumentType = Inventor.kPartDocumentObject Then
                    Call Collect_Workpoints(oComponentoccurrence.Definition)                                'Funktionsaufruf "Collect_Workpoints"
                End If
            Next
        Else
            Call Collect_Workpoints(oObject.ComponentDefinition)                                'Funktionsaufruf "Collect_Workpoints"
        End If
    End If

End Function


Function Collect_Workpoints(ByVal oObject As Object)


    Debug.Print (oObject.Document.DisplayName)

    'Hier die Workpoints erfassen -> in Public Variable speichern
 
 
    ' [KraBBy]
    Dim PointCount As Long
    PointCount = UBound(points)    'höchster Index vom Array
 
 
 
    Dim selectedObj As WorkPoint
    For Each selectedObj In oObject.WorkPoints
 
 
        If TypeOf selectedObj Is WorkPointProxy Then
            If Not selectedObj.ContainingOccurrence Is Nothing Then
            '[KraBBy]das schlägt fehl, Workpoint hat keine Cont.Occ.
            ' deshalb die If aussen rum gezimmert mit type ? wpProxy
            ' soll hier mit Proxies gearbeitet werden? https://help.autodesk.com/view/INVNTOR/2020/ENU/?guid=GUID-6A540540-CA8A-40AD-8EBF-C4BB1F3E7288
            ' in diese Fkt hier werden aber die Definitions geworfen...
            ' -> es werden Punkte geliefert im lokalen Koordinatensystem (des jew. Bauteils)
                Bauteilname(PointCount) = selectedObj.ContainingOccurrence.Name
            Else
                Bauteilname(PointCount) = ""
            End If
        Else 'kein Proxy
            Bauteilname(PointCount) = oObject.Document.DisplayName
        End If
     
        Set points(PointCount) = selectedObj
 
        'für die nächste Runde vorbereiten; Arrays vergrößern
        PointCount = PointCount + 1
     
        ReDim Preserve Bauteilname(PointCount)
        ReDim Preserve points(PointCount)
    Next
 
End Function

Private Sub Points_auswerten(myPoints() As WorkPoint, myNames() As String, xCoordW As Double, yCoordW As Double, zCoordW As Double, WinkelW As Double)
'[KraBBy] die Auswertung der Punkte abgetrennt in eigenes Sub
' dabei die Punkte (bzw. das entspr. Array) als Parameter übergeben
' auch die zugehörigen Namen

    Debug.Print "---- Sub: Points_auswerten ---"

    ' Referenz auf das Objekt abrufen, um Einheitenumrechnung durchzuführen
        Dim uom As UnitsOfMeasure
        Set uom = ThisApplication.ActiveDocument.UnitsOfMeasure '[KraBBy] nur Dokumente haben das UnitsOfMeasure
     
        Dim i As Long
        For i = 0 To (UBound(myPoints) - 1) '-1 weil das letzte Element der Arrays immer leer bleibt, in Fkt. 'Collect_Workpoints'
            Dim xCoord As Double
            xCoord = uom.ConvertUnits(myPoints(i).Point.X, _
                kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
               
            Dim yCoord As Double
            yCoord = uom.ConvertUnits(myPoints(i).Point.Y, _
                kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
               
            Dim zCoord As Double
            zCoord = uom.ConvertUnits(myPoints(i).Point.Z, _
                kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
               
     
   
            Debug.Print myNames(i)
            Debug.Print myPoints(i).Name
            Debug.Print (xCoord)
            Debug.Print (xCoordW)
            Debug.Print (yCoord)
            Debug.Print (yCoordW)
            Debug.Print (zCoord)
            Debug.Print (zCoordW)
           
           
           
           
          MsgBox ("Das Bauteil heißt:" & myNames(i) & " und enthält die folgenden Arbeitspunkte:" & Chr(13) & Chr(13) & _
                    "Arbeitspunkt: " & myPoints(i).Name & Chr(13) & _
                    "x-Koordinate: " & xCoordW + xCoord & Chr(13) & _
                    "y-Koordinate: " & yCoordW + yCoord & Chr(13) & _
                    "z-Koordinate: " & zCoordW + zCoord)

Next



End Sub

Private Sub CSV_Datei_Erstellen(myPoints() As WorkPoint, Bauteilname() As String, xCoordW As Double, yCoordW As Double, zCoordW As Double, WinkelW As Double, Dateiname_csv As String)

'-----------------------------------------------------------------------
'  Erstellen der Excel-Datei im *.CSV-Format
'-----------------------------------------------------------------------

        MsgBox "Die angegebene Datei ist: " & Dateiname_csv
   
     
        ' Schreiben der Koordinaten der Arbeitspunkte in eine csv Datei
        On Error Resume Next
        Open Dateiname_csv For Output As #1
        If Err.Number <> 0 Then
            MsgBox "Die angegebene Datei kann nicht geöffnert werden. " & _
                  "Die Datei ist eventuell durch einen anderen Prozess geöffnet."
            Exit Sub
        End If

       
        ' Referenz auf das Objekt abrufen, um eine Einheitenumrechnung durchzuführen
        Dim uom As UnitsOfMeasure
        Set uom = ThisApplication.ActiveDocument.UnitsOfMeasure
       
        ' Schreiben der Punkte unter Berücksichtigung der aktuellen Standardlängeneinheit des Dokuments
        Print #1, "Bauteilname" & "    " & _
                "Bezeichnung" & "    " & _
                "X-Koordinate" & "    " & _
                "Y-Koordinate" & "    " & _
                "Z-Koordinate"
       
        Dim i As Long
        For i = 0 To (UBound(myPoints) - 1) '-1 weil das letzte Element der Arrays immer leer bleibt, in Fkt. 'Collect_Workpoints'
            Dim xCoord As Double
            xCoord = uom.ConvertUnits(myPoints(i).Point.X, _
                kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
               
            Dim yCoord As Double
            yCoord = uom.ConvertUnits(myPoints(i).Point.Y, _
                kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
               
            Dim zCoord As Double
            zCoord = uom.ConvertUnits(myPoints(i).Point.Z, _
                kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
                   
            Print #1, Bauteilname(i) & "    " & myPoints(i).Name & "    " & _
                Format(Cos(WinkelW) * xCoord - Sin(WinkelW) * yCoord + xCoordW, "0.000") & "    " & _
                Format(Sin(WinkelW) * xCoord + Cos(WinkelW) * yCoord + yCoordW, "0.000") & "    " & _
                Format(zCoord + zCoordW, "0.000")
        Next
       
       
        Close #1
   
'-----------------------------------------------------------------------
       
       
    MsgBox "Das Schreiben der Dateien ist beendet. " & Chr(13) & Chr(13) & _
          "Die Daten befinden sich in der Datei: " & Chr(13) & Chr(13) & _
          "- """ & Dateiname_csv & """"


 

End Sub


Private Sub Excel_Datei_Erstellen(myPoints() As WorkPoint, Bauteilname() As String, xCoordW As Double, yCoordW As Double, zCoordW As Double, WinkelW As Double, Dateiname_xls As String)

    MsgBox "Die angegebene Datei ist: " & Dateiname_xls
   
'-----------------------------------------------------------------------
'  Erstellen der Excel-Datei im *.xls-Format
'-----------------------------------------------------------------------
    'Eine neue Excel-Instance erstellen
    Dim oExcelApplication As Excel.Application                    'Variante 1
    Set oExcelApplication = New Excel.Application                  'Variante 1 - an dieser Stelle Fehler beim Ausführen
'    Dim oExcelApplication As Object                                'Variante 2
'    Set oExcelApplication = CreateObject("Excel.Application")      'Variante 2
   
    oExcelApplication.Visible = True    'schaltet die Excel-Instanz sichtbar

    'Ein neues excel workbook erstellen
    Dim oBook As Excel.Workbook
    Set oBook = oExcelApplication.Workbooks.Add()                  'bei Variante 2 an dieser Stelle Fehler beim Ausführen
    Dim oSheet As Excel.WorkSheet
    Set oSheet = oBook.ActiveSheet
 
    Dim nRow As Integer
    nRow = 2

    'Spaltenüberschriften
        oSheet.Cells(1, 1) = "Bauteilname"
        oSheet.Cells(1, 1).Font.Bold = True
       
        oSheet.Cells(1, 2) = "Bezeichnung"
        oSheet.Cells(1, 2).Font.Bold = True
       
        oSheet.Cells(1, 3) = "X-Koordinate"
        oSheet.Cells(1, 3).Font.Bold = True
       
        oSheet.Cells(1, 4) = "Y-Koordinate"
        oSheet.Cells(1, 4).Font.Bold = True
       
        oSheet.Cells(1, 5) = "Z-Koordinate"
        oSheet.Cells(1, 5).Font.Bold = True
       
   
    ' Referenz auf das Objekt abrufen, um eine Einheitenumrechnung durchzuführen
        Dim uom As UnitsOfMeasure
        Set uom = ThisApplication.ActiveDocument.UnitsOfMeasure
   
    'Schreiben der Koordinaten in separate Spalten, ein Arbeitspunkt je Zeile
        Dim i As Long
        For i = 0 To (UBound(myPoints) - 1) '-1 weil das letzte Element der Arrays immer leer bleibt, in Fkt. 'Collect_Workpoints'
            Dim xCoord As Double
            xCoord = uom.ConvertUnits(myPoints(i).Point.X, _
                kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
               
            Dim yCoord As Double
            yCoord = uom.ConvertUnits(myPoints(i).Point.Y, _
                kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
               
            Dim zCoord As Double
            zCoord = uom.ConvertUnits(myPoints(i).Point.Z, _
                kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
                   
       
        oSheet.Cells(nRow, 1) = Bauteilname(i)
        oSheet.Cells(nRow, 2) = myPoints(i).Name
        oSheet.Cells(nRow, 3) = Cos(WinkelW) * xCoord - Sin(WinkelW) * yCoord + xCoordW
        oSheet.Cells(nRow, 4) = Sin(WinkelW) * xCoord + Cos(WinkelW) * yCoord + yCoordW
        oSheet.Cells(nRow, 5) = zCoord + zCoordW
        nRow = nRow + 1
       
        Next
   
    oSheet.Columns(1).EntireColumn.AutoFit
    oSheet.Columns(2).EntireColumn.AutoFit
    oSheet.Columns(3).EntireColumn.AutoFit
    oSheet.Columns(4).EntireColumn.AutoFit
    oSheet.Columns(5).EntireColumn.AutoFit
   
    oSheet.Cells(nRow + 1, 1) = ThisApplication.ActiveDocument.FullFileName
     
     
    On Error Resume Next
    oBook.SaveAs (Dateiname_xls)
    oBook.Close
    Set oBook = Nothing
    Set oSheet = Nothing
    Set oExcelApplication = Nothing
 

'-----------------------------------------------------------------------
       
       
    MsgBox "Das Schreiben der Dateien ist beendet. " & Chr(13) & Chr(13) & _
          "Die Daten befinden sich in den beiden Dateien: " & Chr(13) & Chr(13) & _
          "- """ & Dateiname_xls & "" & Chr(13) & _
          "- """ & Dateiname_csv & """"

End Sub



In dem Code sind noch viele Hinweisdialoge enthalten, die aber später mal noch entfernt werden. Sie dienen mir nur zum besseren Verständnis was der Code macht.

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

KraBBy
Mitglied
Maschinenbau-Ingenieur


Sehen Sie sich das Profil von KraBBy an!   Senden Sie eine Private Message an KraBBy  Schreiben Sie einen Gästebucheintrag für KraBBy

Beiträge: 601
Registriert: 19.09.2007

Inventor Professional 2020
WinX

erstellt am: 29. Jun. 2022 17:54    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für SifiCAD 10 Unities + Antwort hilfreich

Zitat:
Original erstellt von FroSte:
Ich brauche eigentlich die Koordinaten der einzelnen Bauteile in Bezug auf den Ursprung der Baugruppe. [...]
Da fehlt mir aber jegliche Vorstellung, wie das funktionieren kann.


Daran habe ich mich jetzt versucht. Das folgende lief in meinem kleinen Test durch. Es wird auch das Array "points" befüllt, jetzt aber mit dem Proxy (dh. mit dem Stellvertreter im Kontext der Bgr). Auch das Array "Bauteilname" wird befüllt, jetzt mit dem Namen der Komponente. Dabei gibt es das (mögliche) Problem, dass das Bauteil "Klotz:1" mehrfach auftritt wenn es mehrfach auf verschiedenen Bgr-Ebenen vorkommt.

Zum Ausprobieren sollte es reichen, wenn Du im Sub Neu_ExportWorkpoints_iam die Zeile
Call Loop_through(oObject)
auskommentierst und stattdessen
Call StartLoopThroughOccs(oObject)
aufrufst. Den folgenden Code dann noch zusätzlich in das Modul kopieren.

Code:
Private Sub StartLoopThroughOccs(oAsmDoc As AssemblyDocument)
   
    Debug.Print "---- Sub: StartLoopThroughOccs ---"
   
    'Punkte aus der Baugruppe erfassen
    Call CollectWorkpointProxys(oAsmDoc.ComponentDefinition)
   
    'Start der Rekursion durch die Occurrences
    Call loopThroughOccs(oAsmDoc.ComponentDefinition.Occurrences)
   
    Debug.Print "---- Sub: StartLoopThroughOccs ist durch ---"
End Sub

Private Sub loopThroughOccs(oOccs As ComponentOccurrences)
   
    If 0 = oOccs.Count Then Exit Sub 'Abbruchbedingung für die Rekursion
   
    Dim oOcc As ComponentOccurrence
    For Each oOcc In oOccs
       
        Debug.Print oOcc.Name
       
        Call CollectWorkpointProxys(oOcc.Definition, oOcc)
       
        If Not 0 = oOcc.SubOccurrences.Count Then
            'erneuter Aufruf dieses Sub -> Rekursion
            Call loopThroughOccs(oOcc.SubOccurrences)
        Else
            'nix zu tun (es geht weiter mit der nächsten Occ)
        End If
       
    Next 'oOcc
   
End Sub

Private Sub CollectWorkpointProxys(oCompDef As ComponentDefinition, Optional oCC As ComponentOccurrence)  '### neue Variante von Collect_Workpoints

    Dim PointCount As Long
    PointCount = UBound(points)    'höchster Index vom Array
   
   
    Dim oWp As WorkPoint, oPtProxy As WorkPointProxy
    For Each oWp In oCompDef.WorkPoints
   
        If Not oCC Is Nothing Then  'Occ wurde uebergeben
            Call oCC.CreateGeometryProxy(oWp, oPtProxy)    'Proxy bilden
            Set points(PointCount) = oPtProxy              'dem Array zuweisen (das funktioniert, weil ein WorkPointProxy auch ein WorkPoint ist (umgekehrt gilt das nicht); Stichwort: Vererbung)
            Bauteilname(PointCount) = oCC.Name
        Else 'oCC wurde NICHT uebergeben
            ' es kann kein Proxy gebildet werden    -> jetzt nur bei der geöffneten Bgr.
            Set points(PointCount) = oWp
            Bauteilname(PointCount) = oCompDef.Document.DisplayName
        End If
       
        'für die nächste Runde vorbereiten; Arrays vergrößern
        PointCount = PointCount + 1
       
        ReDim Preserve Bauteilname(PointCount)
        ReDim Preserve points(PointCount)
    Next 'oWp
   
End Sub



------------------
Gruß KraBBy

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

KraBBy
Mitglied
Maschinenbau-Ingenieur


Sehen Sie sich das Profil von KraBBy an!   Senden Sie eine Private Message an KraBBy  Schreiben Sie einen Gästebucheintrag für KraBBy

Beiträge: 601
Registriert: 19.09.2007

Inventor Professional 2020
WinX

erstellt am: 29. Jun. 2022 19:09    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für SifiCAD 10 Unities + Antwort hilfreich

Das Problem mit Excel konnte ich jetzt nicht nachstellen. Das unten hat bei mir funktioniert. Hängt vielleicht mit der Excelversion und -Installation zusammen (hab aber letztlich keine Ahnung)
IV2020
Excel Version 2107 (aus Microsoft 365 MSO) 64-Bit

Ich habe bisher einen Bogen um die Kommunikation zwischen IV und Excel gemacht. Ich würde die Daten lieber in ein einfacheres Dateiformat wie csv schreiben. Dann fehlt zwar zunächst die Formatierung, aber dafür läuft es stabil (und ich kann leichter folgen, was passiert etc.). Wenn die Formatierung wichtig/nötig ist, dann würde ich in Excel ein Makro dafür schreiben (das die geöffnete csv aufbereitet und speichert).

Tipp bzgl. csv: Schau Dir die Hilfe bzgl. Print und Write Anweisung an. mE ist Write hier besser geeignet

Code:
Private Sub test_Excel()
' wichtig: unter Extras -> Verweise das folgende einbinden
'  Microsoft Excel 16.0 Object Library
' KraBBy 29.06.2022
    Dim oExcelApp As Excel.Application
    Set oExcelApp = New Excel.Application
    'Set oExcelApp = CreateObject("Excel.Application")
    'bei mir liefen beide Zeilen
   
    Dim oWb As Excel.Workbook
    Set oWb = oExcelApp.Workbooks.Add()
   
'    oExcelApp.Visible = True
   
    Dim oSheet As WorkSheet
    Set oSheet = oWb.ActiveSheet
   
    'Zellen mit Inhalt füllen
    oSheet.Cells(1, 1) = "geht doch"
   
    'Formeln
    Dim oCell As Excel.Range
    Set oCell = oSheet.Cells(2, 1)
    oCell.Formula = "=today()"      'mit Englischen Befehlen
    Set oCell = oSheet.Cells(2, 3)
    oCell.FormulaLocal = "=heute()" 'in der Sprache der lokalen Installation
   
   
    'Workbook speichern
    oExcelApp.DisplayAlerts = False    'damit wird die Abfrage bzgl. überschreiben unterdrückt
    oWb.SaveAs FileName:="C:\temp\wtf_excel.xlsx"
   
    'Excel beenden
    oExcelApp.Quit
    Set oExcelApp = Nothing
     
End Sub

------------------
Gruß KraBBy

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

FroSte
Mitglied
Bauingenieur


Sehen Sie sich das Profil von FroSte an!   Senden Sie eine Private Message an FroSte  Schreiben Sie einen Gästebucheintrag für FroSte

Beiträge: 20
Registriert: 09.06.2009

Inventor 2021

erstellt am: 30. Jun. 2022 11:03    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für SifiCAD 10 Unities + Antwort hilfreich

Hallo KraBBy,
vielen Dank für das Testen der Routine für das Erstellen der Exceldatei.
Heute hat es bei mir auch auf anhieb problemlos funktioniert.

Entweder hat das gestern installierte Windows und Office-Update das Problem gelöst, oder es hat mit Sicherheitseinstellungen zu tun. Heute bin ich in der Firma. Die letzten Tage war ich im Home Office. Ich werde das gleich heute Abend nochmals zu Hause ausprobieren.

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

FroSte
Mitglied
Bauingenieur


Sehen Sie sich das Profil von FroSte an!   Senden Sie eine Private Message an FroSte  Schreiben Sie einen Gästebucheintrag für FroSte

Beiträge: 20
Registriert: 09.06.2009

Inventor 2021

erstellt am: 30. Jun. 2022 11:46    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für SifiCAD 10 Unities + Antwort hilfreich

Hallo KraBBy,

Zitat:
Original erstellt von KraBBy:

Daran habe ich mich jetzt versucht. Das folgende lief in meinem kleinen Test durch. Es wird auch das Array "points" befüllt, jetzt aber mit dem Proxy (dh. mit dem Stellvertreter im Kontext der Bgr). Auch das Array "Bauteilname" wird befüllt, jetzt mit dem Namen der Komponente. Dabei gibt es das (mögliche) Problem, dass das Bauteil "Klotz:1" mehrfach auftritt wenn es mehrfach auf verschiedenen Bgr-Ebenen vorkommt.


Super, vielen Dank.
Das Skript klappt prima und macht genau das, was ich bzw. wir benötigen.

Ich werde jetzt noch ein paar Dinge anpassen und eine Abfrage für beide Varianten (Koordinaten auf den lokalen Ursprung der Bauteile bezogen und Koordinaten auf den globalen Ursprung der baugruppe bezogen ausgeben) einbauen. Vielleicht benötigen wir doch mal auch die Koordinate aus den einzelnen Bauteilen.

Nochmals ganz vielen herzlichen Dank für die tolle Unterstützung.

Viele Grüße,
FroSte

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

Anzeige.:

Anzeige: (Infos zum Werbeplatz >>)

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen

nächster neuerer Beitrag | nächster älterer Beitrag
Antwort erstellen


Diesen Beitrag mit Lesezeichen versehen ... | Nach anderen Beiträgen suchen | CAD.de-Newsletter

Administrative Optionen: Beitrag schliessen | Archivieren/Bewegen | Beitrag melden!

Fragen und Anregungen: Kritik-Forum | Neues aus der Community: Community-Forum

(c)2023 CAD.de | Impressum | Datenschutz