Code:
'Diese Funktion erstellt von allen Bauteilzeichnungen mit Blatt2 eine DWG oder DXF Datei.
'Gleichzeitig wird eine Stückliste mit den Brennschnittteilen ersellt
'- Das Modell muss im gleichen Verzeichniss wie die Zeichnung (idw) sein!
'- Das Modell und die Zeichnung müssen dem gleichen Dateinamen haben!
'- Im Modell muss es eine iProperty Artikelstatus geben (7 für Brennschnitt, 8 für Laserschnitt)
'- Im Modell muss es noch weitere iPropertys geben (Produktmarke,Produktgruppe, Material/Norm)
Sub DXFoutAll()
Dim oRefDocs As DocumentsEnumerator
Dim oRefDoc As Document
Dim oAsmDoc As AssemblyDocument
Set oAsmDoc = ThisApplication.ActiveDocument
Set oRefDocs = oAsmDoc.AllReferencedDocuments
Dim oAsmName As String
oAsmName = Left(oAsmDoc.DisplayName, Len(oAsmDoc.DisplayName) - 4)
Dim oFileName As String
oFileName = Left(oAsmDoc.DisplayName, Len(oAsmDoc.DisplayName) - 4)
Dim oDXFAddIn As TranslatorAddIn
Set oDXFAddIn = ThisApplication.ApplicationAddIns.ItemById("{C24E3AC4-122E-11D5-8E91-0010B541CD80}")
Dim oContext As TranslationContext
Set oContext = ThisApplication.TransientObjects.CreateTranslationContext
oContext.Type = kFileBrowseIOMechanism
Dim oOptions As NameValueMap
Set oOptions = ThisApplication.TransientObjects.CreateNameValueMap
Dim oDataMedium As DataMedium
Set oDataMedium = ThisApplication.TransientObjects.CreateDataMedium
Dim oDocument As Document
Dim PrüfenPG, SPExport As Boolean
Dim TeileNummer, TeileNr2, MatNorm, iptMatStärke As String
Dim idwPathName, oModellTyp, oRevNum, ArtStatus, Produktgruppe, ExcelBlatt, DateiEndung As String
Dim oFolderEXP, oFolderSTL, oFolderSTLu, oFolderBSZ, oFolderLSZ, strIniFile, BSSVorlage As String
oFolderEXP = "N:\Department\Technik\Datenexport\" '< Hauptordner für den Export
oFolderSTL = oFolderEXP & "1 - Stücklisten\" '< Speicherort der BSStücklisten
oFolderBSZ = oFolderEXP & "3 - Brennschnitte\" '< Speicherort der BSZeichnungen
oFolderLSZ = oFolderEXP & "4 - Laserschnitte\" '< Speicherort der LSZeichnungen
BSSVorlage = oFolderEXP & "0 - Vorlagen\BSSVorlage.xls" '< Vorlagedatei für die Excel-Stückliste
'Konfiguration der Excel-Tabelle
Dim BSZExcelZeile, LSZExcelZeile, ExcelZeile As Byte
BSZExcelZeile = 10 '< Startzeile in der BSZ-Excel Stückliste
LSZExcelZeile = 10 '< Startzeile in der LSZ-Excel Stückliste
'Einstellung ob beim Dateinamen die RevNr angegeben werden soll
Dim RevNr_by_Dateiname As Boolean
RevNr_by_Dateiname = False '< True = mit Rev, False = ohne Rev
'Einstellung ob eine .dwg oder .dxf Datei exportiert werden soll
Dim Export_as_DXF As Boolean
Export_as_DXF = True '< True = .dxf, False = .dwg
'ini-Datei dem gewählten Exportfile zuweisen
If Export_as_DXF = True Then
strIniFile = "0 - Vorlagen\DXFexport.ini" '< Konfigurationsdatei für den DWG-Export
Else
strIniFile = "0 - Vorlagen\DWGexport.ini" '< Konfigurationsdatei für den DXF-Export
End If
'Prüfen ob eine Baugruppe (.iam) das aktive Dokument ist
If ThisApplication.ActiveDocument.DocumentType <> kAssemblyDocumentObject Then
MsgBox "Diese Funktion kann nur in einer Baugruppe ausgeführt werden!"
Exit Sub
End If
'Benutzerinformation vor dem Start
Dim oYesNo As String
oYesNo = MsgBox("Diese Funktion erstellt von allen Blechbauteilen in dieser Baugruppe eine Schnittzeichnung." _
& " Gleichzeitig wird auch die BS-Stückliste erstellt." _
& vbLf & "" _
& vbLf & "Der Ordner für die Stückliste ist:" _
& vbLf & oFolderSTL & Left(oAsmName, 3) _
& vbLf & "" _
& vbLf & "Der Ordner für die BRENNschnittzeichnungen ist :" _
& vbLf & oFolderBSZ & Left(oAsmName, 3) _
& vbLf & "" _
& vbLf & "Der Ordner für die LASERschnittzeichnungen ist :" _
& vbLf & oFolderLSZ & Left(oAsmName, 3) _
& vbLf & "" _
& vbLf & "Dieser Vorgang kann ein paar Minuten dauern." _
& vbLf & "Wollen sie diese Funktion starten?", vbYesNo)
If oYesNo = vbNo Then End
'Unterordner im Stücklistenverzeichniss
oFolderSTLu = oFolderSTL & Left(oAsmName, 3)
'Prüfen ob es das Stücklistenverzeichniss gibt, wenn nicht wird er erstellt
MakeNewFolder (oFolderSTLu)
'Kopiert die Vorlage .xls in den Unterordner und benennt die Vorlage nach der Hauptbaugruppe
Dim ExcelFileName As String
ExcelFileName = oFolderSTLu & "\" & oAsmName & " - " & oAsmDoc.PropertySets(1).Item("Title").Value & ".xls"
FileCopy BSSVorlage, ExcelFileName
'Excel wird vorbereitet
Dim oExl As New Excel.Application
oExl.Workbooks.Open (ExcelFileName)
'Excel Tabellenkopf wird geschreiben
oExl.ActiveWorkbook.Sheets("Baugruppe").Cells(2, 2) = oAsmDoc.PropertySets(4).Item("Produktmarke").Value & oAsmName
oExl.ActiveWorkbook.Sheets("Baugruppe").Cells(3, 2) = oAsmDoc.PropertySets(1).Item("Title").Value
oExl.ActiveWorkbook.Sheets("Baugruppe").Cells(4, 2) = oAsmDoc.PropertySets(2).Item("Category").Value
'Alle Zeichnungen der enthaltenen Bauteile/Baugruppen werden geöffnet
For Each oRefDoc In oRefDocs
idwPathName = Left(oRefDoc.FullDocumentName, Len(oRefDoc.FullDocumentName) - 4) & ".idw"
'Dateityp des Modells wird erkannt (.iam oder .ipt)
oModellTyp = Right(oRefDoc.DisplayName, 4)
'Prüfen ob das Modell ein .ipt ist und ob es eine Zeichnung hat (Normteile haben keine Zeichnung)
Dim fso As New FileSystemObject
If fso.FileExists(idwPathName) And oModellTyp = ".ipt" Then
Dim oDrawDoc As DrawingDocument
Set oDrawDoc = ThisApplication.Documents.Open(idwPathName, True)
Set oDocument = ThisApplication.ActiveDocument
oFileName = Left(oRefDoc.DisplayName, Len(oRefDoc.DisplayName) - 4)
'ohne gehts nicht!
On Error Resume Next
'RevNr. des Modells auslesen
oRevNum = oRefDoc.PropertySets(1).Item("Revision Number").Value
'oRevNum soll immer 2-stellig sein (mit einer 0 am Anfang)
If Len(oRevNum) = 1 Then oRevNum = 0 & oRevNum
If Len(oRevNum) = 0 Then oRevNum = 0 & 0
'Anzahl der Blätter In einer Zeichnung wird ermittelt
Dim oSheets As Sheets
Set oSheets = oDrawDoc.Sheets
'Der Artikelstatus wird aus der geöffneten Zeichnung ausgelesen
ArtStatus = oRefDoc.PropertySets(4).Item("Artikelstatus").Value
'Die Produktgruppe wird aus der geöffneten Zeichnung ausgelesen
Produktgruppe = oRefDoc.PropertySets(4).Item("Produktgruppe").Value
'Prüfen ob die Teile einer ZUKAUFBAUGRUPPE exportiert werden sollen (Produktgruppe = SP)
'Diese Abfrage soll aber nur 1x erfolgen
If Produktgruppe = "SP" Then
If PrüfenPG = False Then
oYesNo = MsgBox("In dieser Baugruppe befinden sich Teile einer Zukaufbaugruppe!" _
& vbLf & "Sollen diese BSZ/LSZ exportiert werden?", vbYesNo)
If oYesNo = vbNo Then
PrüfenPG = True
SPExport = False
Else
PrüfenPG = True
SPExport = True
End If
End If
If SPExport = False Then GoTo NoExport
End If
'Prüfen ob die Zeichnung mehr als ein Blatt hat und ob der Artikelstatur 7 oder 8 ist
If oSheets.Count > 1 And ArtStatus = 7 Or ArtStatus = 8 Then
'Blatt 2 wird als aktiv gesetzt (Blatt 2 ist immer die Brennschnittkontur)
oDrawDoc.Sheets.Item(2).Activate
'DXF/DWG-Export wird vorbereitet
If oDXFAddIn.HasSaveCopyAsOptions(oDocument, oContext, oOptions) Then
oOptions.Value("Export_Acad_IniFile") = oFolderEXP & strIniFile
End If
'Exportverzeichnis und Excel-Export wird vorbereitet
If oRefDoc.PropertySets(4).Item("Artikelstatus").Value = "7" Then 'Artikelstatus 7 = Brennschnitt
oFolder = oFolderBSZ & Left(oRefDoc.DisplayName, 3)
ExcelBlatt = "Baugruppe"
BSZExcelZeile = BSZExcelZeile + 1
ExcelZeile = BSZExcelZeile
ElseIf oRefDoc.PropertySets(4).Item("Artikelstatus").Value = "8" Then 'Artikelstatus 8 = Laserschnitt
oFolder = oFolderLSZ & Left(oRefDoc.DisplayName, 3)
ExcelBlatt = "Laserschnitt"
LSZExcelZeile = LSZExcelZeile + 1
ExcelZeile = LSZExcelZeile
End If
'Prüfen ob es den Zielordner gibt, wenn nicht wird er erstellt
MakeNewFolder (oFolder)
'Auswertung der Einstellung .dxf/.dwg
If Export_as_DXF = True Then
DateiEndung = ".dxf"
Else
DateiEndung = ".dwg"
End If
'Exportpfad mit Auswertung von RevNr. ja/nein
If RevNr_by_Dateiname = True Then
'Pfad mit Dateinamen erstellen (mit Rev)
oDataMedium.FileName = oFolder & "\" & oFileName & " Rev" & oRevNum & DateiEndung
Else
'Pfad mit Dateinamen erstellen (ohne Rev)
oDataMedium.FileName = oFolder & "\" & oFileName & DateiEndung
End If
'Datei speichern
Call oDXFAddIn.SaveCopyAs(oDocument, oContext, oOptions, oDataMedium)
'Blatt 1 wird wieder aktiv gesetzt
oDrawDoc.Sheets.Item(1).Activate
'Abschnitt Excel Export beginnt hier
'Die Produktmarke wird der Teilenummer vorangestellt
TeileNummer = oRefDoc.PropertySets(4).Item("Produktmarke").Value _
& oRefDoc.PropertySets(3).Item("Part Number").Value
'Übergabevariable für die Funktion "TeileAnz"
TeileNr2 = oRefDoc.PropertySets(3).Item("Part Number").Value
'Die Blechstärke wird aus der "Material/Norm" gefiltert (Blech 30 > 30)
MatNorm = oRefDoc.PropertySets(4).Item("Material/Norm").Value
If Left(MatNorm, 5) = "Blech" Then
iptMatStärke = Right(MatNorm, Len(MatNorm) - 6)
ElseIf Left(MatNorm, 11) = "Tränenblech" Then
iptMatStärke = "TrB " & Right(MatNorm, Len(MatNorm) - 12)
ElseIf Left(MatNorm, 11) = "Riffelblech" Then
iptMatStärke = "RiB " & Right(MatNorm, Len(MatNorm) - 12)
ElseIf Left(MatNorm, 9) = "Lochblech" Then
iptMatStärke = "LoB " & Right(MatNorm, Len(MatNorm) - 10)
End If
'Excelzeile wird mit Daten befüllt
oExl.ActiveWorkbook.Sheets(ExcelBlatt).Cells(ExcelZeile, "A") = TeileNummer
oExl.ActiveWorkbook.Sheets(ExcelBlatt).Cells(ExcelZeile, "B").Value = TeileAnz(TeileNr2, oAsmDoc)
oExl.ActiveWorkbook.Sheets(ExcelBlatt).Cells(ExcelZeile, "C").Value = oRefDoc.PropertySets(1).Item("Title").Value
oExl.ActiveWorkbook.Sheets(ExcelBlatt).Cells(ExcelZeile, "D").Value = oRefDoc.PropertySets(4).Item("Länge").Value
oExl.ActiveWorkbook.Sheets(ExcelBlatt).Cells(ExcelZeile, "E").Value = oRefDoc.PropertySets(4).Item("Breite").Value
oExl.ActiveWorkbook.Sheets(ExcelBlatt).Cells(ExcelZeile, "F").Value = iptMatStärke
oExl.ActiveWorkbook.Sheets(ExcelBlatt).Cells(ExcelZeile, "G").Value = oRefDoc.PropertySets(3).Item("Material").Value
End If
NoExport: 'Sprungziel wenn die Teile einer ZUKAUFBAUGRUPPE nicht exportiert werden sollen
oDrawDoc.Close
End If
Next
'Die Excel-Stückliste speichern und schließen
oExl.ActiveWorkbook.Save
oExl.ActiveWorkbook.Close
'ERP-Stückliste exoprtieren
Call BomExport.BomExport(False)
'Informationsfenster anzeigen
oYesNo = MsgBox("Die Stückliste wurden erstellt in: " _
& vbLf & oFolderSTLu _
& vbLf & " " _
& vbLf & " Soll dieser Ordner geöffnet werden?", vbYesNo)
If oYesNo = vbYes Then
oExl.Workbooks.Open (ExcelFileName)
oExl.Visible = True
End If
End Sub
Sub MakeNewFolder(oName As String)
'Prüfen ob es den Ordner gibt, wenn nicht wird er erstellt
Dim fso As New FileSystemObject
If Not fso.FolderExists(oName) Then MkDir (oName)
End Sub
Function TeileAnz(TeileNr2, oAsmDoc) As Integer
'Gesamtanzahl der Einzelteile wird aus der Stückliste (in der .iam) ausgelesen
Dim oBOM As BOM
Dim oBOMRow As BOMRow
Dim oCompDef As ComponentDefinition
Dim oPropSet As PropertySet
Dim oBOMView As BOMView
Set oBOM = oAsmDoc.ComponentDefinition.BOM
If oBOM.PartsOnlyViewEnabled = False Then oBOM.PartsOnlyViewEnabled = True
For Each oBOMView In oBOM.BOMViews
If oBOMView.ViewType = kPartsOnlyBOMViewType Then
Exit For
End If
Next
For Each oBOMRow In oBOMView.BOMRows
Set oCompDef = oBOMRow.ComponentDefinitions.Item(1)
Set oPropSet = oCompDef.Document.PropertySets.Item("Design Tracking Properties")
If oPropSet.Item("Part Number").Value = TeileNr2 Then
TeileAnz = oBOMRow.ItemQuantity
Exit For
End If
Next
End Function
Foren auf CAD.de (alle Foren)
| 
Ich vermute du hast irgendwo vorher ein OnErrorResumeNext im Code? Das sollte man immer erstmal auskommentieren. Dann hagelt's auch Fehlermeldungen und man sieht wo's klemmt.
