Hot News:

Unser Angebot:

  Foren auf CAD.de (alle Foren)
  Inventor VBA
  Step Baugruppe für DXF in Blechteile konvertieren

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:  Step Baugruppe für DXF in Blechteile konvertieren (1175 mal gelesen)
minimal
Mitglied
Konstrukteur

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

Beiträge: 1
Registriert: 15.06.2021

Inventor 2020; WIN7

erstellt am: 15. Jun. 2021 15: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


6000-BT-2x.stp

 
Moin moin Leutz,
ich habe mal eine Frage zur Inventorsteuerung via VBA..

Gegeben ist folgender Sachverhalt: (Inventor 2020 Professional / Win7)
Ich bekomme eine Step - Baugruppe (Siehe Anhang) und benötige von jedem darin enthaltenen Volumenkörper eine DXF. Meine Aufgabe besteht darin, jeden Volumenkörper aus der Baugruppe in ein Blechteil zu konvertieren. Dies geht leider nur (meines Wissens nach), indem ich für jeden Volumenkörper eine Basisfläche definiere. Jedem Volumenkörper die Basisfläche zuzuordnen kann äußerst Umfangreich sein umso komplexer die Step – Baugruppe ist…
Nun meine Frage:
Gibt es via VBA eine Möglichkeit die Basisfläche (Ich nehme mal an das es die Fläche eine Körpers mit dem größten Flächeninhalt ist..?!) automatisch jedem Volumenkörper zuzuordnen um dann automatisch eine Abwicklung /  DXF erstellen zu können?

Also quasi ein „ multi DXF erstellen aus einer Step – Baugruppe“..

Bin euch über jede Idee / Vorschlag dankbar.

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: 15. Jun. 2021 17:45    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 minimal 10 Unities + Antwort hilfreich

EIBe 3D
Mitglied
Dipl. - Ing. (FH)


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

Beiträge: 267
Registriert: 24.01.2020

HP Z4 G4 Workstation
Xeon 3,6 32GB
Nvidia P2000
WIN10
SW2015 SP5.0
SW2017
*************
Inv2018 akt.SP

erstellt am: 16. Jun. 2021 07:27    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 minimal 10 Unities + Antwort hilfreich

Hallo zusammen,

[/Halb OT on]

immer wieder schön zu sehen was für tolle Vorlagen die Jungs (und Mädels?) von Mod the machine für uns erstellen.

[/Halb OT off]


Grüße

EIBe 3D

Edit 1: @minimal: Willkommen im Forum

[Diese Nachricht wurde von EIBe 3D am 16. Jun. 2021 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: 16. Jun. 2021 09:15    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 minimal 10 Unities + Antwort hilfreich

Die genannte Lösung von Mod the machine konnte ich nun für Deine Anwendung etwas aufbohren.

Ich hab meinen "Abwicklungs-Export" ergänzt und eine Logik zum Öffnen einer beliebigen Stp. Im einfachsten Fall ist es damit eine 1-Klick-Lösung, wenn Du vorher den Pfad der step-Datei in die Zwischenablage von Windows kopiert hast. Bei Win7 im Dateiexplorer: Umschalt + rechte Maustaste -> als Pfad kopieren
Dann das Sub ConvertToSheetMetal_Main aufrufen.

Einige weitere Gedanken als Kommentare im Code...

Code:
Option Explicit

Const sPfad As String = "C:\temp\bla\"  'Ablagepfad für dxf; muss existieren sonst Fehler

Private gsFertigMsg As String  'verwendet für Schlussmeldung

'----------------
' https://modthemachine.typepad.com/my_weblog/2020/09/generate-flat-pattern-for-3d-sheet-metal-files.html
' leicht angepasst (ausgehend vom Import einer Bgr (statt Einzelteil) und dann Schleife durch alle Einzelteile)


Sub ConvertToSheetMetal_Main()

  Dim path As String: path = "C:\temp\6000-BT-2x.stp"
 
  'Dateiname einer beliebigen STEP
  path = get_StpFile_Clipboard_or_Dialog
  If "" = path Then Exit Sub    'z.b. falls der Öffnen-Dialog abgebrochen wurde

  Dim asmDoc As AssemblyDocument
  Set asmDoc = ThisApplication.Documents.Open(path)
  'hier wird ein Fehler auftreten, wenn das Step keine Bgr. enthält!

   
    'Variable auf Modulebene für Schlussmeldung vorbereiten (befüllt im dxfExp.)
    gsFertigMsg = "in diesem Verzeichnis" & vbCrLf
    gsFertigMsg = gsFertigMsg & vbTab & sPfad & vbCrLf
    gsFertigMsg = gsFertigMsg & "wurden folgende Dateien erzeugt: " & vbCrLf & vbCrLf
   
    'es wäre vmtl. noch gut den folgenden Ablauf in eine einzige Rückgängig-Aktion zu packen
    Dim oTxnMgr As TransactionManager
    '... [fehlt]
   
   
    'Schleife durch alle Dokumente, der aktiven Bgr
    Dim tmpDoc As Document, doc As PartDocument
    For Each tmpDoc In asmDoc.AllReferencedDocuments    'asmDoc.ReferencedDocuments liefert nur die Unterbgr.
       
        If TypeOf tmpDoc Is PartDocument Then
           
            '### Displayupdate ausschalten, dann sollte es etwas schneller laufen
            'ThisApplication.ScreenUpdating = False 'erst wenn es ausreichend gut läuft...!
           
            Set doc = tmpDoc
           
            'Aufruf des Sub für das einzelne Bauteil
            Call ConvertToSheetMetal(doc)
           
            ThisApplication.ScreenUpdating = True
           
            'Export vom dxf der Abwicklung
            Dim sDateiName As String
            sDateiName = Left(doc.DisplayName, Len(doc.DisplayName) - 4)  'Dateiname ohne Endung (.ipt)
            Call WriteSheetMetalDXF(sPfad, sDateiName, doc)
       
        Else 'kein part
            'nix zu tun
        End If
  Next
 
  'Schlussmeldung
  MsgBox gsFertigMsg, vbOKOnly, "Fertig"
 
End Sub

Sub ConvertToSheetMetal(doc As PartDocument)

    ' Turn it into a sheet metal part
    doc.SubType = "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}"
   
    Dim cd As SheetMetalComponentDefinition
    Set cd = doc.ComponentDefinition
   
    cd.UseSheetMetalStyleThickness = False
    cd.Thickness.Value = GetThickness(cd.SurfaceBodies(1))
   
    Call cd.Unfold
   
    '### das Bauteil wird in neuem View geöffnet, wieder schließen (sonst schlägt das nächste Unfold fehl)
    cd.FlatPattern.ExitEdit
    If ThisApplication.ActiveView.Document Is doc Then ThisApplication.ActiveView.Close
   
End Sub

Function GetThickness(sb As SurfaceBody) As Double    ' unverändert [KraBBy]
  ' Find biggest face
  Dim f As Face
  Dim bf As Face
  Dim area As Double
  For Each f In sb.Faces
    ' Only care about planar faces
    If TypeOf f.Geometry Is Plane And f.Evaluator.area > area Then
      Set bf = f
      area = f.Evaluator.area
    End If
  Next
 
  ' Find the opposite face
  Dim p As Plane
  Set p = bf.Geometry
 
  Dim pt1 As Point
  Set pt1 = bf.PointOnFace
 
  Dim tr As TransientGeometry
  Set tr = ThisApplication.TransientGeometry
 
  Dim objs As ObjectsEnumerator
  Dim pts As ObjectsEnumerator
  Dim n As UnitVector
  ' We have to search in the opposite direction
  ' of the face's normal vector
  If bf.IsParamReversed Then
    Set n = p.Normal
  Else
    Set n = tr.CreateUnitVector( _
      -p.Normal.x, -p.Normal.y, -p.Normal.z)
  End If
  ' objs(2) should be the opposite face
  ' but we do not need it, the intersection point
  ' is enough, i.e. pts(2)
  Call sb.FindUsingRay(pt1, n, 0, objs, pts)
 
  ' The first point found will be on the same face
  ' The second one will be on the face opposite
  Dim pt2 As Point
  Set pt2 = pts(2)
 
  GetThickness = pt1.DistanceTo(pt2)
End Function


Sub TestFlatPattern()    ' nicht implementiert
  Dim doc As PartDocument
  Set doc = ThisApplication.ActiveDocument
 
  Dim cd As SheetMetalComponentDefinition
  Set cd = doc.ComponentDefinition
 
  Dim tr As TransientBRep
  Set tr = ThisApplication.TransientBRep
 
  Dim objs As ObjectCollection
  Set objs = ThisApplication.TransientObjects.CreateObjectCollection
  Call objs.Add(cd.SurfaceBodies(1))
  Call objs.Add(cd.FlatPattern.SurfaceBodies(1))
  Set objs = tr.GetIdenticalBodies(objs)
 
  If objs.Count > 0 Then
    MsgBox ("The flat pattern body is the same as the original body")
  End If
End Sub

'########################


Public Sub WriteSheetMetalDXF(sPfad As String, sDatName As String, Optional oDoc As Document)
' bildet den Befehl ab
' Abwicklung -> Kopie speichern unter -> dxf ...
' KraBBy 18.03.2015
'

On Error GoTo ErrHnd

    ' Make sure the document is a sheet metal document.
    If Not (oDoc.SubType = "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}") Then
        MsgBox "Das ref. Dokument ist kein Blechteil!" & vbCrLf _
                & oDoc.DisplayName, vbInformation + vbOKOnly, "no Sheet Metal"
        Exit Sub
    End If
   
    ' Get the sheet metal component definition.  Because this is a part document whose
    ' sub type is sheet metal, the document will return a SheetMetalComponentDefinition
    ' instead of a PartComponentDefinition.
    Dim oSheetMetalCompDef As SheetMetalComponentDefinition
    Set oSheetMetalCompDef = oDoc.ComponentDefinition
   
    Dim oFlat As FlatPattern
    Set oFlat = oSheetMetalCompDef.FlatPattern
   
    If oFlat Is Nothing Then    'keine Abwicklung      'Block hinzu  26.06.2018
        oSheetMetalCompDef.Unfold  'Abwicklung erzeugen
        'es gibt auch die Methode Unfold2, dann mit Angabe der "Basisfläche"
        Set oFlat = oSheetMetalCompDef.FlatPattern
    End If
   
    If oFlat Is Nothing Then    'erneute Prüfung
        'Abwicklung konnte auch nicht erzeugt werden
        MsgBox "Das ref. Dokument enthält keine Abwicklung!" & vbCrLf _
                & oDoc.DisplayName, vbInformation + vbOKOnly, "no Flat"
        Exit Sub
    End If
   
'Get the DataIO object.
Dim oDataIO As DataIO
Set oDataIO = oDoc.ComponentDefinition.DataIO

' Build the string that defines the format of the DXF file.
' Parameter aus Hilfe zu DataIO Interface
Dim sOut As String
sOut = "FLAT PATTERN DXF?"
sOut = sOut & "AcadVersion=R12"    '2010, 2007, 2004, 2000, or R12
sOut = sOut & "&OuterProfileLayer=IV_outer"
sOut = sOut & "&InteriorProfilesLayer=IV_inner"
sOut = sOut & "&FeatureProfilesLayer=IV_Profiles"
sOut = sOut & "&TangentLayer=IV_Tangent"
'sOut = sOut & "&BendLayer=IV_Bend"    'Alternativ zu BendUp/-Down
sOut = sOut & "&BendUpLayer=IV_BendUp"
sOut = sOut & "&BendDownLayer=IV_BendDown"
sOut = sOut & "&ToolCenterLayer=IV_ToolCenter"
sOut = sOut & "&ArcCentersLayer=IV_ArcCenter"
'sOut = sOut & "&SimplifySplines=True"    'auskom.; ansonsten Fehler beim Export !?! 25.06.2018
'sOut = sOut & "&SplineTolerance=0.01"    'auskom.; -"-
sOut = sOut & "&TangentLayerColor=255;0;0" 'Beispiel Farbeinstellung (RGB)
sOut = sOut & "&InvisibleLayers=IV_ArcCenter" 'hier aufgelistete Layer (getrennt durch ";"), werden nicht exportiert

'Datei bereits vorhanden?
Dim sFileName As String
sFileName = sPfad & sDatName  'ohne Dateiendung!
If Not ("" = Dir(sFileName & ".dxf")) Then
    'Datei existiert
    Dim vInput
    vInput = MsgBox(sFileName & ".dxf" & vbCrLf & "Datei existiert bereits!" & vbCrLf _
    & "Überschreiben?", vbYesNoCancel + vbExclamation, "Datei existiert bereits")
    If vbYes = vInput Then
        Kill sFileName & ".dxf"  'existierende Datei löschen
    ElseIf vbNo = vInput Then
        Dim iCount As Integer
        iCount = 0
        Do
            sFileName = sFileName & "_"    'Dateiname ändern
            sDatName = sDatName & "_"  'auch hier ändern damit gsFertigMsg passt
            iCount = iCount + 1
            If 5 < iCount Then  'Endlosschleife verhindern
                MsgBox "Kein DXF erzeugt!" & vbCrLf & "es existieren bereits mehrere Dateien mit diesem Dateinamen (und angehängtem '_')" _
                    , vbCritical, "jetzt is aber mal gut!"
                Exit Sub
            End If
        Loop Until "" = Dir(sFileName & ".dxf")
    Else    'Cancel gedrückt oder MsgBox geschlossen (oben rechts)
        MsgBox "Kein DXF erzeugt!", vbOKOnly, "Abbruch durch Benutzer"
        Exit Sub
    End If
End If

' Create the DXF file.
oDataIO.WriteDataToFile sOut, sFileName & ".dxf"

'Schlussmeldung
'MsgBox "Export erfolgt" & vbCrLf & sFilename & ".dxf", vbInformation, "DXF (Flat) Fertig"
gsFertigMsg = gsFertigMsg & sDatName & ".dxf" & vbCrLf


'Aufräumen
Set oSheetMetalCompDef = Nothing
Set oFlat = Nothing
Set oDataIO = Nothing

Exit Sub

ErrHnd:
MsgBox "Fehler in Sub 'WriteSheetMetalDXF': " & vbCrLf & vbCrLf & Err.Description, vbCritical, "Err.Number: " & Err.Number
End Sub


Private Function get_StpFile_Clipboard_or_Dialog() As String
' Pfad aus der Zwischenablage nehmen (Prüfung ob Datei vorhanden, auch Dateiendung)
' sonst OpenDialog

    'Titel für Msgbox(en)
    Dim sMsgTitle As String
    sMsgTitle = "Makro 'Import_stp'"
   
    'Win-Zwischenablage auswerten
    Dim sFile As String, bFileDiag As Boolean
    sFile = txt_FromClipboard()
    sFile = Replace$(sFile, Chr(34), "")    'Anführungszeichen ggf. entfernen
    If "" = sFile Then
        'kein Text in Zwischenablage
        bFileDiag = True
    ElseIf Not Test_FileExists(sFile) Then ' "" = Dir$(sFile) Then  'Dir() liefert bei manchen Inputs einen Fehler
        'es ist kein Pfad oder Datei existiert nicht
        bFileDiag = True
    ElseIf ".stp" = LCase$(Right$(sFile, 4)) Or ".step" = LCase$(Right$(sFile, 5)) Then
        'die Datei existiert und hat die richtige Dateiendung
        'kein Dialog erforderlich
        bFileDiag = False
    Else
        'Datei existiert, hat aber nicht die richtige Dateiendung
        MsgBox "In der Zwischenablage ist folgende Datei angegeben:" & vbCrLf _
            & sFile & String(2, vbCrLf) _
            & "Dieses Makro funktioniert aber nur für .stp (.step)", vbInformation + vbOKOnly, sMsgTitle & " - abgebrochen"
        Exit Function
    End If
   
    'Öffnen-Dialog
    If bFileDiag Then
        Dim oFileDlg As Inventor.FileDialog
        Call ThisApplication.CreateFileDialog(oFileDlg)
        'oFileDlg.InitialDirectory = FileSystem.getPathName(???)    'was könnte ein sinnvolles Verz. sein?
       
        oFileDlg.DialogTitle = sMsgTitle & " - Datei für Import angeben"
        oFileDlg.filter = "STEP Files (*.stp;*.step)|*.stp;*.step|All Files (*.*)|*.*"
        oFileDlg.FilterIndex = 1
        oFileDlg.CancelError = False
        'On Error Resume Next
        oFileDlg.ShowOpen
        If "" = oFileDlg.Filename Then
            MsgBox "Aktion abgebrochen.", vbOKOnly, "nichts passiert"
            Exit Function
        Else
            sFile = oFileDlg.Filename
        End If
        Set oFileDlg = Nothing
    Else: 'nix, unten weiter (sFile schon aus Zwischenablage gesetzt
    End If
   
    'sFile ist nun mit Pfad/Dateiname einer stp/STEP befüllt (oder das Makro wurde abgebrochen)
    '-> Rückgabewert der Fkt
    get_StpFile_Clipboard_or_Dialog = sFile
   
    Set oFileDlg = Nothing
End Function


Private Function txt_FromClipboard() As String
'gibt den Text aus der Zwischenablage von Windows zurück
'Rückgabe "", wenn kein Text in Zwischenablage

    Dim o As DataObject
    Set o = New DataObject
    o.GetFromClipboard
    On Error Resume Next
    txt_FromClipboard = o.GetText(1)    'Rückgabewert
    If Not 0 = Err.Number Then 'wenn etwas anderes als Text in der ZwAblage ist, schlägt obige Z. fehl
        On Error GoTo 0
        txt_FromClipboard = ""
    End If
    Set o = Nothing
End Function

Public Function Test_FileExists(sFile As String) As Boolean
' existiert Datei?
' Rückgabewert True:  Datei existiert
On Error GoTo err_handler
    Dim fs As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    If fs.FileExists(sFile) Then
        'MsgBox "Datei existiert nicht", vbInformation, "Fehler in 'FileExists'"
        Test_FileExists = True
    Else
        Test_FileExists = False
    End If
    Set fs = Nothing
    Exit Function
err_handler:
    MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, "Fehler im Funktion 'FileExists'"
End Function



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

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

EIBe 3D
Mitglied
Dipl. - Ing. (FH)


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

Beiträge: 267
Registriert: 24.01.2020

HP Z4 G4 Workstation
Xeon 3,6 32GB
Nvidia P2000
WIN10
SW2015 SP5.0
SW2017
*************
Inv2018 akt.SP

erstellt am: 17. Jun. 2021 15:35    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 minimal 10 Unities + Antwort hilfreich

Hübsch, hübsch 

zu beachten wäre noch eine Abfrage ob es sich um ein multibody part handelt. Bei Step-Importen nicht unüblich.

Dort läuft "Call cd.Unfold" in einen Fehler. Ich meine seit irgendeiner Version wurden die Abwicklungen für multibody parts aber unterstützt dort sollte es klappen.

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: 17. Jun. 2021 17:02    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 minimal 10 Unities + Antwort hilfreich

Hi EIBe 3D,

ist schon berücksichtigt 
Zumindest tritt vorher schon ein Fehler auf.

Zitat:
[...]
  Dim asmDoc As AssemblyDocument
  Set asmDoc = ThisApplication.Documents.Open(path)
  'hier wird ein Fehler auftreten, wenn das Step keine Bgr. enthält!
[...]

Wenn die Logik auf für multibody parts (MBP) funktionieren soll, wird man noch an ein par mehr Schrauben drehen müssen. Mehrere Abwicklungen klappen darin ja nicht (oder?). Dh. man könnte evtl. die ganzen Blechstile mit den unterschiedlichen Dicken im MBP verwalten, bräuchte aber für die Abwicklung wieder eine AK (abgeleitete Komponente) von jedem Einzelteil. Die Anpassung am Makro wäre kleiner, wenn man nur auf das Öffnen der STEP verzichtet und mit der geöffneten Baugruppe loslegt und diese eben vorher (von Hand per AK) erzeugt.

Da fällt mir ein: in diesem Fall/Beispiel ist ein MBP vielleicht nicht üblich/sinnvoll. Da ginge ja die Info bzgl. Gleichteilen verloren, weil jedes an einer anderen Stelle im Raum sitzt. Im Beispiel waren gleiche Teile mehrmals verbaut (jetzt aus dem Kopf, ohne es nochmal geöffnet zu haben).

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

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

EIBe 3D
Mitglied
Dipl. - Ing. (FH)


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

Beiträge: 267
Registriert: 24.01.2020

HP Z4 G4 Workstation
Xeon 3,6 32GB
Nvidia P2000
WIN10
SW2015 SP5.0
SW2017
*************
Inv2018 akt.SP

erstellt am: 18. Jun. 2021 09:06    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 minimal 10 Unities + Antwort hilfreich

Morgen,

zugegeben das Beispiel habe ich mir bis eben nicht angesehen. Da ich zufällig aber gerade einen ähnlichen Fall zur Untersuchung reinbekommen habe, fiel mir auf das einige, aus Step erzeugte Bauteile, als MBPs daher kommen. Diese liegen hier innerhalb der BG-Struktur vor. Ich schließe MBPs von vornherein aus der Konvertierung aus. Die Vorraussetzungen bei meiner Import-Step und Anforderungen sind aber auch andere.

Was mir nun beim Vergleich des Beispiels von minimal und meinem aufgefallen ist: In seinem sind Gleichteile vorhanden, bei mir hat jede Kopie einer Komponente einen eigenen Bauteilnamen enthalten. Schlecht in meinem Fall.

Auch eine mittlere Herausforderung ist das sinnvolle Herausfiltern von ungefalteten Blechen (bspw. Flanschplatte) wenn ich eine Kontrolle auf Abwicklungskörper ungleich Ursprungskörper ähnlich wie im verlinkten Beispiel durchführe (ähnlich weil

Code:
GetIdenticalBodies(objs)
erst in INV2021 eingeführt wurde).


Hier mal meine aktuelle Abfrage dazu:

Code:

Private Function TestFlatPattern() As Boolean
    Dim doc As PartDocument
    Set doc = ThisApplication.ActiveDocument
   
    Dim equalBody As Boolean
   
    Dim cd As SheetMetalComponentDefinition
    Set cd = doc.ComponentDefinition
       
    Dim oSurfaceBody01 As Inventor.SurfaceBody, oSurfaceBody02 As Inventor.SurfaceBody
   
    Set oSurfaceBody01 = cd.SurfaceBodies(1)
    Set oSurfaceBody02 = cd.FlatPattern.SurfaceBodies(1)
   
    Dim oFaces01 As Inventor.Faces, oFaces02 As Inventor.Faces
   
    Set oFaces01 = oSurfaceBody01.Faces
    Set oFaces02 = oSurfaceBody02.Faces
   
    Dim oEdges01 As Inventor.Edges, oEdges02 As Inventor.Edges
   
    Set oEdges01 = oSurfaceBody01.Edges
    Set oEdges02 = oSurfaceBody02.Edges
   
    Dim baseFace As Inventor.face
   
    Set baseFace = cd.FlatPattern.baseFace
     
   
    If oFaces01.Count = oFaces02.Count Then
        If oEdges01.Count = oEdges02.Count Then
            equalBody = True
        End If
    End If
   
   
    TestFlatPattern = True
   
    If equalBody Then
        If Not isFlatSheet(oSurfaceBody01, baseFace) Then TestFlatPattern = False
    End If
   
'    MsgBox TestFlatPattern
   
End Function

Private Function isFlatSheet(SurfaceBody As SurfaceBody, baseFace As face) As Boolean '(SurfaceBody As SurfaceBody) As Boolean

    Dim baseCounterFace As face
   
    ' Find the opposite face
    Dim Plane As Plane
    Set Plane = baseFace.Geometry
   
    Dim pt1 As Point
    Set pt1 = baseFace.PointOnFace
   
    Dim tr As TransientGeometry
    Set tr = ThisApplication.TransientGeometry
   
    Dim objs As ObjectsEnumerator
    Dim pts As ObjectsEnumerator
    Dim n As UnitVector
    ' We have to search in the opposite direction
    ' of the face's normal vector
    If baseFace.IsParamReversed Then
        Set n = Plane.Normal
    Else
        Set n = tr.CreateUnitVector( _
        -Plane.Normal.x, -Plane.Normal.y, -Plane.Normal.Z)
    End If
   
    ' objs(2) should be the opposite face
    Call SurfaceBody.FindUsingRay(pt1, n, 0, objs, pts)
   
    Set baseCounterFace = objs(2)
   
    If Round(baseFace.Evaluator.area, 5) = Round(baseCounterFace.Evaluator.area, 5) Then isFlatSheet = True

End Function


Mein Vergleich geht davon aus, dass sich bei einem entfalteten Blech die Anzahl der Flächen und Kanten ändern muss damit nicht die gleiche Geometrie vorliegt. Dann könnte es aber immer noch ein ungefaltetes Blechteil oder eine sonstige beliebige Geometrie sein. Hat die Gegenfläche der Basisfläche jedoch den gleichen Flächeninhalt gehe ich davon aus, dass es sich wohl um ein ungefaltetes Blechteil handeln muss. Ist beides nicht der Fall gibt TestFlatPattern False zurück und über ein UndoTransaction mache ich die gesamte Konvertiererei rückgängig. Bisherige Tests bestätigen recht hohe Wirksamkeit 

Grüße

EIB 3D

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

EIBe 3D
Mitglied
Dipl. - Ing. (FH)


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

Beiträge: 267
Registriert: 24.01.2020

HP Z4 G4 Workstation
Xeon 3,6 32GB
Nvidia P2000
WIN10
SW2015 SP5.0
SW2017
*************
Inv2018 akt.SP

erstellt am: 18. Jun. 2021 09:40    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 minimal 10 Unities + Antwort hilfreich

Zitat:
Bisherige Tests bestätigen recht hohe Wirksamkeit

Kaum geschrieben schon einen Fall gehabt wo es nciht passt :D

Änderungen:

Code:

Private Function TestFlatPattern() As Boolean
    Dim doc As PartDocument
    Set doc = ThisApplication.ActiveDocument
   
    Dim equalBody As Boolean
   
    Dim cd As SheetMetalComponentDefinition
    Set cd = doc.ComponentDefinition
       
    Dim oSurfaceBody01 As Inventor.SurfaceBody, oSurfaceBody02 As Inventor.SurfaceBody
   
    Set oSurfaceBody01 = cd.SurfaceBodies(1)
    Set oSurfaceBody02 = cd.FlatPattern.SurfaceBodies(1)
   
    Dim oFaces01 As Inventor.Faces, oFaces02 As Inventor.Faces
   
    Set oFaces01 = oSurfaceBody01.Faces
    Set oFaces02 = oSurfaceBody02.Faces
   
    Dim oEdges01 As Inventor.Edges, oEdges02 As Inventor.Edges
   
    Set oEdges01 = oSurfaceBody01.Edges
    Set oEdges02 = oSurfaceBody02.Edges
   
    Dim MinPointX As Double, MinPointY As Double, MinPointZ As Double
    Dim MaxPointX As Double, MaxPointY As Double, MaxPointZ As Double
   
    Dim dx As Double, dy As Double, dz As Double
   
    MinPointX = oSurfaceBody02.RangeBox.MinPoint.x: MinPointY = oSurfaceBody02.RangeBox.MinPoint.y: MinPointZ = oSurfaceBody02.RangeBox.MinPoint.Z
    MaxPointX = oSurfaceBody02.RangeBox.MaxPoint.x: MaxPointY = oSurfaceBody02.RangeBox.MaxPoint.y: MaxPointZ = oSurfaceBody02.RangeBox.MaxPoint.Z
   
    dx = MaxPointX - MinPointX: dy = MaxPointY - MinPointY: dz = MaxPointZ - MinPointZ
    dx = Round(dx, 3): dy = Round(dy, 3): dz = Round(dz, 3):
   
    Dim thickness As Double
    thickness = Round(cd.thickness.value, 3)
   
    Dim baseFace As Inventor.face
   
    Set baseFace = cd.FlatPattern.baseFace
      
   
    If oFaces01.Count = oFaces02.Count Then
        If oEdges01.Count = oEdges02.Count Then
            equalBody = True
        End If
    End If
   
   
    TestFlatPattern = True
   
     If equalBody Then
        If Not isFlatSheet(oSurfaceBody01, baseFace) Then
            TestFlatPattern = False
        Else
            If Not dx = thickness Or Not dy = thickness Or Not dz = thickness Then TestFlatPattern = False
        End If
    End If
   
'    MsgBox TestFlatPattern
   
End Function

Um Abfrage ergänz, dass die Ausdehnung des Abgewickelten Bauteils in mindestens einer Koordinatenrichtung der zugewiesenen Blechdicke entsprechen muss. Liefert zwar auch noch in ungünstigen Fällen falsch positiv zurück, aber immerhin besser wie vorher.

Edit1: Fehler beseitigt

[Diese Nachricht wurde von EIBe 3D am 18. Jun. 2021 editiert.]

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

gunni0815
Mitglied
Maschinenbau Techniker


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

Beiträge: 42
Registriert: 23.04.2014

erstellt am: 06. Jul. 2021 07:42    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 minimal 10 Unities + Antwort hilfreich

Hi Leutz,
sorry für die verspätete Antwort. Ihr habt mir echt sehr weitergeholfen und ich habe mein Makro endlich fertig. Zu erwähnen sei noch, dass ich absolut neu im Umgang mit VBA bzw. im Allgemeinen mit der Makroprogrammierung bin. Ich gelobe Besserung und versuche "Am Ball" zu bleiben... Ohne die Hilfe unseres IT Spezialisten wäre ich niemals zu diesem Ergebnis gekommen.. Aus diesem Grund nochmal ein Special THX an unseren T.M. - du bist einfach der Beste.. <3

So, nun genug beweihräuchert und ab zum Wesentlichen..
Da die Preiskalkulation der Laserteile in einer separaten Excel Tabelle durchführt wird, reicht mit eine Textdatei, in der die gewünschten Teileinformationen stehen, die ich zur Preiskalkulation benötige.

Hier mein Code:
----------------------------------------------------------------
Dim arrSL As Variant
Dim oBom As BOM

Function GetThickness(sb As SurfaceBody) As Double
  ' Find biggest face
  Dim f As Face
  Dim bf As Face
  Dim area As Double
  For Each f In sb.Faces
    ' Only care about planar faces
    If TypeOf f.Geometry Is Plane And f.Evaluator.area > area Then
      Set bf = f
      area = f.Evaluator.area
    End If
  Next
 
  ' Find the opposite face
  Dim p As Plane
  Set p = bf.Geometry
 
  Dim pt1 As Point
  Set pt1 = bf.PointOnFace
 
  Dim tr As TransientGeometry
  Set tr = ThisApplication.TransientGeometry
 
  Dim objs As ObjectsEnumerator
  Dim pts As ObjectsEnumerator
  Dim n As UnitVector
  ' We have to search in the opposite direction
  ' of the face's normal vector
  If bf.IsParamReversed Then
    Set n = p.Normal
  Else
    Set n = tr.CreateUnitVector( _
      -p.Normal.X, -p.Normal.Y, -p.Normal.Z)
  End If
  ' objs(2) should be the opposite face
  ' but we do not need it, the intersection point
  ' is enough, i.e. pts(2)
  Call sb.FindUsingRay(pt1, n, 0, objs, pts)
 
  ' The first point found will be on the same face
  ' The second one will be on the face opposite
  Dim pt2 As Point
  Set pt2 = pts(2)
 
  GetThickness = pt1.DistanceTo(pt2)
End Function

Function PDFExport()
'Set a reference to the active document (the document to be published).
    Dim oDocument As Document
    ThisApplication.ActiveDocument.Update
    Set oDocument = ThisApplication.ActiveDocument
   
    Dim fso As Object
    Set fso = CreateObject("Scripting.FilesystemObject")
    Dim ret As Variant
    Dim dDoc As Document
    Set dDoc = ThisApplication.ActiveDocument
     
      If dDoc.FullFileName = "" Then
        MsgBox "Bitte zuerst die Datei speichern...  "
        Exit Function
    End If
   
  ' Get the PDF translator Add-In.
    Dim PDFAddIn As TranslatorAddIn
    Set PDFAddIn = ThisApplication.ApplicationAddIns.ItemById("{0AC6FD96-2F4D-42CE-8BE0-8AEA580399E4}")
   
    Dim oContext As TranslationContext
    Set oContext = ThisApplication.TransientObjects.CreateTranslationContext
    oContext.Type = kFileBrowseIOMechanism

' Create a NameValueMap object
    Dim oOptions As NameValueMap
    Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap

' Create a DataMedium object
    Dim oDataMedium As DataMedium
    Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
   
' Check whether the translator has 'SaveCopyAs' options
    If PDFAddIn.HasSaveCopyAsOptions(oDocument, oContext, oOptions) Then

        'oOptions.Value("All_Color_AS_Black") = 0
        'oOptions.Value("Remove_Line_Weights") = 0
        'oOptions.Value("Vector_Resolution") = 400
        oOptions.Value("Sheet_Range") = kPrintAllSheets
        'oOptions.Value("Custom_Begin_Sheet") = 2
        'oOptions.Value("Custom_End_Sheet") = 4
 
   
    'Set the destination file name
    Dim pfad As String
    pfad = fso.GetParentFoldername(dDoc.FullFileName) + "\pdf\"
    If Not fso.FolderExists(pfad) Then fso.CreateFolder pfad
   
    oDataMedium.FileName = Replace(pfad + dDoc.DisplayName, ".ipt", ".pdf")
   
  End If    'Publish document.
  Call PDFAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium)

    'MsgBox "PDF wurde unter  -- C:\GAIN\Exchange -- gespeichert!!"
 
End Function


Private Function dxferzeugen(doc As PartDocument)

    Dim DocFlatPattern As FlatPattern
    Dim tmpstr As String
    Dim pfad As String
    Dim dxfFileName As String
    Dim filesystem As Object
    Set filesystem = CreateObject("Scripting.FilesystemObject")
   
    pfad = filesystem.GetParentFoldername(doc.FullFileName) + "\dxf\"
    If Not filesystem.FolderExists(pfad) Then filesystem.CreateFolder pfad
    'Debug.Print "start 1"

   
        Debug.Print doc.FullDocumentName
       
           
                Debug.Print "start"

                dxfFileName = Replace(pfad + doc.DisplayName, ".ipt", ".dxf")
               
                Dim oDataIO As DataIO
                Set oDataIO = doc.ComponentDefinition.DataIO
                Dim sOut As String
                sOut = "FLAT PATTERN DXF?"
                sOut = sOut & "AcadVersion=2004"    '2010, 2007, 2004, 2000, or R12
                sOut = sOut & "&OuterProfileLayer=IV_Outer_Profile"
                sOut = sOut & "&InteriorProfilesLayer=IV_INTERIOR_PROFILES"
                'sOut = sOut & "&FeatureProfilesLayer=IV_Profiles"
                sOut = sOut & "&TangentLayer=IV_Tangent"
                'sOut = sOut & "&BendLayer=IV_BEND"    'Alternativ zu BendUp/-Down
                sOut = sOut & "&BendUpLayer=IV_Bend"
                sOut = sOut & "&BendDownLayer=IV_BendDown"
                'sOut = sOut & "&ToolCenterLayer=IV_ToolCenter"
                sOut = sOut & "&ArcCentersLayer=IV_ArcCenter"
                'sOut = sOut & "&SimplifySplines=True"
                'sOut = sOut & "&SplineTolerance=0.01"
                'sOut = sOut & "&TangentLayerColor=255;0;0" 'Beispiel Farbeinstellung (RGB)
                sOut = sOut & "&InvisibleLayers=IV_ArcCenter;IV_TANGENT;IV_BEND;IV_BendDown;IV_ArcCenter;IV_Featrue_Profiles;IV_Feature_Profiles_Down" 'hier aufgelistete Layer (getrennt durch ";"), werden
                oDataIO.WriteDataToFile sOut, dxfFileName
              'doc.Close (True)
                Debug.Print sOut
           
       
End Function


Function BlechteilParameter()
    Dim oPart As PartDocument
    Dim oFace As Face
    Dim oThicknessParam As Parameter
    Dim oSheetMetalCompDef As SheetMetalComponentDefinition
    Dim Stueckzahl As Integer
    Dim Kantungen As String
    Dim tKantungen As Bend
   
   
    Dim dArea As Double
    Dim dVolume As Double
    Dim dThickness As Double
    Dim dContour As Double
   
    Stueckzahl = 0
    ' Aktives Dokument holen
    Set oPart = ThisApplication.ActiveDocument
 
    dArea = 0
 
    For Each oFace In oPart.ComponentDefinition.SurfaceBodies(1).Faces
        ' Gesamtfläche berechnen
        dArea = dArea + oFace.Evaluator.area
    Next
 
    'Volumen berechnen
    dVolume = Round(oPart.ComponentDefinition.SurfaceBodies(1).Volume(0.01) * 10, 2)

    Set oSheetMetalCompDef = oPart.ComponentDefinition
    Set oThicknessParam = oSheetMetalCompDef.Thickness
 
    ' Blechstärke berechnen
    dThickness = Round(oThicknessParam.ModelValue * 10, 2)
 
    ' Kontur berechnen
    dContour = Round(((dArea - (2 * (dVolume / dThickness))) / dThickness) * 10, 2)
 
  Dim oFP As FlatPattern
    Set oFP = oSheetMetalCompDef.FlatPattern
    Dim dLaenge, dBreite, dimZ As Double
    Dim sdimXYZ As String

    On Error Resume Next
    dLaenge = Round((oFP.Body.RangeBox.MaxPoint.X - oFP.Body.RangeBox.MinPoint.X) * 10, 2)
    dBreite = Round((oFP.Body.RangeBox.MaxPoint.Y - oFP.Body.RangeBox.MinPoint.Y) * 10, 2)
    'MsgBox ("Fläche:" & vbTab & vbTab & Round(dArea, 2) & " cm^2" & vbCrLf & _
            "Volumen:" & vbTab & vbTab & Round(dVolume, 2) & " cm^3" & vbCrLf & _
            "Blechstärke:" & vbTab & Round(dThickness, 2) & " cm" & vbCrLf & vbCrLf & _
            "Konturlänge:" & vbTab & Round(dContour, 2) & " cm")
           
           
    Dim oBOMRow As BOMRow
   
    Dim tmp As Object
    For Each tmp In oBom.BOMViews
   

      If tmp.ViewType = kPartsOnlyBOMViewType Then
            For Each oBOMRow In tmp.BOMRows
                Dim a As Document
                Set a = oBOMRow.ComponentDefinitions.Item(1).Document
                If a.DisplayName = oPart.DisplayName Then
                    Stueckzahl = oBOMRow.ItemQuantity
                    'MsgBox a.DisplayName & " : " & oBOMRow.ItemQuantity
                End If
               
            Next

            'MsgBox "Ich habe " & tmp.BOMRows.Count & " Bauteile gezählt"
        End If

    Next
    Kantungen = " "
   
    For Each tKantungen In oSheetMetalCompDef.Bends
        If Not tKantungen.IsFlat Then
            Kantungen = "Kantung prüfen"
            Exit For
        End If
    Next
           
           
           
           
           
    Call WriteFile(oPart, oPart.DisplayName & ";" & dContour & ";" & dThickness & ";" & Round(dVolume, 2) & ";" & dLaenge & ";" & dBreite & ";" & Kantungen & ";" & Stueckzahl)
End Function


Function ConvertToSheetMetal(doc As PartDocument)
  'MsgBox (doc.SubType)
 
  ' Turn it into a sheet metal part
  doc.SubType = "{9C464203-9BAE-11D3-8BAD-0060B0CE6BB4}"
 
  Dim cd As SheetMetalComponentDefinition
  Set cd = doc.ComponentDefinition

  cd.UseSheetMetalStyleThickness = False
  cd.Thickness.Value = GetThickness(cd.SurfaceBodies(1))
 
  On Error GoTo weiter
    Call cd.Unfold
 
  Call BlechteilParameter
 
  Call dxferzeugen(doc)
 
  Dim oFP As FlatPattern
  Set oFP = doc.ActivatedObject

    oFP.ExitEdit
   
    doc.Save
    doc.Close
   
    Exit Function
weiter:
  doc.SubType = "{4D29B490-49B2-11D0-93C3-7E0706000000}"
  MsgBox (doc.DisplayName + " kann nicht abgewickelt werden")
  doc.Save
    doc.Close
 
 
End Function

Function WriteFile(doc As PartDocument, aStr As String)
    Dim filesystem As Object
    Dim pfad As String
   
    Set filesystem = CreateObject("Scripting.FilesystemObject")
    pfad = filesystem.GetParentFoldername(doc.FullFileName) + "\info\"
   
    If Not filesystem.FolderExists(pfad) Then filesystem.CreateFolder pfad
   
    Open pfad + "\Teileinfo.txt" For Append As #1 'Open file for output
   
    Print #1, aStr 'Write comma-delimited data
   
    Close #1 'Close file
End Function


Function WriteFileHead(doc As Document, aStr As String)
    Dim filesystem As Object
    Dim pfad As String
   
    Set filesystem = CreateObject("Scripting.FilesystemObject")
    pfad = filesystem.GetParentFoldername(doc.FullFileName) + "\info\"
   
    If Not filesystem.FolderExists(pfad) Then filesystem.CreateFolder pfad
   
    Open pfad + "\Teileinfo.txt" For Output As #1 'Open file for output
   
    Print #1, aStr 'Write comma-delimited data
   
    Close #1 'Close file
End Function


Function Stueckliste_erstellen()
    'oBom global zum durchsuchen in anderen Funktionen
   
    Dim oDoc As AssemblyDocument
    Set oDoc = ThisApplication.ActiveDocument
   
    Set oBom = oDoc.ComponentDefinition.BOM
 
    oBom.StructuredViewFirstLevelOnly = False
    oBom.StructuredViewEnabled = False
    oBom.PartsOnlyViewEnabled = True

End Function

Sub Laserteilkalkulation()
    Dim doc As Document
   
    'Call OpenDoc2
    'Call Dateiliste
   

   
    Set doc = ThisApplication.ActiveDocument
    Dim allDocs As Documents
    Set allDocs = ThisApplication.Documents
    ' Iterate through the contents of the Documents collection.
    Dim singleDoc As Document
    Dim Anzahl As Integer
   
    Anzahl = 0
   
    Call Stueckliste_erstellen
    Call WriteFileHead(doc, "Name;Konturlänge;Blechstärke;Volumen;Länge(X)mm;Breite(Y)mm;Kantungen;Stückzahl")
   
    For Each singleDoc In allDocs
        If (singleDoc.DocumentType = kPartDocumentObject) Then
            Call ConvertToSheetMetal(singleDoc)
            Anzahl = Anzahl + 1
           
        End If
    Next

    MsgBox ("Fertig! " & Anzahl & " Teile wurden bearbeitet.")
End Sub

Sub OpenDoc(datei As String)

Dim oDoc As Document

Set oDoc = ThisApplication.Documents.Open(datei)
oDoc.Activate


End Sub

Sub OpenDoc2()
Dim oDoc As Document

        Dim oFileDlg As Inventor.FileDialog
        Call ThisApplication.CreateFileDialog(oFileDlg)

        oFileDlg.InitialDirectory = "c:\"
        oFileDlg.FileName = "*"
Call oFileDlg.ShowOpen
Call OpenDoc(oFileDlg.FileName)

End Sub

Sub Dateiliste()

    LKForm1.Show
If LKForm1.CBabbruch.Value Then
this.Exit
End If

Dim i As Integer
For i = 0 To LKForm1.ListBox1.ListCount - 1
    Call OpenDoc(LKForm1.ListBox1.List(i, 0))
    Call Laserteilkalkulation
Next

End Sub

Vielen Vielen Dank nochmals für eure Hilfe... <3

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

EIBe 3D
Mitglied
Dipl. - Ing. (FH)


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

Beiträge: 267
Registriert: 24.01.2020

HP Z4 G4 Workstation
Xeon 3,6 32GB
Nvidia P2000
WIN10
SW2015 SP5.0
SW2017
*************
Inv2018 akt.SP

erstellt am: 06. Jul. 2021 07:53    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 minimal 10 Unities + Antwort hilfreich

Moin gunni0815,

wenn du nun noch schreiben würdest wobei du exakt welche Hilfe benötigst, schätze ich die Wahrscheinlichkeit dass dir jemand helfen kann wesentlich höher ein. 

Grüße

EIBe 3D

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

gunni0815
Mitglied
Maschinenbau Techniker


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

Beiträge: 42
Registriert: 23.04.2014

erstellt am: 06. Jul. 2021 08:28    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 minimal 10 Unities + Antwort hilfreich

Hi,
hatte ich doch oben schon geschrieben..

Aus einer Stepbaugruppe alle Teile zum Blech.ipt konvertieren, abwickeln und als .dxf speichern. Dazugekommen ist jetzt noch das Erstellen einer Textdatei mit allen Blechinformationen (Stärke, länge, breite, Volumen, Anzahl in BG, etc. ..) um eine Preiskalkulation via Excel auszuführen..

Gruß

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

EIBe 3D
Mitglied
Dipl. - Ing. (FH)


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

Beiträge: 267
Registriert: 24.01.2020

HP Z4 G4 Workstation
Xeon 3,6 32GB
Nvidia P2000
WIN10
SW2015 SP5.0
SW2017
*************
Inv2018 akt.SP

erstellt am: 06. Jul. 2021 09:38    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 minimal 10 Unities + Antwort hilfreich

Immer noch ins Blaue geraten mutmaße ich nun dass du nicht weißt wie die txtDatei zu erstellen ist.


Code:

Private Sub SchreibeTxtDatei()

    Dim fs As Object, txtFile As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    Dim Path As String, txtFileName As String, txtFileFullName As String
   
    Path = "C:\Temp\" 'Anpassen Ordner muss vorhanden sein
    txtFileName = "MeineTextDatei.txt" 'Name und ggf. Endung anpassen
    txtFileFullName = Path & txtFileName
   
    If fs.FileExists(txtFileFullName) Then fs.Delete
   
    Set txtFile = fs.CreateTextFile(txtFileFullName, True)
    txtFile.WriteLine ("ErsteEigenschaft")
    txtFile.WriteLine ("ZweiteEigenschaft")
    txtFile.WriteLine ("usw.")
    txtFile.Close

End Sub


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

Frank_Schalla
Ehrenmitglied
CAD_SYSTEMBETREUER


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

Beiträge: 1731
Registriert: 06.04.2002

DELL M6800
Cad Admin
Methodikentwickler 3D

erstellt am: 09. Jul. 2021 09:15    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 minimal 10 Unities + Antwort hilfreich

Hi Krabby
An den Splines habe ich mir auch die Zähne ausgebissen.

So gehts
Alt
'sOut = sOut & "&SimplifySplines=True"    'auskom.; ansonsten Fehler beim Export !?! 25.06.2018
'sOut = sOut & "&SplineTolerance=0.01"    'auskom.; -"-

Neu
sOut = sOut & "&SimplifySplines=True"
'SplineTolerance Double 0.01
sOut = sOut & "&SplineTolerance=0,1"

------------------
************************************
 

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: 10. Jul. 2021 13:36    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 minimal 10 Unities + Antwort hilfreich

Hi Frank,

herzlichen Dank fürs genaue lesen und den Tipp! Werde ich ausprobieren und wohl auch verwenden.
(verstehen muss man das nicht, oder? Vmtl von der Windows Einstellung zum Trennzeichen abhängig...?)

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

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