Rubrik: COM/OLE/Registry/DLL · Automation | VB-Versionen: VB6 | 07.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 Grimm | Bewertung: | Views: 19.162 |
ohne Homepage | System: 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