| | | 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 (2021 / mal gelesen)
|
SifiCAD Mitglied Konstrukteur
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 / zitieren --> Unities abgeben:
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
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 / zitieren --> Unities abgeben: Nur für SifiCAD
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
Beiträge: 35 Registriert: 17.02.2016 Inventor 2019 Win7 64Bit
|
erstellt am: 09. Okt. 2017 16:20 <-- editieren / zitieren --> Unities abgeben: Nur für SifiCAD
|
SifiCAD Mitglied Konstrukteur
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 / zitieren --> Unities abgeben:
|
FroSte Mitglied Bauingenieur
Beiträge: 20 Registriert: 09.06.2009 Inventor 2021
|
erstellt am: 26. Okt. 2017 15:24 <-- editieren / zitieren --> Unities abgeben: Nur für SifiCAD
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
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 / zitieren --> Unities abgeben: Nur für SifiCAD
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
Beiträge: 20 Registriert: 09.06.2009 Inventor 2021
|
erstellt am: 27. Okt. 2017 16:41 <-- editieren / zitieren --> Unities abgeben: Nur für SifiCAD
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
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 / zitieren --> Unities abgeben: Nur für SifiCAD
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
Beiträge: 20 Registriert: 09.06.2009 Inventor 2021
|
erstellt am: 31. Mai. 2022 14:39 <-- editieren / zitieren --> Unities abgeben: Nur für SifiCAD
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
Beiträge: 601 Registriert: 19.09.2007 Inventor Professional 2020 WinX
|
erstellt am: 23. Jun. 2022 17:32 <-- editieren / zitieren --> Unities abgeben: Nur für SifiCAD
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
Beiträge: 20 Registriert: 09.06.2009 Inventor 2021
|
erstellt am: 28. Jun. 2022 20:03 <-- editieren / zitieren --> Unities abgeben: Nur für SifiCAD
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 zusammenDim 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
Beiträge: 601 Registriert: 19.09.2007 Inventor Professional 2020 WinX
|
erstellt am: 29. Jun. 2022 17:54 <-- editieren / zitieren --> Unities abgeben: Nur für SifiCAD
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 SubPrivate 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
Beiträge: 601 Registriert: 19.09.2007 Inventor Professional 2020 WinX
|
erstellt am: 29. Jun. 2022 19:09 <-- editieren / zitieren --> Unities abgeben: Nur für SifiCAD
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
Beiträge: 20 Registriert: 09.06.2009 Inventor 2021
|
erstellt am: 30. Jun. 2022 11:03 <-- editieren / zitieren --> Unities abgeben: Nur für SifiCAD
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
Beiträge: 20 Registriert: 09.06.2009 Inventor 2021
|
erstellt am: 30. Jun. 2022 11:46 <-- editieren / zitieren --> Unities abgeben: Nur für SifiCAD
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 >>)
|