Rubrik: COM/OLE/Registry/DLL · Automation | VB-Versionen: VB5, VB6 | 22.02.08 |
Werte in ein Excel-Objekt übertragen Mit dieser Funktion wird das Excel_Applikations_Objekt über LateBinding erzeugt und mit Werten gefüllt. | ||
Autor: Norbert Grimm | Bewertung: | Views: 13.210 |
ohne Homepage | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 | Beispielprojekt auf CD |
Mit dieser Funktion wird das Excel_Applikations_Objekt über ein "spätes Binden" (late binding) erzeugt und mit optionalen Parametern gefüllt. Der Parameter vWert ist ein 2-dimensionales Array [vWert(x,y)], wobei y dynamisch sein kann. Die vPSxxxxx-Parameter könnte man auch als ein optionales varArray übergeben.
Die Funktion wird von mir in dieser Form (oder spez.abgewandelt) für das Übertragen von Werten aus verschiedenen Quellen der Datenbank (DatenDateien, FlexGrid, usw.) oft eingesetzt.
' Parameter: XL ' 1 = Direktes Einlesen ohne Wert-Formatierung in Excel ' 10 = Einlesen mit Wert-Formatierung anhand Datentyp ' (Numeric / Date / Text) ' ' vWert: 2-dimensionales Array, wobei die 2. Dimension die ' Anzahl der Spalten bestimmt ' ' vPS...: optionale Parameter für Fußzeile, Kopfzeile und Titel ' ' Rückgabewert: 0 = ok ' <> 0 = Fehler (Err-Eigenschaft) ' ------------------------------------------------------------- Public Function CreateExcel(ByVal XL As Long, vWert As Variant, _ Optional vTitel As Variant, _ Optional vPSLHeader As Variant, _ Optional vPSCHeader As Variant, _ Optional vPSRHeader As Variant, _ Optional vPSLFooter As Variant, _ Optional vPSCFooter As Variant, _ Optional vPSRFooter As Variant) As Long On Error GoTo Err_CreateExcel Dim i As Long Dim j As Long Dim u As Long Dim LB1 As Long Dim UB1 As Long Dim LB2 As Long Dim UB2 As Long Dim s As Long Dim Ret As Long ' Variable : Rückgabe Dim z As Long Dim Zoom As Long Dim N As Double Dim xlApp As Object ' xlApp As Excel.Application Dim xlBook As Object ' xlBook As Excel.Workbook Dim xlSheet As Object ' xlSheet As Excel.Worksheet Dim SheetNr As Integer LB1 = LBound(vWert) ' 2-dimensionales Array : vWert(x,y) UB1 = UBound(vWert) LB2 = LBound(vWert, 2) UB2 = UBound(vWert, 2) ' späte Bindung (Late-Binding) Set xlApp = CreateObject("Excel.Application") With xlApp SheetNr = .SheetsInNewWorkbook ' Anzahl Tabellen merken .SheetsInNewWorkbook = 1 ' 1.Tabelle zuweiesen Set xlBook = .Workbooks.Add Set xlSheet = .Worksheets(1) With xlSheet .Cells.Borders.LineStyle = 1 ' xlContinuous .PageSetup.Orientation = 2 ' ----------------------------- ' optionale Argumente auswerten ' ----------------------------- ' Fußzeile links If Not IsMissing(vPSLFooter) Then .PageSetup.LeftFooter = vPSLFooter Else .PageSetup.LeftFooter = Format(Now, "dddd, dd.mm.yyyy hh:mm") End If ' Fußzeile rechts If Not IsMissing(vPSRFooter) Then .PageSetup.RightFooter = vPSRFooter End If ' Fußzeile mitte If Not IsMissing(vPSCFooter) Then .PageSetup.CenterFooter = vPSCFooter Else .PageSetup.CenterFooter = "Quelle: Datenbank " & _ Chr$(169) & " EXTRAPPS" End If ' Kopfzeile rechts If Not IsMissing(vPSRHeader) Then .PageSetup.RightHeader = vPSRHeader Else .PageSetup.RightHeader = "Schwabe Extracta" End If ' Titelzeile If Not IsMissing(vTitel) Then .PageSetup.LeftHeader = vTitel End If ' je nach Spaltenanzahl, Zoomfaktor einstellen s = UB2 - LB2 + 1 Select Case s Case 11 Zoom = 90 Case Is > 11 Zoom = 80 Case Else Zoom = 100 End Select If Zoom Then ' Breite anpassen .PageSetup.Zoom = Zoom End If End With ' Werte aus dem Variantarray als Text übertragen ' oder ggf. Datentyp abfragen und entsprechend ' formatiert übertragen Select Case XL ' direkt einlesen (als Text übertragen) Case 1 For i = LB1 To UB1 z = z + 1 j = 0 For u = LB2 To UB2 j = j + 1 With xlSheet .Cells(z, j).Font.Size = 9 .Cells(z, j).Value = vWert(i, u) End With Next u Next i ' Datentyp abfragen und Werte formatiert übertragen Case 10 For i = LB1 To UB1 z = z + 1 j = 0 For u = LB2 To UB2 j = j + 1 If IsDate(vWert(i, u)) Then ' Datum With xlSheet .Cells(z, j).Font.Size = 9 .Cells(z, j).Value = Format(vWert(i, u), "dd.mm.yyyy") End With ElseIf IsNumeric(vWert(i, u)) Then ' numerisch N = CDbl(vWert(i, u)) With xlSheet .Cells(z, j).Font.Size = 9 .Cells(z, j).Value = N 'V End With Else ' Text With xlSheet .Cells(z, j).Font.Size = 9 .Cells(z, j).Value = vWert(i, u) End With End If Next u Next i End Select .Visible = True ' Anzahlen Tabellen wiederherstellen .SheetsInNewWorkbook = SheetNr End With Exit_CreateExcel: ' Ret = 0 : okay ' <> 0 : Fehler in Ausführung CreateExcel = Ret Exit Function Err_CreateExcel: Ret = Err MsgBox Err & vbCr & Err.Description, , "CreateExcel" Resume Exit_CreateExcel End Function
Beispiel:
Die Daten, die nach Excel übertragen werden sollen, befinden sich in einem mehrspaltigen ListView-Control.
' Werte vom ListView in ein Variant-Array übertragen Dim nCols As Long Dim nRows As Long Dim vData() As Variant Dim i As Long Dim u As Long Dim nResult As Long With ListView1 ' Anzahl Zeilen und Spalten für die korrekte ' Dimension des Variant-Arrays ermitteln nCols = .ColumnHeaders.Count nRows = .ListItems.Count ' Array dimensionieren ReDim vData(nRows - 1, nCols - 1) ' alle Zeilen durchlaufen For i = 1 To nRows With .ListItems(i) ' Inhalt der 1. Spalte einlesen vData(i - 1, 0) = .Text ' jetzt alle weiteren Spalten einlesen For u = 1 To nCols - 1 vData(i - 1, u) = .SubItems(u) Next u End With Next i End With ' Daten formatiert an Excel übergeben nResult = CreateExcel(10, vData, "vb@rchiv Tipps & Tricks") If nResult <> 0 Then MsgBox "Es trat ein Fehler auf:" & vbCrLf & _ "Fehler " & CStr(nResult), vbExclamation End If