Public Sub main() Stückliste_frm.Show 1 End Sub Public Function SWXTypeOfFile(filename As String) As Long ' function will determine the filetype used by OpenDoc ' by analysing the filename extension; the SolidWorks ' constants have to be imported with swconst.bas or declared Select Case UCase(Right(filename, 6)) Case "SLDPRT" SWXTypeOfFile = swDocPART Case "SLDASM" SWXTypeOfFile = swDocASSEMBLY Case "SLDDRW" SWXTypeOfFile = swDocDRAWING Case Else SWXTypeOfFile = swDocNONE End Select End Function Public Function Rahmen(objXls As Object, AnzZeilen As Long) Dim strRange As String strRange = "A9:M" & CStr(AnzZeilen) objXls.worksheets(1).Range(strRange).Select With objXls.selection.borders(12) 'xlInsideHorizontal .LineStyle = 1 'xlcontinous .Weight = 2 'xlthin .colorindex = 0 'black bzw. xlautomatic End With With objXls.selection.borders(11) 'xlInsideVertical .LineStyle = 1 .Weight = 2 .colorindex = 0 End With With objXls.selection.borders(9) 'xlEdgeBottom .LineStyle = 1 .Weight = 2 .colorindex = 0 End With With objXls.selection.borders(8) 'xlEdgeTop .LineStyle = 1 .Weight = 2 .colorindex = 0 End With With objXls.selection.borders(7) 'xlEdgeLeft .LineStyle = 1 .Weight = 2 .colorindex = 0 End With With objXls.selection.borders(10) 'xlEdgeRight .LineStyle = 1 .Weight = 2 .colorindex = 0 End With End Function Public Function splitten(Wert As String, Trennzeichen As String, Rueck_de As String, Rueck_en As String) Dim a As Long Rueck_de = Wert Rueck_en = Wert a = InStr(Wert, Trennzeichen) If a <> 0 Then Rueck_de = Left(Wert, a - 1) Rueck_en = LTrim(Right(Wert, Len(Wert) - a - 1)) End If End Function Public Function ReadPartProperties(swApp As SldWorks.SldWorks, swModel As SldWorks.ModelDoc2, PfadPart As String, _ Benennung As String, _ Description As String, _ Zeichnungsnummer_extern As String, _ Revision As String, _ Artikelnummer As String, _ Abmessungen As String, _ Material As String, _ DIN As String, _ Gewicht As String, _ Ersatzteil As String, _ Bemerkung As String) Dim Benennung_de_en As String 'Modell öffnen Set swModel = swApp.OpenDoc(PfadPart, SWXTypeOfFile(PfadPart)) 'Daten auslesen Benennung_de_en = swModel.GetCustomInfoValue("", "Benennung") Call splitten(Benennung_de_en, " ", Benennung, Description) 'damit splitten richtig funktioniert, müssen min. 5 Leerzeichen dazwischen sein Zeichnungsnummer_extern = swModel.GetCustomInfoValue("", "Zeichnungsnummer_extern") Revision = swModel.GetCustomInfoValue("", "Revision") Artikelnummer = swModel.GetCustomInfoValue("", "Artikelnummer") Abmessungen = swModel.GetCustomInfoValue("", "Abmessungen") Material = swModel.GetCustomInfoValue("", "Material") DIN = swModel.GetCustomInfoValue("", "DIN") Gewicht = swModel.GetCustomInfoValue("", "Gewicht") Ersatzteil = swModel.GetCustomInfoValue("", "Ersatzteil") Bemerkung = swModel.GetCustomInfoValue("", "Bemerkung") 'Modell schließen swApp.CloseDoc (PfadPart) End Function Public Function ProcessTableAnn(swApp As SldWorks.SldWorks, swModel As SldWorks.ModelDoc2, swTableAnn As SldWorks.TableAnnotation, ConfigName As String, objXls As Object, AnzZeilen As Long) Dim nNumRow As Long Dim J As Long Dim I As Long Dim Zeile As Long Dim ItemNumber As String Dim PartNumber As String Dim swBOMTableAnn As BomTableAnnotation Dim vPtArr As Variant Dim swComp As Object Dim pt As Object Dim compPath As String Dim Benennung As String Dim Description As String Dim Benennung_de_en As String Dim Zeichnungsnummer_extern As String Dim Revision As String Dim Artikelnummer As String Dim Abmessungen As String Dim Material As String Dim DIN As String Dim Gewicht As String Dim Ersatzteil As String Dim Bemerkung As String Dim Stck As Long nNumRow = swTableAnn.RowCount Set swBOMTableAnn = swTableAnn Zeile = 9 For J = nNumRow To 0 Step -1 Stck = swBOMTableAnn.GetComponentsCount2(J, ConfigName, ItemNumber, PartNumber) vPtArr = swBOMTableAnn.GetComponents2(J, ConfigName) If (Not IsEmpty(vPtArr)) Then For I = 0 To UBound(vPtArr) Set pt = vPtArr(I) Set swComp = pt If Not swComp Is Nothing Then compPath = swComp.GetPathName 'Jetzt dieses Teil öffnen und Daten auslesen ReadPartProperties swApp, swModel, compPath, Benennung, Description, Zeichnungsnummer_extern, Revision, Artikelnummer, Abmessungen, Material, DIN, Gewicht, Ersatzteil, Bemerkung 'Daten in die Excelliste schreiben objXls.worksheets(1).Activate objXls.worksheets(1).cells(Zeile, 1).Value = nNumRow - (J + 1) 'Wieder 90Leerzeichen einfügen!!! Benennung_de_en = Benennung & " " & Description objXls.worksheets(1).cells(Zeile, 2).Value = Benennung_de_en objXls.worksheets(1).cells(Zeile, 3).Value = Stck objXls.worksheets(1).cells(Zeile, 4).Value = Zeichnungsnummer_extern objXls.worksheets(1).cells(Zeile, 5).Value = Revision objXls.worksheets(1).cells(Zeile, 6).Value = Artikelnummer objXls.worksheets(1).cells(Zeile, 7).Value = Abmessungen objXls.worksheets(1).cells(Zeile, 8).Value = Material objXls.worksheets(1).cells(Zeile, 9).Value = DIN objXls.worksheets(1).cells(Zeile, 10).Value = Gewicht objXls.worksheets(1).cells(Zeile, 12).Value = Ersatzteil objXls.worksheets(1).cells(Zeile, 14).Value = Bemerkung objXls.worksheets(1).Rows(Zeile).autofit Zeile = Zeile + 1 GoTo weiter 'Einmal auslesen genügt, wenn mehrere gleiche Teile in der Stückliste sind! Else Debug.Print " Could not get component." End If Next End If weiter: Next J AnzZeilen = Zeile - 1 End Function Public Function ProcessBomFeature(swApp As SldWorks.SldWorks, swModel As SldWorks.ModelDoc2, swBomFeat As SldWorks.BomFeature, objXls As Object, AnzZeilen As Long) Dim swFeat As SldWorks.Feature Dim vTableArr As Variant Dim vTable As Variant Dim vConfigArray As Variant Dim vConfig As Variant Dim ConfigName As String Dim swTable As SldWorks.TableAnnotation Set swFeat = swBomFeat.GetFeature vTableArr = swBomFeat.GetTableAnnotations For Each vTable In vTableArr Set swTable = vTable vConfigArray = swBomFeat.GetConfigurations(True, True) For Each vConfig In vConfigArray 'eigentlich braucht man nur eine Konfig, weil normalerweise überall dieselben Teile drin sind ConfigName = vConfig ProcessTableAnn swApp, swModel, swTable, ConfigName, objXls, AnzZeilen Next vConfig Next vTable End Function