vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
sevDataGrid - G?nnen Sie Ihrem SQL-Kommando diesen kr?nenden Abschlu?!  
 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: 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:     [ Jetzt bewerten ]Views:  11.208 
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

    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

    Dieser Tipp wurde bereits 11.208 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.

    Neue Diskussion eröffnen

    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