vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Blitzschnelles Erstellen von grafischen Diagrammen!  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   RSS-Feeds  | Newsletter  | Impressum  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2014
 
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:  6.840 
ohne HomepageSystem:  Win9x, WinNT, Win2k, WinXP, Vista, Win7, Win8 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

Dieser Tipp wurde bereits 6.840 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-2014 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