| Word.Application, Word.Document |
|
|
| Sub cmdWord_Click() |
| Dim WordObj As New Word.Application |
| Dim WordDoc As New Word.Document |
| Dim dName$ |
| dName = "C:\Windows\Testdokument.doc" |
| On Error GoTo w |
| AppActivate "Microsoft Word" |
| Set WordObj = Word.Application |
| GoTo n |
| w: |
| Set WordObj = CreateObject("Word.Application") |
| n: |
| Set WordDoc = WordObj.Documents.Add(dName) |
| WordObj.Visible = True |
| WordObj.Application.Selection.TypeParagraph |
| WordObj.Application.Selection.TypeText Text:=TextBox1.Text |
| WordObj.Application.Selection.TypeParagraph |
| If TextBox2.Text = "" Then |
| WordObj.Application.Selection.TypeText Text:=TextBox3.Text |
| Else |
| If TextBox1.Text <> "Firma" Then |
| WordObj.Application.Selection.TypeText Text:=TextBox2.Text & " " & TextBox3.Text |
| Else |
| WordObj.Application.Selection.TypeText Text:=TextBox2.Text |
| WordObj.Application.Selection.TypeParagraph |
| WordObj.Application.Selection.TypeText Text:=TextBox3.Text |
| End If |
| End If |
| WordObj.Application.Selection.TypeParagraph |
| WordObj.Application.Selection.TypeText Text:=TextBox4.Text & " " & TextBox5.Text |
| WordObj.Application.Selection.TypeParagraph |
| If Textbox6.Text = "D" Or Textbox6.Text = "DE" Then |
| WordObj.Application.Selection.TypeText Text:=TextBox7.Text & " " & TextBox8.Text |
| Else |
| WordObj.Application.Selection.TypeText Text:=Textbox6.Text & " - " & _ |
| TextBox7.Text & " " & TextBox8.Text |
| End If |
| WordObj.Application.Selection.TypeParagraph |
| WordObj.Application.Selection.TypeParagraph |
| WordObj.Application.Selection.TypeParagraph |
| WordObj.Application.Selection.TypeParagraph |
| If TextBox1.Text = "Herr" Then |
| WordObj.Application.Selection.TypeText Text:="Sehr geehrter Herr " & TextBox3.Text & ", " |
| WordObj.Application.Selection.TypeParagraph |
| WordObj.Application.Selection.TypeParagraph |
| ElseIf TextBox1.Text = "Frau" Then |
| WordObj.Application.Selection.TypeText Text:="Sehr geehrte Frau " & TextBox3.Text & ", " |
| WordObj.Application.Selection.TypeParagraph |
| WordObj.Application.Selection.TypeParagraph |
| Else |
| WordObj.Application.Selection.TypeText Text:="Sehr geehrte " |
| End If |
| End Sub |
|
| |
|
| ... und noch eine Lösung... |
|
| Const DateiInland$ = "C:\Letter_Inland.dot" |
| Const DateiAusland$ = "C:\Letter_Ausland.dot" |
| Const BriefOrt$ = "München, den " |
| Dim W As Worksheet, TBereich$ |
| 'Die Word.Application muss zunächst oben im Menü referenziert werden |
| Dim WordObj As New Word.Application |
| Dim WordDoc As New Word.Document |
| 'Variablen für Spalten |
| Dim Anrede$, Nachna$, Vornam$ |
| Dim Strass$, HausNu$, Landtt$, PeElZe$, Ortttt$ |
| 'Schulungen |
| Dim BEword$, BEexcl$, BEaces$, BEpppt$, BEedit$ |
| Dim i& |
|
| Sub Button1_Click() |
| Start_Serienbrief |
| End Sub |
|
| Function Start_Serienbrief() |
| i = 0 |
| 'Prüft ob die Word-Vorlage vorhanden ist |
| If VBA.Dir(DateiInland) = "" Or VBA.Dir(DateiAusland) = "" Then |
| VBA.MsgBox "Die Briefvorlage ist nicht vorhanden!" & VBA.Chr(10) & _ |
| VBA.Chr(10) & "Bitte eine Vorlage erstellen und ins Verzeichnis WINNT stellen!" _ |
| & VBA.Chr(10), VBA.vbInformation, "Info" |
| Exit Function |
| End If |
| Set W = ThisWorkbook.Worksheets("Schulung") |
| On Error GoTo CreateWordObject |
| VBA.AppActivate "Microsoft Word" |
| Set WordObj = Word.Application |
| GoTo next_step |
| CreateWordObject: |
| Set WordObj = CreateObject("Word.Application") |
| next_step: |
| TBereich = W.Range("A1").CurrentRegion.Rows.Count |
| For i = 2 To TBereich |
| If W.Range("F" & (i)).Text = "D" Then |
| Set WordDoc = WordObj.Documents.Add(DateiInland) |
| Else |
| Set WordDoc = WordObj.Documents.Add(DateiAusland) |
| End If |
| 'Zeile auslesen |
| Anrede = W.Range("A" & (i)).Text |
| Nachna = W.Range("B" & (i)).Text |
| Vornam = W.Range("C" & (i)).Text |
| Strass = W.Range("D" & (i)).Text |
| HausNu = W.Range("E" & (i)).Text |
| Landtt = W.Range("F" & (i)).Text |
| PeElZe = W.Range("G" & (i)).Text |
| Ortttt = W.Range("H" & (i)).Text |
| 'Lehrgänge lesen |
| BEword = W.Range("I" & (i)).Text |
| BEexcl = W.Range("J" & (i)).Text |
| BEaces = W.Range("K" & (i)).Text |
| BEpppt = W.Range("L" & (i)).Text |
| BEedit = W.Range("M" & (i)).Text |
| 'Word Fehlermeldung abschalten |
| WordObj.Application.DisplayAlerts = Word.wdAlertsNone |
| 'Seriendruck für jede Zeile starten |
| Call WordSerie(WordObj, Anrede, Vornam, Nachna, Strass, HausNu, _ |
| Landtt, PeElZe, Ortttt, BEword, BEexcl, BEaces, BEpppt, BEedit) |
| WordDoc.Application.DisplayAlerts = Word.wdAlertsNone |
| 'Speichern des Word-Dokuments unterbinden |
| WordObj.Options.SavePropertiesPrompt = False |
| 'braucht bei mir kleine Pause, sonst Fehler |
| Application.Wait VBA.Now + VBA.TimeSerial(0, 0, 5) |
| 'Speichern wird nur simuliert |
| WordDoc.Saved = True |
| Set WordDoc = Nothing |
| 'Abfrage beim ersten Ausdruck, ob OK |
| If i <= 2 Then |
| If VBA.MsgBox("Es wird ein Testausdruck erzeugt. Ist der Testausdruck OK und " & _ |
| VBA.vbCrLf & "soll das Drucken fortgesetzt werden? ", VBA.vbQuestion + _ |
| VBA.vbOKCancel + VBA.vbDefaultButton2, "Testausdruck läuft...") = VBA.vbOK Then |
| 'mach weiter |
| Else |
| WordObj.Quit |
| Set WordObj = Nothing |
| Exit Function |
| End If |
| End If |
| Next i |
| WordObj.Quit |
| Set WordObj = Nothing |
| End Function |
|
| Function WordSerie(WordObj, Anr, Vorn, Nachn, Stras, HaNr, Lant, _ |
| PLZt, Orrt, Bword, Bexcl, Baces, Bpppt, Bedit) |
| On Error Resume Next |
| With WordObj.Application.Selection |
| .TypeParagraph |
| If Anr <> "" Then |
| .TypeText Text:=Anr |
| .TypeParagraph |
| End If |
| If Vorn = "" Then |
| .TypeText Text:=Nachn |
| Else |
| If Anr <> "Firma" And Anr <> "" Then |
| .TypeText Text:=Vorn & " " & Nachn |
| Else |
| .TypeText Text:=Nachn |
| .TypeParagraph |
| .TypeText Text:=Vorn |
| End If |
| End If |
| .TypeParagraph |
| .TypeText Text:=Stras & " " & HaNr |
| .TypeParagraph |
| If Lant = "D" Or Lant = "DE" Then |
| .TypeText Text:=PLZt & " " & Orrt |
| Else |
| .TypeText Text:=Lant & " - " & PLZt & " " & Orrt |
| End If |
| .TypeParagraph |
| .ParagraphFormat.Alignment = Word.wdAlignParagraphRight |
| .TypeText Text:=BriefOrt & VBA.Day(VBA.Date) & "." & VBA.Month(VBA.Date) & "." & VBA.Year(VBA.Date) |
| .TypeParagraph |
| .ParagraphFormat.Alignment = Word.wdAlignParagraphLeft |
| .TypeParagraph: .TypeParagraph |
| .TypeParagraph: .TypeParagraph |
| |
| 'Bereich "besuchte Kurse" |
| .Font.Underline = wdUnderlineSingle |
| .TypeText Text:="Besuchte Kurse:" |
| .TypeParagraph |
| .Font.Underline = wdUnderlineNone |
| |
| If Bword <> "" And Bword <> "B" Then |
| .TypeText "- " & Bword & ": Microsoft Word" |
| .TypeParagraph |
| Bword = "" |
| End If |
| If Bexcl <> "" And Bexcl <> "B" Then |
| .TypeText "- " & Bexcl & ": Microsoft Excel" |
| .TypeParagraph |
| Bexcl = "" |
| End If |
| If Baces <> "" And Baces <> "B" Then |
| .TypeText "- " & Baces & ": Microsoft Access" |
| .TypeParagraph |
| Baces = "" |
| End If |
| If Bpppt <> "" And Bpppt <> "B" Then |
| .TypeText "- " & Bpppt & ": Microsoft Powerpoint" |
| .TypeParagraph |
| Bpppt = "" |
| End If |
| If Bedit <> "" And Bedit <> "B" Then |
| .TypeText "- " & Bedit & ": Microsoft Multi Editor XP" |
| .TypeParagraph |
| Bedit = "" |
| End If |
| |
| .TypeParagraph: .TypeParagraph |
| |
| 'Bereich "offene Kurse" |
| .Font.Underline = wdUnderlineSingle |
| .TypeText Text:="Möchte noch besuchen:" |
| .TypeParagraph |
| .Font.Underline = wdUnderlineNone |
| |
| If Bword = "B" Then |
| .TypeText "- Microsoft Word" |
| .TypeParagraph |
| Bword = "" |
| End If |
| If Bexcl = "B" Then |
| .TypeText "- Microsoft Excel" |
| .TypeParagraph |
| Bexcl = "" |
| End If |
| If Baces = "B" Then |
| .TypeText "- Microsoft Access" |
| .TypeParagraph |
| Baces = "" |
| End If |
| If Bpppt = "B" Then |
| .TypeText "- Microsoft Powerpoint" |
| .TypeParagraph |
| Bpppt = "" |
| End If |
| If Bedit = "B" Then |
| .TypeText "- Multi Editor XP" |
| .TypeParagraph |
| Bedit = "" |
| End If |
| |
| 'dann drucke mal |
| .Document.PrintOut |
| End With |
| End Function |
|
| |
|
| ... und noch eine Lösung mit Button in der Symbolleiste... |
 |
|
|
|
|
|
|
|
|
|
|
|
|
|
| Beim Öffnen des Workbooks wird Button in Symbolleiste erzeugt |
| Sub Workbook_Open() |
| Dim myControl As CommandBarButton |
| On Error Resume Next |
| Application.WindowState = xlMaximized |
| Application.CommandBars("Standard").Controls("Starte Word Serienbrief").Delete |
| Set myControl = Application.CommandBars("Standard").Controls. _ |
| Add(Type:=msoControlButton, Before:=5) |
| With myControl |
| .Style = msoButtonWrapCaption |
| .Width = 100 |
| .State = msoButtonDown |
| .Caption = "Starte Word Serienbrief" |
| .OnAction = "Brief_Start" |
| .Visible = True |
| End With |
| End Sub |
|
| Formular zum Markieren der Datensätze |
| Sub AlleMarkieren_Click() |
| On Error Resume Next |
| Dim c& |
| 'alle Einträge in der Listbox markieren |
| For c = 0 To frmSuchen.cbAuswahl.ListCount - 1 |
| frmSuchen.cbAuswahl.Selected(c) = True |
| Next |
| End Sub |
|
| Sub cmdExit_Click() |
| On Error Resume Next |
| Application.DisplayAlerts = False |
| Worksheets(TEMP1).Delete |
| Application.DisplayAlerts = True |
| Unload Me |
| End Sub |
|
| Sub cmdStart_Click() |
| Call Start_Serienbrief |
| End Sub |
|
| Sub UserForm_Terminate() |
| On Error Resume Next |
| frmSuchen.cmdExit_Click |
| WordDoc.Application.DisplayAlerts = Word.wdAlertsNone |
| WordObj.Options.SavePropertiesPrompt = False |
| WordObj.Quit |
| Set WordDoc = Nothing |
| Set WordObj = Nothing |
| Set W2 = Nothing |
| End Sub |
|
| Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) |
| If CloseMode <> 1 Then Cancel = 1 |
| End Sub |
|
| Modul |
| 'Wo ist die Winword.exe installiert? Sonst geht nix... |
| Public Const WinwordPfad$ = "C:\Programme\Office\Office10\" |
|
| 'Ort und Name der Word-Dokumentenvorlage |
| Public Const Dateivorlage$ = "U:\daten\Letter.dot" |
|
| 'Hier wird das fertige Word-Dokument abgespeichert |
| Public Const Laufwerk$ = "U:\daten\" |
|
| 'Worksheet Namen nie verändern! |
| Public Const WNAME$ = "Mitarbeiterliste wg durchgeführ" |
| Public Const TEMP1$ = "Temp" |
|
| Die Word.Application muss oben im Menü (Werkzeuge - Verweise) referenziert werden. |
| Beim Wechsel der Office-Release neue "Microsoft Word XXX Object-Library" zuweisen! |
| Public WordObj As New Word.Application |
| Public WordDoc As New Word.Document |
| Public W As Worksheet |
| Public W2 As Worksheet |
|
| 'Schulungen Überschriften |
| Public Const Kurs_I$ = "- Verkaufstraining Basis (Baumaschine & Stapler)" |
| Public Const Kurs_J$ = "- Verkaufstraining Fortgeschrittene" |
| Public Const Kurs_K$ = "- Verkaufstraining Refresher" |
| Public Const Kurs_L$ = "- Verkaufen am Telefon" |
| Public Const Kurs_M$ = "- Inkasso-Management" |
| Public Const Kurs_N$ = "- Mitarbeiterförderungsprogramm" |
| Public Const Kurs_O$ = "- Erfolgreiche Kundenberatung" |
| Public Const Kurs_P$ = "- B & F Seminare" |
| Public Const Kurs_Q$ = "- Kommunikationstraining für Disponenten" |
| Public Const Kurs_R$ = "- Ausbilderworkshop (Gewerbliche Ausbildung)" |
| Public Const Kurs_S$ = "- Workshop für kaufmännische Ausbildungsbeauftragte" |
| Public Const Kurs_T$ = "- 1 x 1 der Führungspraxis" |
| Public Const Kurs_U$ = "- Konflikte lösen bzw. Umgang mit schwierigen Führungssituationen" _ |
| & VBA.vbCrLf & " (Folgeseminar zum '1x1 der Führungspraxis')" |
| Public Const Kurs_V$ = "- Konflikte lösen bzw. Umgang mit schwierigen Führungssituationen" _ |
| & VBA.vbCrLf & " (ohne vorherige Teilnahme am '1x1 der Führungspraxis')" |
| Public Const Kurs_W$ = "- Meister / Disponenten führen Servicetechniker" |
| Public Const Kurs_X$ = "- Projektmanagement" |
| Public Const Kurs_Y$ = "- Rhetorik & Präsentation" |
| Public Const Kurs_Z$ = "- Verhalten und Verhandeln am Telefon" |
| Public Const Kurs_AA$ = "- Zielvereinbarung, Beurteilung, Förderung" |
| Public Const Kurs_AB$ = "- Verhalten und Verkaufen am Telefon" |
| Public Const Kurs_AC$ = "- MZSG" |
| Public Const Kurs_AD$ = "- Betriebsverfassungsrecht für Führungskräfte" |
| Public Const Kurs_AE$ = "- Basisschulung Baumaschinen" |
| Public Const Kurs_AF$ = "- Basisschulung Stapler" |
| Public Const Kurs_AG$ = "- Basisschulung ET/Komponenten" |
| Public Const Kurs_AH$ = "- Basisschulung Windows XP" |
| Public Const Kurs_AI$ = "- Basisschulung Kommunikation am Telefon" |
| Public Const Kurs_AJ$ = "- Basisschulung Telemarketing & Telefonverkauf" |
| Public Const Kurs_AK$ = "- Grundlagen der Erdbewegung I" |
| Public Const Kurs_AL$ = "- Grundlagen der Erdbewegung II" |
| Public Const Kurs_AM$ = "- Nachwuchsförderprogramm - NFP" |
| Public Const Kurs_AN$ = "- Development Center - ZDC" |
|
| 'Schulungen: Variablen für "Datum auslesen" |
| Public Datum_I$, Datum_J$, Datum_K$, Datum_L$, Datum_M$, Datum_N$ |
| Public Datum_O$, Datum_P$, Datum_Q$, Datum_R$, Datum_S$, Datum_T$ |
| Public Datum_U$, Datum_V$, Datum_W$, Datum_X$, Datum_Y$, Datum_Z$ |
| Public Datum_AA$, Datum_AB$, Datum_AC$, Datum_AD$, Datum_AE$, Datum_AF$ |
| Public Datum_AG$, Datum_AH$, Datum_AI$, Datum_AJ$, Datum_AK$, Datum_AL$ |
| Public Datum_AM$, Datum_AN$ |
|
| Public Nachna$, Vornam$ 'Namen Kursteilnehmer |
| Public Pfad$, DatName$ 'Pfad & Dateiname für das Word-Dokument |
| Public TBereich& 'Zeilen im Worksheet |
| Public i&, z& 'Listbox-Zähler |
|
| Sub Brief_Start() |
| Dim c% |
|
| 'Eventuelle "alte Word-Session" schließen |
| On Error Resume Next |
| WordObj.Options.SavePropertiesPrompt = False |
| WordObj.Quit |
| Set WordDoc = Nothing |
| Set WordObj = Nothing |
| Set W2 = Nothing |
| Set W = Nothing |
|
| 'ist der Pfad für Winword.exe korrekt? |
| If VBA.Dir(WinwordPfad) = "" Then |
| VBA.MsgBox "Der Dateipfad für Ausführung von Winword ist nicht korrekt! " & VBA.Chr(10) & _ |
| VBA.Chr(10) & "Bitte wenden Sie sich an Ihren Administrator!" _ |
| & VBA.Chr(10), VBA.vbInformation, "Info" |
| Exit Sub |
| End If |
|
| 'ist die Word-Vorlage vorhanden? |
| If VBA.Dir(Dateivorlage) = "" Then |
| VBA.MsgBox "Die Briefvorlage ist nicht vorhanden!" & VBA.Chr(10) & _ |
| VBA.Chr(10) & "Bitte eine Vorlage erstellen und ins Verzeichnis " & _ |
| Laufwerk & " stellen! " & VBA.Chr(10), VBA.vbInformation, "Info" |
| Exit Sub |
| End If |
|
| 'Worksheet direkt mit Namen ansprechen |
| Set W = ThisWorkbook.Worksheets(WNAME) |
| Application.DisplayAlerts = False |
|
| 'Gibt es das temporäre Worksheet schon? |
| For c = 1 To Worksheets.Count |
| If Worksheets(c).Name <> WNAME Then Worksheets(c).Delete |
| Next c |
|
| 'Temporäres Worksheet anlegen |
| Worksheets.Add.Move After:=Worksheets(Worksheets.Count) |
| ActiveSheet.Name = TEMP1 |
| Set W2 = ThisWorkbook.Worksheets(TEMP1) |
|
| 'Auswahl vom 1. Worksheet ins temp.Worksheet kopieren |
| W2.Cells.ClearContents |
| W.UsedRange.Copy W2.[A1] |
| TBereich = W2.Range("A1").CurrentRegion.Rows.Count |
|
| 'Listbox laden |
| If TBereich > 1 Then |
| frmSuchen.cbAuswahl.ColumnCount = 5 |
| frmSuchen.cbAuswahl.ColumnWidths = 65 & ";" & 55 & ";" & 80 & ";" & 35 & ";" & 55 |
| frmSuchen.cbAuswahl.RowSource = "D2:H" & TBereich |
| frmSuchen.cbAuswahl.MultiSelect = fmMultiSelectExtended |
|
| 'in den Worksheets die Spaltenbreite anpassen - sonst falsche Ausgabe in WORD! |
| W.Columns.AutoFit |
| W2.Columns.AutoFit |
| |
| Set W = Nothing |
| Set W2 = Nothing |
| |
| Application.DisplayAlerts = True |
| |
| frmSuchen.lblHinweis.Caption = "Im linken Fenster die gewünschten Datensätze anwählen" _ |
| & VBA.vbCrLf & VBA.vbCrLf & "(oder alles markieren)" & VBA.vbCrLf & VBA.vbCrLf & "Dann Seriendruck starten..." |
|
| 'in Listbox alle Einträge markieren |
| frmSuchen.AlleMarkieren_Click |
| frmSuchen.Show |
|
| Else |
|
| 'keine Teilnehmer ausgewählt = Abbruch |
| Set W = Nothing |
| Set W2 = Nothing |
| VBA.MsgBox "Keine Teilnehmer ausgewählt! " & VBA.Chr(10) & _ |
| VBA.Chr(10) & "Bitte wiederholen..." & VBA.Chr(10) _ |
| & VBA.Chr(10), VBA.vbInformation, "Info" |
| Application.DisplayAlerts = False |
| Worksheets(TEMP1).Delete |
| Application.DisplayAlerts = True |
| End If |
|
| End Sub |
|
|
| Function Start_Serienbrief() |
| i = 0: z = 0 |
|
| 'sind Einträge in der Listbox markiert? |
| For i = 0 To frmSuchen.cbAuswahl.ListCount - 1 |
| If frmSuchen.cbAuswahl.Selected(i) = True Then |
| z = z + 1 |
| End If |
| Next |
| If z = 0 Then |
| VBA.MsgBox "Keine Teilnehmer ausgewählt! " & VBA.Chr(10) & _ |
| VBA.Chr(10) & "Bitte wiederholen..." & VBA.Chr(10) _ |
| & VBA.Chr(10), VBA.vbInformation, "Info" |
| Exit Function |
| End If |
| |
| i = 0: z = 0 |
| Set W2 = ThisWorkbook.Worksheets(TEMP1) |
|
| 'Word.Application aufrufen |
| On Error GoTo CreateWordObject |
| VBA.AppActivate "Microsoft Word" |
| Set WordObj = Word.Application |
| GoTo next_step |
|
| CreateWordObject: |
| Set WordObj = CreateObject("Word.Application") |
|
| next_step: |
| On Error GoTo abbruch |
| TBereich = W2.Range("A1").CurrentRegion.Rows.Count |
| Set WordDoc = WordObj.Documents.Add(Dateivorlage) |
| For i = 0 To frmSuchen.cbAuswahl.ListCount - 1 |
| If frmSuchen.cbAuswahl.Selected(i) = True Then |
| z = z + 1 |
| If z > 1 Then |
| 'Seitenumbruch |
| WordObj.Application.Selection.InsertBreak Type:=wdPageBreak |
| End If |
| 'Namen in Zeile auslesen |
| Nachna = W2.Range("D" & (i + 2)).Text |
| Vornam = W2.Range("E" & (i + 2)).Text |
| 'Datum der Lehrgänge lesen |
| Datum_I = W2.Range("I" & (i + 2)).Text |
| Datum_J = W2.Range("J" & (i + 2)).Text |
| Datum_K = W2.Range("K" & (i + 2)).Text |
| Datum_L = W2.Range("L" & (i + 2)).Text |
| Datum_M = W2.Range("M" & (i + 2)).Text |
| Datum_N = W2.Range("N" & (i + 2)).Text |
| Datum_O = W2.Range("O" & (i + 2)).Text |
| Datum_P = W2.Range("P" & (i + 2)).Text |
| Datum_Q = W2.Range("Q" & (i + 2)).Text |
| Datum_R = W2.Range("R" & (i + 2)).Text |
| Datum_S = W2.Range("S" & (i + 2)).Text |
| Datum_T = W2.Range("T" & (i + 2)).Text |
| Datum_U = W2.Range("U" & (i + 2)).Text |
| Datum_V = W2.Range("V" & (i + 2)).Text |
| Datum_W = W2.Range("W" & (i + 2)).Text |
| Datum_X = W2.Range("X" & (i + 2)).Text |
| Datum_Y = W2.Range("Y" & (i + 2)).Text |
| Datum_Z = W2.Range("Z" & (i + 2)).Text |
| Datum_AA = W2.Range("AA" & (i + 2)).Text |
| Datum_AB = W2.Range("AB" & (i + 2)).Text |
| Datum_AC = W2.Range("AC" & (i + 2)).Text |
| Datum_AD = W2.Range("AD" & (i + 2)).Text |
| Datum_AE = W2.Range("AE" & (i + 2)).Text |
| Datum_AF = W2.Range("AF" & (i + 2)).Text |
| Datum_AG = W2.Range("AG" & (i + 2)).Text |
| Datum_AH = W2.Range("AH" & (i + 2)).Text |
| Datum_AI = W2.Range("AI" & (i + 2)).Text |
| Datum_AJ = W2.Range("AJ" & (i + 2)).Text |
| Datum_AK = W2.Range("AK" & (i + 2)).Text |
| Datum_AL = W2.Range("AL" & (i + 2)).Text |
| Datum_AM = W2.Range("AM" & (i + 2)).Text |
| Datum_AN = W2.Range("AN" & (i + 2)).Text |
| |
| 'Word Fehlermeldung abschalten |
| WordObj.Application.DisplayAlerts = Word.wdAlertsNone |
|
| 'Seriendruck für jede Zeile starten |
| Call WordSerie(WordObj, Vornam, Nachna, _ |
| Datum_I, Datum_J, Datum_K, Datum_L, Datum_M, Datum_N, _ |
| Datum_O, Datum_P, Datum_Q, Datum_R, Datum_S, Datum_T, _ |
| Datum_U, Datum_V, Datum_W, Datum_X, Datum_Y, Datum_Z, _ |
| Datum_AA, Datum_AB, Datum_AC, Datum_AD, Datum_AE, Datum_AF, _ |
| Datum_AG, Datum_AH, Datum_AI, Datum_AJ, Datum_AK, Datum_AL, _ |
| Datum_AM, Datum_AN) |
|
| VBA.DoEvents |
| frmSuchen.lblHinweis.Caption = z & " Datensätze verarbeitet" |
| frmSuchen.AlleMarkieren.Enabled = False |
| frmSuchen.cbAuswahl.Enabled = False |
| frmSuchen.cmdStart.Enabled = False |
| frmSuchen.cmdExit.Enabled = False |
|
| WordDoc.Application.DisplayAlerts = Word.wdAlertsNone |
|
| Nachna = "": Vornam = "" |
| Datum_I = "": Datum_J = "": Datum_K = "": Datum_L = "": Datum_M = "": Datum_N = "" |
| Datum_O = "": Datum_P = "": Datum_Q = "": Datum_R = "": Datum_S = "": Datum_T = "" |
| Datum_U = "": Datum_V = "": Datum_W = "": Datum_X = "": Datum_Y = "": Datum_Z = "" |
| Datum_AA = "": Datum_AB = "": Datum_AC = "": Datum_AD = "": Datum_AE = "": Datum_AF = "" |
| Datum_AG = "": Datum_AH = "": Datum_AI = "": Datum_AJ = "": Datum_AK = "": Datum_AL = "" |
| Datum_AM = "": Datum_AN = "" |
|
| End If |
| Next i |
|
| 'Speichern |
| If z >= 1 Then |
| DatName = Format(Now(), "yyyymmddhhmmss") & "_Trainings.doc" |
| Pfad = Laufwerk & DatName |
| WordObj.Options.SavePropertiesPrompt = False |
| WordDoc.SaveAs Pfad |
|
| If z = 1 Then |
| VBA.MsgBox z & " Datensatz wurde in Datei " & Pfad & " erzeugt.", VBA.vbInformation, "Info" |
| Else |
| VBA.MsgBox z & " Datensätze wurden in Datei " & Pfad & " erzeugt.", VBA.vbInformation, "Info" |
| End If |
|
| 'Word öffnen |
| ChDrive Left(ThisWorkbook.Path, 1) |
| ChDir ThisWorkbook.Path |
| Shell WinwordPfad & "winword.exe " & Pfad, 3 |
|
| Set WordDoc = Nothing |
| Set WordObj = Nothing |
| Set W2 = Nothing |
| Application.DisplayAlerts = False |
| Worksheets(TEMP1).Delete |
| Application.DisplayAlerts = True |
| Unload frmSuchen |
|
| End If |
| Exit Function |
|
| abbruch: |
| On Error Resume Next |
| WordObj.Options.SavePropertiesPrompt = False |
| WordObj.Quit |
| Set WordDoc = Nothing |
| Set WordObj = Nothing |
| Set W2 = Nothing |
| Application.DisplayAlerts = False |
| Worksheets(TEMP1).Delete |
| Application.DisplayAlerts = True |
| Unload frmSuchen |
| End Function |
|
|
| Function WordSerie(WordObj, Vorn, Nachn, _ |
| Text_I$, Text_J$, Text_K$, Text_L$, Text_M$, Text_N$, _ |
| Text_O$, Text_P$, Text_Q$, Text_R$, Text_S$, Text_T, _ |
| Text_U$, Text_V$, Text_W$, Text_X$, Text_Y$, Text_Z$, _ |
| Text_AA$, Text_AB$, Text_AC$, Text_AD$, Text_AE$, Text_AF$, _ |
| Text_AG$, Text_AH$, Text_AI$, Text_AJ$, Text_AK$, Text_AL$, _ |
| Text_AM$, Text_AN$) |
|
| Dim Training$ |
| On Error Resume Next 'Fehler durch Word-Applikation |
|
| Training = "" |
|
| With WordObj.Application.Selection |
| .Font.Bold = True |
| .Font.Size = 12 |
| |
| 'Nachname / Vorname schreiben |
| If Vorn = "" Then |
| .TypeText Text:=Nachn |
| Else |
| .TypeText Text:=Nachn & ", " & Vorn |
| End If |
| |
| .TypeParagraph: .TypeParagraph |
|
| '******************************************************** |
|
| 'Bereich "Besuchte Kurse" |