' ****************************************************************************** ' Solid-Safe-Excel-2 - Version 1.0.0 - 22.April 2016 ' ****************************************************************************** Option Explicit Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliSeconds As Long) Const swDocPART = 1 Const swDocASSEMBLY = 2 Const swDocDRAWING = 3 'Typ deklarieren, damit alle gewünschten Eigenschaften in einem Feld gespeichert werden können (kann erweitert werden) Public Type TreferencedDoc 'http://www.datadidact.de/pdf/m9878.pdf PathName As String 'kpl. Dateipfad incl. Dateinamen und Extender Name As String 'Dateiname ohne kpl. Dateipfad bzw. Extender plus optionale Konfiguration Komponente As String 'Dateiname ohne kpl. Dateipfad bzw. Extender RefConfig As String 'referenzierte Konfiguration Revision As String 'Revision der Konfiguration Änderungsvermerk As String 'Änderungsvermerk-Konfig Lebenszyklus As String 'Lebenszyklus Typ As String 'Komponenteneigenschaft (Einzelteil, Baugruppe, Normteil) StückzahlBgr As Long 'Stückzahl in der Baugruppe Description As String 'Description Description2 As String 'Description 2 Description3 As String 'Description 3 Lieferant As String 'Lieferant ArtikelNr As String 'ArtikelNr Verw_Bereich As String 'Verwendungsbereich Oberfläche As String 'Oberfläche Zuschnitt As String 'Zuschnitt Zuschnitt2 As String 'Zuschnitt 2 Stück As String 'Stück FertigAnzahl As String 'Fertigungsanzahl CNC As String 'CNC-Programm Material As String 'Material Masse As String 'Gewicht Konstrukteur As String 'Konstrukteur Datum As String 'Datum End Type Public referencedDoc() As TreferencedDoc 'Feld zum speichern von Eigenschaften der referenzierten Dokumente Dim dbs As Variant 'zum Material auslesen Dim sMatDB As String 'zum Material auslesen Dim MassProp As Variant 'zum Gewicht auslesen Dim MaxIdx As Integer 'Größe des Arrays Dim nxNumRow As Integer 'zusätzliche Zeilen in der Tabelle Sub main() Dim swApp As SldWorks.SldWorks Dim swModel As SldWorks.ModelDoc2 Dim Komponente As String 'Dateiname ohne Pfad / Extender Dim Configuration As SldWorks.Configuration 'aktive Konfiguration der Komponente Dim Config As String 'Konfiguration der Komponente Dim Revision As String 'Revision der Konfiguration Dim Datum As String 'aktuelles Datum mit Uhrzeit Dim swmodelDocExt As SldWorks.ModelDocExtension Dim ExportPath As String 'Pfad (Speicherort) der zu speichernden Tabelle Dim ExportName As String 'Dateiname der zu speichernden Tabelle Dim ret As Integer 'für die Erkennung eines ToolboxParts (Normteil) Dim Masse As String 'zum Gewicht auslesen Dim Material As String 'zum Material auslesen Dim Typ As String 'zum ermitteln der Komponenteneigenschaft Dim StückzahlBgr As String 'wie oft verwendet in der Baugruppe Dim RootComponent As SldWorks.Component2 Dim k As Integer 'ein Zähler Dim n As Integer 'ein Zähler Dim xlApp As New Excel.Application Dim xlWb As Excel.Workbook Dim xlWbs As Excel.Workbooks Dim xlWs As Excel.Worksheet Dim ConfigCount As Long 'Anzahl der Konfigurationen Dim ConfigNames As Variant 'Namen der Konfigurationen Dim showconfig As String 'Name der gewählten Konfiguration Dim boolstatus As Boolean Dim l As Long 'ein Zähler ExportPath = "C:\1Arbeitsverzeichnis\Zu-Projekte-kopieren\" ExportName = "ERP-Sammeltabelle" Masse = "" Material = "" Set swApp = Application.SldWorks Set swModel = swApp.ActiveDoc dbs = swApp.GetMaterialDatabases nxNumRow = 0 'dann war gar kein Dokument geöffnet, wie soll da was funktionieren If swModel Is Nothing Then Call MsgBox("Kein Dokument geöffnet!", vbSystemModal, "Information") End End If 'wenn eine Zeichnung aktiv ist wird das Makro wieder beendet If (swModel.GetType = swDocDRAWING) Then Call MsgBox("Nicht für Zeichnungen geeignet!", vbSystemModal, "Information") End End If 'Abfrage, ob Dokument gespeichert wurde und gegebenenfalls zum Speichern auffordern If swModel.GetPathName = "" Then swModel.Save 'aktives Dokument speichern unter End 'Makro beenden End If '--------------------- Dim sPath As String sPath = "C:\1Arbeitsverzeichnis\Zu-Projekte-kopieren\ERP-Sammeltabelle.xlsx" Dim ExcelApp As Excel.Application Dim excelsheet As Excel.Worksheet Dim excelbook As Excel.Workbook Set ExcelApp = CreateObject("Excel.Application") 'Excel öffnen ExcelApp.Visible = True 'False 'True 'Excel ausblenden Set excelbook = ExcelApp.Workbooks.Open(sPath) Set xlWs = excelbook.Worksheets("Tabelle1") Verzögerung 'Wartezeit vor dem Druck, (1 Sekunde) '------------------- Set swmodelDocExt = swModel.Extension ConfigCount = swModel.GetConfigurationCount ConfigNames = swModel.GetConfigurationNames 'dann alle Konfigurationen nacheinander Aufrufen und Daten ermitteln For l = 0 To ConfigCount - 1 showconfig = ConfigNames(l) boolstatus = swModel.ShowConfiguration2(showconfig) 'Dateinamen, Konfiguration und Revision ermitteln Komponente = Mid(swModel.GetPathName, InStrRev(swModel.GetPathName, "\") + 1, Len(swModel.GetPathName)) 'Dateiname ohne Pfad mit Extender Komponente = VBA.Left(Komponente, Len(Komponente) - 7) 'Dateiname ohne Extender Set Configuration = swModel.GetActiveConfiguration() 'aktive Konfiguration der Komponente Config = Configuration.Name 'Konfiguration der Komponente Revision = swModel.CustomInfo2(Config, "Revision") 'Revision der Konfiguration Datum = Format(Now(), "yy.mm.dd hh.mm.ss") 'aktuelles Datum mit Uhrzeit 'ExportName = Komponente & "-" & Config & "-Rev-" & Revision & "-" & Datum 'Dateiname der zu speichernden Tabelle 'ermitteln der Komponenteneigenschaft und bei Baugruppen traversieren If (swModel.GetType = swDocASSEMBLY) Then Typ = "Baugruppe" ' ReDim Preserve referencedDoc(0) 'Array vordimensionieren ' Set RootComponent = Configuration.GetRootComponent() 'Root-Komponente des Assemblies als Ausgangspunkt festmachen ' 'und jetzt rekursiv durch alle Ebenen gehen, um Daten im Array "referencedDoc" zu speichern ' TraverseComponent 1, RootComponent Else ret = swmodelDocExt.ToolboxPartType 'ret = 0 ist ein NotAToolboxPart 'ret = 1 ist ein ToolboxStandardPart 'ret = 2 ist ein ToolboxCopiedPart 'http://help.solidworks.com/2014/English/api/swdocmgrapi/SolidWorks.Interop.swdocumentmgr~SolidWorks.Interop.swdocumentmgr.SwDmToolboxPartType.html If ret = 0 Then 'ist kein ToolboxPart Typ = "Einzelteil" Else Typ = "Normteil" 'ist ein ToolboxPart End If End If 'das Material der Konfig auslesen If (swModel.GetType = swDocPART) Then Material = swModel.GetMaterialPropertyName2(Config, sMatDB) End If 'und die MassProperties auslesen und Gewicht ermitteln MassProp = swModel.GetMassProperties() ' die Reihenfolge der MassProps im Variant ist: ' CenterOfMassX, CenterOfMassY, CenterOfMassZ, Volume, Area, Mass, MomXX, MomYY, MomZZ, MomXY, MomZX, MomYZ ' Masse ist die 6. Eigenschaft, also Index 5 Masse = Round(MassProp(5), 3) ''wenn schon existiert, dann doch lieber vorher löschen ' If Dir(ExportPath & ExportName & ".xlsx") <> "" Then ' Kill ExportPath & ExportName & ".xlsx" ' End If 'öffne Excel und aktiviere ein Blatt 'Set xlApp = Excel.Application 'xlApp.Visible = True 'Set xlWbs = Excel.Workbooks 'Set xlWb = xlWbs.Add() 'Set xlWs = xlWb.Worksheets("Tabelle1") 'Set xlWbs = xlApp.Workbooks.Open(sPath) '------------------ ' Dim ExcelApp As Excel.Application ' Dim excelsheet As Excel.Worksheet ' Dim excelbook As Excel.Workbook ' Set ExcelApp = CreateObject("Excel.Application") 'Excel öffnen ' ExcelApp.Visible = True 'False 'Excel ausblenden ' Set excelbook = ExcelApp.Workbooks.Open(sPath) ' Set xlWs = excelbook.Worksheets("Tabelle1") '------------------ 'Tabelle mit Leben erfüllen ' 'Überschriften ' xlWs.Range("A1:W1").HorizontalAlignment = xlCenter 'mittig formatieren (VerticalAlignment = xlCenter) ' xlWs.Range("A1").value = "Dateiname" ' xlWs.Range("B1").value = "Konfig" ' xlWs.Range("C1").value = "Revision" ' xlWs.Range("D1").value = "Änderungsvermerk-Konfig" ' xlWs.Range("E1").value = "Lebenszyklus" ' xlWs.Range("F1").value = "Typ" ' xlWs.Range("G1").value = "Stück-Bgr." ' xlWs.Range("H1").value = "Description" ' xlWs.Range("I1").value = "Description 2" ' xlWs.Range("J1").value = "Description 3" ' xlWs.Range("K1").value = "Lieferant" ' xlWs.Range("L1").value = "Artikel-Nr." ' xlWs.Range("M1").value = "Verwendungsbereich" ' xlWs.Range("N1").value = "Oberfläche" ' xlWs.Range("O1").value = "Zuschnitt" ' xlWs.Range("P1").value = "Zuschnitt 2" ' xlWs.Range("Q1").value = "Stück" ' xlWs.Range("R1").value = "Fertigungsanzahl" ' xlWs.Range("S1").value = "CNC-Programm" ' xlWs.Range("T1").value = "Material" ' xlWs.Range("U1").value = "Gewicht" ' xlWs.Range("V1").value = "Konstrukteur" ' xlWs.Range("W1").value = "Datum" 'ermitteln der nächsten freien Zeile n = [A65536].End(xlUp).Offset(1, 0).Row 'n = [A1].End(xlDown).Offset(1, 0).Row 'kommt Fehlermeldung ?? 'Debug.Print n 'n = 2 'nächste Zeile = Einzelteil bzw. oberste Baugruppe xlWs.Range("A" & n).value = Komponente '"Dateiname" xlWs.Range("B" & n).NumberFormat = "@" 'als "Text" formatieren xlWs.Range("B" & n).value = Config '"Konfig" xlWs.Range("C" & n).value = swModel.CustomInfo2(Config, "Revision") 'Revision der Konfiguration xlWs.Range("D" & n).value = swModel.CustomInfo2(Config, "Änderungsvermerk-Konfig") '"Änderungsvermerk-Konfig" xlWs.Range("E" & n).value = swModel.CustomInfo2(Config, "Lebenszyklus") '"Lebenszyklus" xlWs.Range("F" & n).value = Typ '"Typ" xlWs.Range("G" & n).value = StückzahlBgr '"Stück Bgr." xlWs.Range("H" & n).value = swModel.CustomInfo2("", "Description") '"Description" xlWs.Range("I" & n).value = swModel.CustomInfo2(Config, "Description2") '"Description 2" xlWs.Range("J" & n).value = swModel.CustomInfo2(Config, "Description3") '"Description 3" xlWs.Range("K" & n).value = swModel.CustomInfo2(Config, "Lieferant") '"Lieferant" xlWs.Range("L" & n).value = swModel.CustomInfo2(Config, "ArtikelNr") '"Artikel-Nr." xlWs.Range("M" & n).value = swModel.CustomInfo2(Config, "Verw_Bereich") '"Verwendungsbereich" xlWs.Range("N" & n).value = swModel.CustomInfo2(Config, "Oberfläche") '"Oberfläche" xlWs.Range("O" & n).value = swModel.CustomInfo2(Config, "Zuschnitt") '"Zuschnitt" xlWs.Range("P" & n).value = swModel.CustomInfo2(Config, "Zuschnitt2") '"Zuschnitt2" xlWs.Range("Q" & n).value = swModel.CustomInfo2(Config, "Stueck") '"Stück" xlWs.Range("R" & n).value = swModel.CustomInfo2(Config, "Fertig_Anzahl") '"Fertigungsanzahl" xlWs.Range("S" & n).value = swModel.CustomInfo2(Config, "CNC") '"CNC-Programm" xlWs.Range("T" & n).NumberFormat = "@" 'als "Text" formatieren xlWs.Range("T" & n).value = Material '"Material" xlWs.Range("U" & n).value = Masse & " kg" '"Gewicht" xlWs.Range("V" & n).value = swModel.CustomInfo2(Config, "Konstrukteur") '"Konstrukteur" xlWs.Range("W" & n).value = swModel.CustomInfo2(Config, "Datum") '"Datum" ' 'folgende Zeilen entsprechen den Komponenten der obersten Ebene in der Baugruppe ' If (swModel.GetType = swDocASSEMBLY) Then ' For k = 0 To MaxIdx ' xlWs.Range("A" & k + 3).value = referencedDoc(k).Komponente 'Dateiname ' xlWs.Range("B" & k + 3).NumberFormat = "@" 'als "Text" formatieren ' xlWs.Range("B" & k + 3).value = referencedDoc(k).RefConfig 'Konfig ' xlWs.Range("C" & k + 3).value = referencedDoc(k).Revision 'Revision der Konfiguration ' xlWs.Range("D" & k + 3).value = referencedDoc(k).Änderungsvermerk 'Änderungsvermerk-Konfig ' xlWs.Range("E" & k + 3).value = referencedDoc(k).Lebenszyklus 'Lebenszyklus ' xlWs.Range("F" & k + 3).value = referencedDoc(k).Typ 'Typ ' xlWs.Range("G" & k + 3).value = referencedDoc(k).StückzahlBgr 'Stück Bgr. ' xlWs.Range("H" & k + 3).value = referencedDoc(k).Description 'Description ' xlWs.Range("I" & k + 3).value = referencedDoc(k).Description2 'Description 2 ' xlWs.Range("J" & k + 3).value = referencedDoc(k).Description3 'Description 3 ' xlWs.Range("K" & k + 3).value = referencedDoc(k).Lieferant 'Lieferant ' xlWs.Range("L" & k + 3).value = referencedDoc(k).ArtikelNr 'Artikel-Nr. ' xlWs.Range("M" & k + 3).value = referencedDoc(k).Verw_Bereich 'Verwendungsbereich ' xlWs.Range("N" & k + 3).value = referencedDoc(k).Oberfläche 'Oberfläche ' xlWs.Range("O" & k + 3).value = referencedDoc(k).Zuschnitt 'Zuschnitt ' xlWs.Range("P" & k + 3).value = referencedDoc(k).Zuschnitt2 'Zuschnitt 2 ' xlWs.Range("Q" & k + 3).value = referencedDoc(k).Stück 'Stück ' xlWs.Range("R" & k + 3).value = referencedDoc(k).FertigAnzahl 'Fertigungsanzahl ' xlWs.Range("S" & k + 3).value = referencedDoc(k).CNC 'CNC-Programm ' xlWs.Range("T" & k + 3).NumberFormat = "@" 'als "Text" formatieren ' xlWs.Range("T" & k + 3).value = referencedDoc(k).Material 'Material ' xlWs.Range("U" & k + 3).value = referencedDoc(k).Masse & " kg" 'Gewicht ' xlWs.Range("V" & k + 3).value = referencedDoc(k).Konstrukteur 'Konstrukteur ' xlWs.Range("W" & k + 3).value = referencedDoc(k).Datum 'Datum ' Next k ' End If 'Array wieder leeren, damit beim nächsten Durchgang nicht aus Versehen schon was drin steht Erase referencedDoc Next l 'Excel speichern xlWs.UsedRange.EntireColumn.AutoFit 'Spaltenbreite automatisch anpassen 'xlWb.SaveAs ExportPath & ExportName & ".xlsx" 'speichern unter 'xlWb.Save 'speichern 'excelbook.Save 'speichern excelbook.SaveAs ExportPath & ExportName & ".xlsx" 'speichern unter 'prüfen, ob das Dokument auch tatsächlich gespeichert wurde If Dir(ExportPath & ExportName & ".xlsx") <> "" Then 'Call MsgBox("Speicherung war erfolgreich!", vbSystemModal, "Information") Else Call MsgBox("Speicherung ist fehlgeschlagen!", vbSystemModal, "Information") End If 'Excel schließen Excel.Application.Quit 'Call MsgBox("Ich geh dann mal!", vbSystemModal, "Information") End Sub Private Function TraverseComponent(Level As Integer, Component As SldWorks.Component2) Dim i As Integer 'Diese Routine ist aus dem Makro 02 Dim Children As Variant ' - Masse aller Baugruppenkomponenten auslesen - Dim Child As SldWorks.Component 'der Makromania von Stefan Berlitz entstanden Dim ChildCount As Integer 'ein Zähler Dim ModelDoc As SldWorks.ModelDoc2 Dim ConfigName As String 'Name der jeweiligen Konfiguration Dim Doublette As Boolean 'Doublette, ja oder nein Dim n As Integer 'ein Zähler Dim actualDoc As TreferencedDoc 'Zwischenspeicher, um sortiert in das Array eingetragen werden zu können Dim modelDocExt As SldWorks.ModelDocExtension 'für die Erkennung eines ToolboxParts Dim ret As Long 'für die Erkennung eines ToolboxParts Dim StListe As Boolean 'Variable für den Status "Aus Stückliste ausschließen" Doublette = False If Not CBool(CInt(Component.IsSuppressed)) Then 'Wenn Komponente nicht unterdrückt ist 'alle gewünschten Eigenschaften auslesen und im Zwischenspeicher "actualDoc" speichern ConfigName = Component.ReferencedConfiguration Set ModelDoc = Component.GetModelDoc() If Not ModelDoc Is Nothing Then 'Dateinamen definieren, um ihn beim Sortieren auswerten zu können actualDoc.Name = Mid(ModelDoc.GetPathName, InStrRev(ModelDoc.GetPathName, "\") + 1, Len(ModelDoc.GetPathName)) 'Dateiname ohne Pfad mit Extender actualDoc.Komponente = VBA.Left(actualDoc.Name, Len(actualDoc.Name) - 7) 'Dateiname ohne Extender actualDoc.Name = actualDoc.Komponente + "-" + Component.ReferencedConfiguration 'Dateiname mit Konfiguration 'die bisherigen Einträge durchsuchen, ob sie schon vorhanden sind und schauen, ob die Komponente aus der Stückliste ausgeschlossen ist StListe = Component.ExcludeFromBOM 'Zustand des Status "Aus Stückliste ausschließen" For n = 0 To UBound(referencedDoc) '- 1 If StListe = 1 Then 'aus Stückliste ausgeschlossen Doublette = True Exit For End If If actualDoc.Name = referencedDoc(n).Name Then Doublette = True referencedDoc(n).StückzahlBgr = referencedDoc(n).StückzahlBgr + 1 'Stückzahl in der Baugruppe um 1 erhöhen Exit For End If Next n If Doublette = False Then 'wenn keine Doublette, dann die Daten auslesen und im Feld speichern actualDoc.PathName = ModelDoc.GetPathName 'kpl. Dateipfad incl. Dateinamen und Extender actualDoc.RefConfig = Component.ReferencedConfiguration 'referenzierte Konfiguration actualDoc.Revision = ModelDoc.CustomInfo2(actualDoc.RefConfig, "Revision") 'Revision der Konfiguration actualDoc.Änderungsvermerk = ModelDoc.CustomInfo2(actualDoc.RefConfig, "Änderungsvermerk-Konfig") 'Änderungsvermerk-Konfig actualDoc.Lebenszyklus = ModelDoc.CustomInfo2(actualDoc.RefConfig, "Lebenszyklus") 'Lebenszyklus actualDoc.StückzahlBgr = 1 'Stückzahl in der Baugruppe actualDoc.Description = ModelDoc.CustomInfo2("", "Description") 'Description actualDoc.Description2 = ModelDoc.CustomInfo2(actualDoc.RefConfig, "Description2") 'Description 2 actualDoc.Description3 = ModelDoc.CustomInfo2(actualDoc.RefConfig, "Description3") 'Description 3 actualDoc.Lieferant = ModelDoc.CustomInfo2(actualDoc.RefConfig, "Lieferant") 'Lieferant actualDoc.ArtikelNr = ModelDoc.CustomInfo2(actualDoc.RefConfig, "ArtikelNr") 'Artikel-Nr. actualDoc.Verw_Bereich = ModelDoc.CustomInfo2(actualDoc.RefConfig, "Verw_Bereich") 'Verwendungsbereich actualDoc.Oberfläche = ModelDoc.CustomInfo2(actualDoc.RefConfig, "Oberfläche") 'Oberfläche actualDoc.Zuschnitt = ModelDoc.CustomInfo2(actualDoc.RefConfig, "Zuschnitt") 'Zuschnitt actualDoc.Zuschnitt2 = ModelDoc.CustomInfo2(actualDoc.RefConfig, "Zuschnitt2") 'Zuschnitt 2 actualDoc.Stück = ModelDoc.CustomInfo2(actualDoc.RefConfig, "Stueck") 'Stück actualDoc.FertigAnzahl = ModelDoc.CustomInfo2(actualDoc.RefConfig, "Fertig_Anzahl") 'Fertigungsanzahl actualDoc.CNC = ModelDoc.CustomInfo2(actualDoc.RefConfig, "CNC") 'CNC-Programm actualDoc.Konstrukteur = ModelDoc.CustomInfo2(actualDoc.RefConfig, "Konstrukteur") 'Konstrukteur actualDoc.Datum = ModelDoc.CustomInfo2(actualDoc.RefConfig, "Datum") 'Datum Set modelDocExt = ModelDoc.Extension ret = modelDocExt.ToolboxPartType 'ret = 0 ist ein NotAToolboxPart 'ret = 1 ist ein ToolboxStandardPart 'ret = 2 ist ein ToolboxCopiedPart 'http://help.solidworks.com/2014/English/api/swdocmgrapi/SolidWorks.Interop.swdocumentmgr~SolidWorks.Interop.swdocumentmgr.SwDmToolboxPartType.html If ret = 0 Then 'ist kein ToolboxPart 'Call MsgBox("Ist kein Toolbox Teil", vbSystemModal, "Information") If (ModelDoc.GetType = swDocASSEMBLY) Then actualDoc.Typ = "Baugruppe" Else actualDoc.Typ = "Einzelteil" End If Else 'Call MsgBox("Ist ein Toolbox Teil", vbSystemModal, "Information") actualDoc.Typ = "Normteil" 'ist ein ToolboxPart End If 'das Material der Konfig auslesen If (ModelDoc.GetType = swDocPART) Then actualDoc.Material = ModelDoc.GetMaterialPropertyName2(actualDoc.RefConfig, sMatDB) End If 'und die MassProperties auslesen und Gewicht ermitteln ModelDoc.ShowConfiguration (ConfigName) MassProp = ModelDoc.GetMassProperties() ' die Reihenfolge der MassProps im Variant ist: ' CenterOfMassX, CenterOfMassY, CenterOfMassZ, Volume, Area, Mass, MomXX, MomYY, MomZZ, MomXY, MomZX, MomYZ ' Masse ist die 6. Eigenschaft, also Index 5 actualDoc.Masse = Round(MassProp(5), 3) End If Else 'oberste Baugruppe End If If Doublette = False Then If Not ModelDoc Is Nothing Then 'nur die referenzierten Komponenten ins Array, oberste Baugruppe ist bereits in der Liste InsertValue actualDoc 'In Array sortiert einfügen nxNumRow = nxNumRow + 1 End If End If End If 'schauen, ob's eine Subkomponente ist und ggf. über die Kinder rüberschauen Dim obersteEbene As Boolean 'nur oberste Ebene, ja oder nein obersteEbene = True If obersteEbene = False Or Level = 1 Then 'bei obersteEbene = True, wird nur bis zur Ebene 1 durchsucht Children = Component.GetChildren 'ansonsten die kpl. Baugruppe mit allen Unterkomponenten ChildCount = UBound(Children) + 1 For i = 0 To (ChildCount - 1) Set Child = Children(i) TraverseComponent Level + 1, Child Next i End If End Function Sub InsertValue(ByRef NewVal As TreferencedDoc) ' 'Fügt die Werte aus "actualDoc" sortiert in das Array "referencedDoc" ein. Dim i As Integer 'Zähler Dim j As Integer 'noch ein Zähler ' MaxIdx = UBound(referencedDoc) ReDim Preserve referencedDoc(MaxIdx + 1) 'Array um einen Speicherplatz erweitern i = 0 While i < MaxIdx 'Schleife über alle Einträge des Arrays If UCase(referencedDoc(i).Name) > UCase(NewVal.Name) Then 'den ersten Eintrag im Array suchen, der größer als der neue Wert ist For j = MaxIdx - 1 To i Step -1 'alle nachfolgenden Einträge des Arrays um einen Platz nach hinten verschieben referencedDoc(j + 1) = referencedDoc(j) Next j referencedDoc(i) = NewVal 'neuen Wert in das Array eintragen Exit Sub End If i = i + 1 Wend referencedDoc(i) = NewVal 'es wurde kein größerer Eintrag im Array gefunden, darum den neuen Wert ans Ende stellen End Sub Private Sub Verzögerung() Sleep (1000) End Sub