Hot News:

Unser Angebot:

  Foren auf CAD.de (alle Foren)
  Inventor VBA
  Bauteilparameter nach Excel exportieren

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:  Bauteilparameter nach Excel exportieren (674 mal gelesen)
Chris0804
Mitglied
Maschinenbauingenieur


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

Beiträge: 22
Registriert: 16.08.2021

Inventor 2019
Inventor 2020

erstellt am: 25. Okt. 2021 11:19    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 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 String

Dim 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


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

Beiträge: 22
Registriert: 16.08.2021

Inventor 2019
Inventor 2020

erstellt am: 25. Okt. 2021 12:31    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

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


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

Beiträge: 22
Registriert: 16.08.2021

Inventor 2019
Inventor 2020

erstellt am: 25. Okt. 2021 13:43    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

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




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

Beiträge: 2166
Registriert: 15.11.2006

Windows 10 x64, AIP 2022

erstellt am: 25. Okt. 2021 21:00    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 Chris0804 10 Unities + Antwort hilfreich

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 Explicit

Public 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


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

Beiträge: 22
Registriert: 16.08.2021

Inventor 2019
Inventor 2020

erstellt am: 26. Okt. 2021 13:37    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 Ralf,

ein paar Kleinigkeiten musste ich noch anpassen, bspw. die Variable sPath in strPath umbenennen, aber es läuft einwandfrei.

Vielen Dank.

------------------
Gruß
Chris

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