| | | Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte |
Autor
|
Thema: Bauteilparameter nach Excel exportieren (674 mal gelesen)
|
Chris0804 Mitglied Maschinenbauingenieur
Beiträge: 22 Registriert: 16.08.2021 Inventor 2019 Inventor 2020
|
erstellt am: 25. Okt. 2021 11:19 <-- editieren / zitieren --> Unities abgeben:
Hallo zusammen, ich verzweifel gerade an einem Problem. Und zwar möchte ich von allen Bauteilen, die in einem bestimmten Verzeichnis liegen ein paar Bauteilparameter nach Excel exportieren. Wenn ich das Makro zum exportieren manuell für ein Bauteil starte, funktioniert auch alles wunderbar. Sobald ich allerdings das Makro zum Parameter-exportieren durch ein anderes Makro, mithilfe einer Loop-Anweisung, starte bekomme ich beim zweiten Bauteil einen Laufzeitfehler 1004: Anwendungs- oder objektdefinierten Fehler für die Zeile, die die erste unbeschriebene Zeile in der Excel-Tabelle ermittelt (im Code Fett markiert). Ich habe schon alles mögliche versucht und recherchiert, weiß aber nicht wo mein Fehler liegt. Ich wäre wirklich für jeden Hinweis dankbar. Hier der Quellcode mit der Loop zum Öffnen der Bauteile: Code: Public Sub Dateien_öffnen() Dim strFileName As String Dim strPath As StringDim oPartDoc As PartDocument Dim DocPfad As String Set oPartDoc = ThisApplication.ActiveDocument If oPartDoc Is Nothing Then DocPfad = "" Else DocPfad = oPartDoc.FullFileName End If strPath = "Pfad zu den Part-Dateien" ' Application.ScreenUpdating = False strFileName = Dir$(strPath & "*.ipt") ' Dir gibt den ersten Dateinamen zurück, der dem Pfadnamen entspricht ' If Right(strPath, 1) <> "\" Then strPath = strPath & "\" Do While strFileName <> "" If Not strFileName = DocPfad Then ThisApplication.Documents.Open (strPath & strFileName) Debug.Print strFileName Call ParamExport ThisApplication.ActiveDocument.Close strFileName = Dir$() ' leeres Dir gibt alle weiteren Pfadnamen innerhalb des Verzeichnisses zurück Else strFileName = Dir$() End If Loop End Sub
und hier der Code zum Parameter exportieren: Code: Public Sub ParamExport() ' Datei Pfade: Dim Pfad_Excel As String Pfad_Excel = "Dateipfad Excel-Datei für Ausgabe" Dim Pfad_STEP As String Pfad_STEP = "Dateipfad Step-Datei" ' Excel-Variablen deklarieren Dim iRow As Long Dim i As Long Dim XL As Object Dim xlWB As Object Dim xlWS As Object ' Variable zur Bestimmung der Dim v1 As Double ' Rohvolumendifferenz Dim F_geo As Double ' Geometriefaktor bei Rohvoldiff-berechnung Dim k As Integer ' Gewindeanzahl allgemein Dim iVerschGewinde As Integer ' unterschiedlichen Gewinde Dim KantenAnz As Integer ' Kantenanzahl Dim AnzVertices As Integer ' Scheitelpunkte Dim AnzFaces As Integer ' Oberflächen Dim cntLines As Integer ' Anzahl der Zeilen im ASCII-Code der STEP-Datei (bisher bestes Kriterium zum automatisierten ' bestimmen der Komplexität) Dim Gewinde(2, 100) As String ' Array zum Vergleichen der Gewindeeigenschaften Set XL = CreateObject("Excel.Application") Set xlWB = XL.Workbooks.Open(Pfad_Excel) Set xlWS = xlWB.Sheets(1) XL.Application.Visible = False Dim oParams As Parameters Dim oPartDoc As PartDocument Dim oCompDef As ComponentDefinition Dim sDocName As String ' Blattname xlWB.Sheets(1).Activate ' Set xlWS = xlWB.ActiveSheet If ThisApplication.ActiveDocumentType <> kPartDocumentObject Then MsgBox "Only Part document", vbCritical Exit Sub End If Set oCompDef = ThisApplication.ActiveDocument.ComponentDefinition ' Abkürzung des Pfads der ComponentDefinitions Set oPartDoc = ThisApplication.ActiveDocument ' Abkürzung Pfad des geöffneten Part-Dokuments Call Count_Threads(iVerschGewinde, k) ' Aufruf Unterprog. Gewinde zählen Call Count_Edges(KantenAnz) ' Aufruf Unterprog. Kanten zählen Call Vertices(AnzVertices) ' Aufruf Unterprog. Scheitelpunkte zählen Call Faces(AnzFaces) ' Aufruf Unterprog. Oberflächen zählen Call ExportToSTEP(cntLines, Pfad_STEP) ' Aufruf Unterprog. Zeilenanzahl im ASCII-Code der STEP-Datei zählen ' Spaltenbeschriftungen in Zeilen der Excel einfügen: xlWS.Cells(1, 1).Value = "Bauteilnr." xlWS.Cells(1, 2).Value = "Name" xlWS.Cells(1, 3).Value = "Rohvolumendifferenz" xlWS.Cells(1, 4).Value = "Material" xlWS.Cells(1, 5).Value = "Oberfläche" xlWS.Cells(1, 6).Value = "Volumen" xlWS.Cells(1, 7).Value = "Bohrung" xlWS.Cells(1, 8).Value = "unterschiedl. Gewinde" xlWS.Cells(1, 9).Value = "Gewinde" xlWS.Cells(1, 10).Value = "Features" xlWS.Cells(1, 11).Value = "Kanten" xlWS.Cells(1, 12).Value = "Scheitelpunkte" xlWS.Cells(1, 13).Value = "Oberflächen" xlWS.Cells(1, 14).Value = "Stp - Zeilen" Dim Rückgabewert As Integer Rückgabewert = MsgBox("Handelt es sich um ein rundes Rohteil?", vbYesNo, "Rohteilabfrage") If Rückgabewert = vbYes Then F_geo = 0.785 'Call Rohvoldiff_rund(v1) ' Rohvolumendifferenz für rundes Rohteil wird berechnet Else F_geo = 1 'Call Rohvoldiff_eckig(v1) ' Rohvolumendifferenz für eckiges Rohteil wird berechnet End If Call Rohvoldiff(v1, F_geo) ' nächste freie Zeile ermitteln: iRow = xlWS.Cells(Rows.Count, 1).End(xlUp).Row + 1 'Daten in die Excel schreiben: xlWS.Cells(iRow, 1).Value = oPartDoc.PropertySets("User Defined Properties").item("Artikelnummer").Value 'xlWS.Cells(iRow, 2).Value = oPartDoc.PropertySets("Inventor Summary Information").item("Title").Value xlWS.Cells(iRow, 3).Value = v1 xlWS.Cells(iRow, 4).Value = oPartDoc.ActiveMaterial.DisplayName xlWS.Cells(iRow, 5).Value = Round(oPartDoc.ComponentDefinition.MassProperties.Area, 3) xlWS.Cells(iRow, 6).Value = Round(oPartDoc.ComponentDefinition.MassProperties.Volume, 3) xlWS.Cells(iRow, 7).Value = oPartDoc.ComponentDefinition.Features.HoleFeatures.Count xlWS.Cells(iRow, 8).Value = iVerschGewinde xlWS.Cells(iRow, 9).Value = k xlWS.Cells(iRow, 10).Value = oPartDoc.ComponentDefinition.Features.Count xlWS.Cells(iRow, 11).Value = KantenAnz xlWS.Cells(iRow, 12).Value = AnzVertices xlWS.Cells(iRow, 13).Value = AnzFaces xlWS.Cells(iRow, 14).Value = cntLines 'Excel Speichern (und Schließen): xlWB.Save xlWB.Close Exit Sub End Sub
------------------ Gruß Chris
[Diese Nachricht wurde von Chris0804 am 25. Okt. 2021 editiert.] Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Chris0804 Mitglied Maschinenbauingenieur
Beiträge: 22 Registriert: 16.08.2021 Inventor 2019 Inventor 2020
|
erstellt am: 25. Okt. 2021 12:31 <-- editieren / zitieren --> Unities abgeben:
Ich habe die Lösung für mein Problem gefunden. Vielleicht hilft die Lösung ja noch jemandem. In der fehlerbehafteten Zeile: iRow = xlWS.Cells(Rows.Count, 1).End(xlUp).Row + 1 habe ich ein xlWS vor dem Rows.Count eingefügt und nun läuft es, also: iRow = xlWS.Cells(xlWS.Rows.Count, 1).End(xlUp).Row + 1 Ich frage mich zwar, warum das Makro mit der fehlerhaften Zeile funktioniert wenn ich es manuell starte, allerdings nicht wenn ich es durch das andere Makro starte. Trotzdem bin ich erstmal froh das es nun funktioniert. Sollte trotzdem noch jemand Optimierungsvorschläge oder ganz andere Ansätze für die Problematik haben, gerne her damit
------------------ Gruß Chris Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Chris0804 Mitglied Maschinenbauingenieur
Beiträge: 22 Registriert: 16.08.2021 Inventor 2019 Inventor 2020
|
erstellt am: 25. Okt. 2021 13:43 <-- editieren / zitieren --> Unities abgeben:
Nun habe ich eine weitere Herausforderung. Ist es möglich alle Dateien nicht nur aus einem Ordner, sondern auch aus Unterordnern nacheinander zu öffnen? Also im Prinzip genau so wie ich das oben gemacht habe, nur dass er auch die Dateien aus Unterordnern berücksichtigt? Vielen Dank im Voraus! ------------------ Gruß Chris Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
rkauskh Moderator Dipl.-Ing. (FH) Versorgungstechnik
Beiträge: 2166 Registriert: 15.11.2006 Windows 10 x64, AIP 2022
|
erstellt am: 25. Okt. 2021 21:00 <-- editieren / zitieren --> Unities abgeben: Nur für Chris0804
Hallo Statt Dir würde ich das Filesystem Object nehmen und rekursiv durch die Verzeichnisse laufen. Filter für nur Bauteile und Verzeichnis OldVersions auslassen habe ich mit eingebaut. Im VBA unter Extras --> Verweise das Häkchen beim "Microsoft Scripting Runtime" setzen falls noch nicht geschehen.
Code:
Option ExplicitPublic Sub Dateien_öffnen() Dim oPartDoc As PartDocument Set oPartDoc = ThisApplication.ActiveDocument Dim strPath As String Dim DocPfad As String If oPartDoc Is Nothing Then DocPfad = "" Else DocPfad = oPartDoc.FullFileName End If strPath = "Pfad zu den Part-Dateien" Call ListFiles(strPath, DocPfad) End Sub Private Sub ListFiles(ByVal sPath As String, ByVal DocPfad As String) Dim oFSO As Object Dim oFolder As Object Dim oSubFolder As Object Dim oFile As Object Set oFSO = CreateObject("Scripting.FileSystemObject") Set oFolder = oFSO.getfolder(sPath) 'Alle Dateien auflisten For Each oFile In oFolder.Files If Not oFile.Path = DocPfad Then If UCase(Right(oFile.Path, 3)) = "IPT" Then ThisApplication.Documents.Open (oFile.Path) Debug.Print oFile.Path Call ParamExport ThisApplication.ActiveDocument.Close End If End If Next oFile If oFolder.subfolders.Count > 0 Then For Each oSubFolder In oFolder.subfolders 'Alle Unterverzeichnisse verarbeiten (rekursiv) If Not UCase(oSubFolder.Name) = "OLDVERSIONS" Then Call ListFiles(oSubFolder.Path, DocPfad) End If Next oSubFolder End If Set oFSO = Nothing Set oFile = Nothing Set oFolder = Nothing Set oSubFolder = Nothing End Sub
------------------ MfG Ralf RKW Solutions GmbH www.RKW-Solutions.com Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Chris0804 Mitglied Maschinenbauingenieur
Beiträge: 22 Registriert: 16.08.2021 Inventor 2019 Inventor 2020
|
erstellt am: 26. Okt. 2021 13:37 <-- editieren / zitieren --> Unities abgeben:
|
| Anzeige.:
Anzeige: (Infos zum Werbeplatz >>)
|