vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#

https://www.vbarchiv.net
Rubrik: COM/OLE/Registry/DLL · Automation   |   VB-Versionen: VB607.07.08
Wordtabelle aus VB6 heraus erstellen und füllen

Die Daten eines ADODB-Recordset (aus Access-, Excel-Tabelle usw.) werden in eine Wordtabelle übertragen.

Autor:   Norbert GrimmBewertung:  Views:  19.138 
ohne HomepageSystem:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 Beispielprojekt auf CD 

Dieser Code zeigt, wie man aus einer VB-Anwendung heraus, ein neues Word-Dokument erstellt, eine Tabelle einfügt und diese mit Daten aus einem ADO-Recordset füllt.

Um das Beispiel testen zu können, muss Microsoft Word auf dem Rechner installiert sein.

Erstellen Sie ein neues Projekt und platzieren auf die Form einen CommandButton (Command1). Fügen Sie nachfolgenden Code in den Codeteil der Form ein:

Option Explicit
 
' Benötigter Verweis:
' Microsoft AxtiveX Data Objects 2.8 Library
' [MSADO15.DLL]
Private adoRS As ADODB.Recordset
Private Sub Form_Load()
  ' temporäres ungebundenes Recordset für Testzwecke erstellen
  Dim i As Long
 
  Set adoRS = New ADODB.Recordset
  With adoRS
    .Fields.Append "id", adInteger
    .Fields.Append "bez", adVarChar, 30
    .Open
    For i = 1 To 10
      .AddNew
      .Fields(0) = i
      .Fields(1) = "Bez " & CStr(i)
      .Update
    Next i
  End With
End Sub
Private Sub Command1_Click()
  ' Word-Dokument mit Tabelle und Daten erstellen
  Word_Tabelle_1
End Sub
' AutomatisierungsCode für Word_Dateien
'
' Die Function "Word_Tab_1" erstellt ein Word_Dokument mit Tabelle.
' Die Daten eines ADODB.Recordsets (Quelle: Access-, Excel-Tabelle usw.)
' werden in die Wordtabelle übertragen.
' Das Word_Application_Object wird über "späte Binding" (last binding)
' erstellt.
'
' Parameter :
' WD        : 0 = sichtbar
'           : 1 = nur drucken
' oRS       : ADODB.Recordset
'
' Rückgabe  :
' Ret       : <> 0, wenn Fehler
Function Word_Tab_1(ByVal WD As Long, ByRef oRS As Object) As Long
  Dim A       As Long
  Dim B       As Long
  Dim C       As Long
  Dim D       As Long
  Dim i       As Long
  Dim J       As Long
  Dim P       As Long
  Dim R       As Long
  Dim W       As Long
  Dim nRow    As Long
  Dim nCol    As Long
  Dim Ret     As Long
  Dim V       As Variant
  Dim vTxt    As Variant
  Dim vdte    As Variant
  Dim sText   As String
  Dim errMsg  As String
  Dim sWord   As String
 
  sWord = "Word.Application"
 
  Const FZ_0 = "Dieses EDV-Dokument ist Eigentum der " & _
    "Fa.xxx GmbH, Stadt,"
  Const FZ_1 = "und darf -auch auszugsweise- nur mit " & _
    "ausdrücklicher Genehmigung"
  Const FZ_2 = "kopiert, veröffentlicht, oder an andere " & _
    "-auch Behörden- weitergegeben werden."
 
  ' Word_Object(ohne Verweis)
  ' mit Verweis: Microsoft Word 11.0 Object Library : MSWORD.OLB
  ' allg.Object               ' spez.Word_Object
  Dim wdApp       As Object   ' Word.Application
  Dim wdDoc       As Object   ' Word.Document
  Dim tblHead     As Object   ' Word.Table
  Dim tblFoot     As Object   ' Word.Table
  Dim tblMain     As Object   ' Word.Table
 
  Dim rngHead     As Object   ' Word.Range
  Dim rngFoot     As Object   ' Word.Range
  Dim txtFoot     As Object   ' Word.Range
  Dim rngMain     As Object   ' Word.Range
  Dim wdRange     As Object   ' Word.Range
  Dim rngTbl      As Object   ' Word.Range
  Dim rngText     As Object   ' Word.Range
  Dim txtMain     As Object
 
  ' Fehlerbehandlung aktivieren
  On Error GoTo Err_Word_Tab_1
 
  ' nCol, nRow bestimmen
  With oRS
    nCol = .Fields.Count       ' - 1
    .MoveFirst
    .MoveLast
    nRow = .RecordCount        ' - 1
  End With
  ' add +1, wegen Caption
  nRow = nRow + 1
 
  ' Fehlerroutine
  ' nächste Anweisung nach Fehler ausführen
  On Error Resume Next
 
  ' Word-Object vorhanden?...Schon mit CreateObject erzeugt...?
  Set wdApp = GetObject(sWord)
  If wdApp Is Nothing Then
    ' nein, neues Object
    Set wdApp = CreateObject(sWord)
  End If
 
  ' Fehleroutine
  ' Sprungziel festlegen
  On Error GoTo Err_Word_Tab_1
  With wdApp
    Set wdDoc = .Documents.Add
    With wdDoc
      If nCol >= 8 Then
        .PageSetup.Orientation = 1 ' wdOrientLandscape = quer
      End If
 
      ' KopfZeile
      sText = "Demo" & vbCrLf & vbCrLf & " " & vbCrLf & " "
 
      ' Set rngHead = .Sections(1).Headers(wdHeaderFooterPrimary).Range
      Set rngHead = .Sections(1).Headers(1).Range
 
      Set tblHead = .Tables.Add(rngHead, 1, 4)
      With tblHead
        W = .Cell(1, 1).Width
        W = W * 4
        .Cell(1, 1).Width = W * 0.5
        .Cell(1, 2).Width = W * 0.2
        .Cell(1, 3).Width = W * 0.2
        .Cell(1, 4).Width = W * 0.1
        .Cell(1, 1).Range.Font.Bold = True
        .Cell(1, 1).Range.Text = sText
        ' wdAlignParagraphCenter
        .Cell(1, 4).Range.ParagraphFormat.Alignment = 1
        .Cell(1, 4).Range.Font.Name = "WingDings"
        .Cell(1, 4).Range.Font.Size = 36
        .Cell(1, 4).Range.Text = "4"
 
        ' ->Rahmen->einfach
        .Cell(1, 1).Borders.OutsideLineStyle = 1
        .Cell(1, 2).Borders.OutsideLineStyle = 1
        .Cell(1, 3).Borders.OutsideLineStyle = 1
        .Cell(1, 4).Borders.OutsideLineStyle = 1
      End With
 
      ' FussZeile
      Set rngFoot = .Sections(1).Footers(1).Range
      Set tblFoot = .Tables.Add(rngFoot, 1, 2)
      With tblFoot
        W = .Cell(1, 1).Width
        W = W * 2
        .Cell(1, 1).Width = W * 0.9
        .Cell(1, 2).Width = W * 0.1
 
        .Cell(1, 1).Range.Font.Size = 8
        .Cell(1, 1).Range.Font.Italic = True
        .Cell(1, 1).Range.Text = vbCrLf _
          & FZ_0 & vbCrLf _
          & FZ_1 & vbCrLf _
          & FZ_2 & vbCrLf
 
        ' Grafiksymbol
        .Cell(1, 2).Range.ParagraphFormat.Alignment = 1
        .Cell(1, 2).Range.Font.Name = "WingDings"
        .Cell(1, 2).Range.Font.Size = 36
        .Cell(1, 2).Range.Text = ":"
 
        ' ->Rahmen->einfach
        .Cell(1, 1).Borders.OutsideLineStyle = 1
        .Cell(1, 2).Borders.OutsideLineStyle = 1
      End With
 
      ' Text für Fusszeile
      vdte = Format(Date, "dddd, dd.mm.yyyy")
      sText = vdte & vbTab & "Sachbearb. " & "Name" & _
        vbTab & "Quelle: Datenbank_VB"
 
      C = rngFoot.Paragraphs.Count
      Set txtFoot = rngFoot.Paragraphs(C).Range
      With txtFoot
        .Font.Size = 8
        .Text = sText
      End With
 
      ' HauptTeil
      P = .Paragraphs.Count
      Set txtMain = .Paragraphs(P).Range
      If WD Then
        vTxt = " "
      Else
        ' Fehlerroutine
        ' nächste Anweisung nach Fehler ausführen
        On Error Resume Next
        vTxt = GetSetting(App.EXEName, "Word_Tab_1", "Titel")
        If vTxt = "" Then vTxt = "Tabellen_Titel......."
        ' Fehleroutine
        ' Sprungziel festlegen
        On Error GoTo Err_Word_Tab_1
      End If
      txtMain.Text = vTxt & vbCrLf & vbCrLf
 
      P = .Paragraphs.Count
      Set rngMain = .Paragraphs(P).Range
      Set tblMain = .Tables.Add(rngMain, nRow, nCol)
 
      oRS.MoveFirst
      With tblMain
        B = .Cell(1, 1).Width
        .Range.Font.Size = 8
        R = 1
        For J = 0 To nCol - 1
          C = J + 1
          V = oRS.Fields(J).Name
          .Cell(R, C).Range.Text = V
          ' ->Rahmen->einfach
          .Cell(R, C).Borders.OutsideLineStyle = 1 ' ->wdLineStyleSingle
        Next J
 
        For i = 2 To nRow
          R = i
          For J = 0 To nCol - 1
            C = J + 1
            V = oRS.Fields(J).Value
            If Len(V) = 0 Then V = Space(32)
            .Cell(R, C).Range.Text = V
            ' ->nRahmen->einfach
            .Cell(R, C).Borders.OutsideLineStyle = 1 '->wdLineStyleSingle
          Next J
 
          oRS.MoveNext
        Next i
 
        ' auto.Anpassen Cell
        .Range.Cells.AutoFit
      End With
 
    End With  ' wdDoc
 
    Select Case Abs(WD)
      Case 0 ' false
        .Visible = True ' Word_Applikation(Dokument) sichtbar
      Case 1 ' true
        wdDoc.PrintOut ' Word_Dokument nur drucken
        wdDoc.Close (0)
        ' wdApp
        ' .ActivePrinter = MyDCK
        .Quit
    End Select
 
  End With  ' wdApp
 
Exit_Word_Tab_1:
  Word_Tab_1 = Ret
  Exit Function
 
Err_Word_Tab_1:
  With Err
    Ret = .Number
    errMsg = .Description
    .Clear
   End With
   MsgBox Ret & vbCr & errMsg, vbCritical, "Word_Tab_1"
   Resume Exit_Word_Tab_1
End Function
' Aufruf_Funktion
Private Function Word_Tabelle_1() As Long
  Dim OP      As Long
  Dim UB      As Long
  Dim Ret     As Long
  Dim JN      As Variant
  Dim vMsg    As Variant
  Dim vTitel  As Variant
  Dim errMsg  As String
 
  ' Fehlerbehandlung aktivieren
  On Error GoTo Err_WT
 
  ' Word_App
  vMsg = "Ja   =Ansicht" & vbCrLf & "Nein=Drucken"
  JN = MsgBox(vMsg, vbInformation + vbYesNoCancel, "Word_Dokument")
 
  If JN = vbNo Then
    OP = 1
  ElseIf JN = vbCancel Then
    Exit Function
  End If
 
  vTitel = "Word_Tabelle_Demo"
  SaveSetting App.EXEName, "Word_Tab_1", "Titel", vTitel
 
  ' adoRS
  ' aktives ADODB.Recordset-Object innerhalb Ihrer Anwendung...
  Screen.MousePointer = 11
  Word_Tab_1 OP, adoRS
 
Exit_WT:
  Screen.MousePointer = 0
  Word_Tabelle_1 = Ret
  Exit Function
 
Err_WT:
  With Err
    Ret = .Number
    errMsg = .Description
    .Clear
  End With
  MsgBox Ret & vbCr & errMsg, vbCritical, "Word_Tabelle_1"
  Resume Exit_WT
End Function



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.
 
 
Copyright ©2000-2024 vb@rchiv Dieter OtterAlle 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.