vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
DTA-Dateien erstellen inkl. BLZ-/Kontonummernpr?fung  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Newsletter  | Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2015
 
zurück
Rubrik: COM/OLE/Registry/DLL · Automation   |   VB-Versionen: VB5, VB622.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 GrimmBewertung:     [ Jetzt bewerten ]Views:  7.363 
ohne HomepageSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8, Win10 Beispielprojekt auf CD 

Summer-Special bei Tools & Components!
Gute Laune Sommer bei Tools & Components
Top Summer-Special - Sparen Sie teilweise über 100,- EUR
Alle sev-Entwicklerkomponenten und Komplettpakete jetzt bis zu 25% reduziert!
zum Beispiel:
  • Developer CD nur 455,- EUR statt 569,- EUR
  • sevDTA 2.0 nur 224,30 EUR statt 299,- EUR
  •  
  • vb@rchiv   Vol.6 nur 18,70 EUR statt 24,95 EUR
  • sevCoolbar 3.0 nur 58,70 EUR statt 69,- EUR
  • - Werbung -Und viele weitere Angebote           Aktionspreise nur für kurze Zeit gültig

    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

    Dieser Tipp wurde bereits 7.363 mal aufgerufen.

    Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

    Über diesen Tipp im Forum diskutieren
    Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

    Aktuelle Diskussion anzeigen (1 Beitrag)

    nach obenzurück


    Anzeige

    Kauftipp Unser Dauerbrenner!Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv  Vol.6
    (einschl. Beispielprojekt!)

    Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
    - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten
    - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look
    Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m.
     
       

    Druckansicht Druckansicht Copyright ©2000-2015 vb@rchiv Dieter Otter
    Alle Rechte vorbehalten.
    Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.

    Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel