Option Explicit
    Dim fso As Object 'FileSystemObject
   'Verweis auf swDocumentMgr -> Verwendung nur bei vorhandenem LicKey
    Dim cf As SwDocumentMgr.SwDMClassFactory
    Dim cmgr As SwDocumentMgr.SwDMApplication

Sub StartHier()
    'Neues FSO erzeugen Entweder via CreateObject oder einen Verweis auf
    'Windows Script Host Object Model
    Set fso = CreateObject("Scripting.Filesystemobject")
        Dim mFileCol As New Collection
        Dim mConfigCol As New Collection
        Dim oFile As Variant
        Dim sConfig As Variant
        Dim oFileStream As Object 'TextStream
        Dim hlpText As String
            
       'Durchsuchen von einem Verzeichniss  !!
       'ToDo: Überprüfen ob das Verz auch existiert ....
        Call BrowseForFiles("D:\Programme\SolidWorks", mFileCol, True)
       'Auslesen der Configs der gefundenen Dateien
       '& Ausgabe in Excel ---- !! Es geht schneller eine csv Datei zu erzeugen und diese in Excel zu Importieren als in Excel direkt zu Schreiben.
        On Error Resume Next
       'ToDo: aus "C:\ImportInExcel.csv" einen Datei im User-Temp-Folder machen (Berechtigungen auf C:\)
        Set oFileStream = fso.CreateTextFile("C:\ImportInExcel.csv", True, False)
        If Err.Number <> 0 Then
            MsgBox Err.Description, vbOKOnly, "Fehler ... Datei noch geöffnet ?"
            Err.Clear
            Exit Sub
        End If
        
       'Für jede oben gefundene Datei jetzt die Konfigs auslesen und in den oben angelegten TextStream pinnen
        For Each oFile In mFileCol
             Set mConfigCol = ReadConfigZeug(oFile)
             hlpText = oFile & ", " & mConfigCol.Count
             For Each sConfig In mConfigCol
                hlpText = hlpText & "," & sConfig
             Next
             oFileStream.WriteLine hlpText
        Next
       'Stream wieder schließen
        oFileStream.Close
        Set oFileStream = Nothing
       
       'Jetzt in Excel Importieren
        Dim oXLS As Object 'Excel.Application Verweis auf Microsoft Excel
        Set oXLS = CreateObject("Excel.Application")
        Dim owb As Object   'Workbook
            Set owb = oXLS.Workbooks.Open(FileName:="C:\ImportInExcel.csv")
            owb.Columns("A:A").Select
            oXLS.Selection.TextToColumns Destination:=oXLS.Range("A1"), DataType:=1, _
            TextQualifier:=1, ConsecutiveDelimiter:=False, Tab:=False, _
            Semicolon:=False, Comma:=True, Space:=False, Other:=False
        
        oXLS.Visible = True
        
        Set owb = Nothing
        Set oXLS = Nothing
        Set fso = Nothing
    

End Sub
'Für jeder Datei in einem Folder wird ein Eintrag in oCol gemacht !! ByRef !!
Private Function BrowseForFiles(ByVal sInFolder As String, ByRef oCol As Collection, Optional bRecursiv As Boolean = False) As Collection
    
    Dim oFile As Object 'File
    For Each oFile In fso.GetFolder(sInFolder).Files
        Select Case LCase(fso.GetExtensionName(oFile.Name))
            Case Is = "slddrw", "sldprt", "sldasm"
                oCol.Add oFile.Path
        End Select
    Next oFile
    
    If bRecursiv = True Then
        Dim oFolder As Object 'Folder
        For Each oFolder In fso.GetFolder(sInFolder).SubFolders
            Call BrowseForFiles(oFolder.Path, oCol, bRecursiv)
        Next
    End If
    
    Set BrowseForFiles = oCol
End Function
Private Function ReadConfigZeug(ByVal sInFile As String) As Collection
    Const skey As String = "-von swx erhältlich -"
    Dim retCOl As New Collection
    Dim mDoc As SwDMDocument
    Dim ret As SwDmDocumentOpenError
    Dim i As Integer
    Set cf = New SwDMClassFactory
       Dim sRet() As String
        Set cmgr = cf.GetApplication(skey)
            Set mDoc = cmgr.GetDocument(sInFile, GetType(sInFile), True, ret)
            If ret = swDmDocumentOpenErrorNone Then
                If mDoc.ConfigurationManager.GetConfigurationCount > 0 Then
                    sRet() = mDoc.ConfigurationManager.GetConfigurationNames
                    For i = LBound(sRet) To UBound(sRet)
                        retCOl.Add sRet(i)
                    Next
                End If
            Else
                
                Call MsgBox("Fehler beim öffnen der Datei " & vbCrLf & sInFile, vbExclamation + vbOKOnly, "ähm")
            End If
            mDoc.CloseDoc
        Set mDoc = Nothing


Set ReadConfigZeug = retCOl
End Function
Private Sub Command1_Click()
Call StartHier
End Sub

'----------------------------------------------------------------------------------------------------------------
'Hilfsfunktion benötigt einen Verweis auf die SolidWorks CONST Library oder eine Deklaration von swDocumentType_e
Private Function GetType(ByVal sFIle As String) As swDocumentTypes_e
 Dim ret As swDocumentTypes_e
 
 If LCase(Right(sFIle, 6)) = "sldprt" Then
  ret = swDocPART
 ElseIf LCase(Right(sFIle, 6)) = "sldasm" Then
  ret = swDocASSEMBLY
 ElseIf LCase(Right(sFIle, 6)) = "slddrw" Then
  ret = swDocDRAWING
 Else
  ret = swDocNONE
 End If
 GetType = ret
 Exit Function
End Function