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 19.138 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
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. |
Neu! sevDTA 3.0 Pro SEPA mit Kontonummernprüfung Erstellen von SEPA-Dateien mit integriertem BIC-Verzeichnis und Konto- nummern-Prüfverfahren, so dass ungültige Bankdaten bereits im Vorfeld ermittelt werden können. Tipp des Monats März 2024 Dieter Otter UTF-8 Konvertierung von Dateien und Strings VB6 selbst verfügt über keine Funktionen zur UTF-8 Konvertierung von Daten. Mit Hilfe des ADODB.Stream-Objekts lassen sich diese fehlenden Funktionen aber schnell nachrüsten. TOP Entwickler-Paket TOP-Preis!! Mit der Developer CD erhalten Sie insgesamt 24 Entwickler- komponenten und Windows-DLLs. Die Einzelkomponenten haben einen Gesamtwert von 1605.50 EUR... |
||||||||||||||||
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. |