Private Sub mnuExportExcel1_Click()
 
  Dim strFile As String
    Dim xlsApp As Object
    Dim xlsWorkbook As Object
    Dim xlsSheet As Object
    Dim arrLog() As String
    Dim I As Long
 
    Screen.MousePointer = vbHourglass
 
 
    'Keine Datensätze
    If lvwCounts.ListItems.Count = 0 Then
        Screen.MousePointer = vbDefault
        MsgBox "Kein Einträge zum Exportieren vorhanden.", vbExclamation, _
          "Hinweis"
        Exit Sub
    End If
 
 
 
    'Datei browsen
    With CommonDialog1
        .CancelError = True
        .DialogTitle = "Protokoll als XLS exportieren"
        .Filter = "Microsoft Excel|*.xls"
        .InitDir = "C:\TEMP"
        On Error Resume Next
            .ShowSave
            If Err Then
                Screen.MousePointer = vbDefault
                Exit Sub
            End If
        On Error Goto 0
        strFile = .FileName
    End With
 
 
    'Excel instanzieren
    On Error Resume Next
        Set xlsApp = CreateObject("Excel.Application")
        Set xlsWorkbook = xlsApp.Workbooks.Add
        If xlsWorkbook.Worksheets.Count = 0 Then
            Set xlsSheet = xlsWorkbook.Worksheets.Add
        Else
            Set xlsSheet = xlsWorkbook.Worksheets(1)
        End If
        If Err Then
            Screen.MousePointer = vbDefault
            MsgBox "Das Programm konnte nicht auf Microsoft Excel zugreifen." & _
              "Der Export kann nicht fortgesetzt werden.", vbCritical, "Fehler"
            Exit Sub
        End If
    On Error Goto 0
 
 
    'Exportieren
    For I = 1 To lvwCounts.ListItems.Count
        xlsSheet.Range("A" & I).Value = lvwCounts.ListItems(I).Text
        If lvwCounts.ListItems(I).ForeColor = vbRed Then
            xlsSheet.Range("A" & I).Font.ColorIndex = 3
        End If
    Next
    xlsSheet.Columns("A:A").EntireColumn.AutoFit
 
 
    'Abschluss
    On Error Resume Next
        xlsWorkbook.Close True, strFile
        If Err Then
            MsgBox "Datei konnte nicht gespeichert werden." & vbCrLf & vbCrLf & _
              strFile, vbCritical, "Fehler"
            xlsApp.Visible = True
        Else
            MsgBox "Export abgeschlossen: " & strFile, vbInformation, _
              "Information"
            xlsApp.Quit
        End If
    On Error Goto 0
 
 
    'Objekte resetten
    Set xlsSheet = Nothing
    Set xlsWorkbook = Nothing
    Set xlsApp = Nothing
 
    Screen.MousePointer = vbDefault
End Sub