Hallo Hr. Huber, meines Wissens kann das DATEV nicht, obwohl es auch kein Problem wäre. In einem ähnlichen Fall löse ich so etwas über ein eigenes Makro direkt in Outlook. Dazu gehe ich wie folgt vor: [Ziel] Es soll immer für einen Mandanten die FiBu-Auswertungen als Einzeldateien per Mail versendet werden. Im Mailtext möchte ich zusätzlich eine persönliche Anrede und die zu fällige USt. mitteilen. [Vorgehensweise] Es werden alle Ausdrucke einzeln in eine festes Verzeichnis exportiert. Ich öffne OL und erstelle eine neue Mail. [Formular] Die Mailadressen sind in einer INI gespeichert und wird beim Start des Formulars ausgelesen. Nach dem Klicken des Button "Mail erstellen" wird in der offenen Mail der Standardtext und die Anlagen eingefügt. [Code] Private Sub cmdMail_Click() Dim objItem As MailItem Dim sTex As String Dim fso As New FileSystemObject Dim objShell As New WshShell Dim a As Object Dim strMailFile As String 10 On Error GoTo cmdMail_Click_Error 20 Dim sTB As String: sTB = GetIniString("Autotext", "FiBu", "", sFileINI) 30 If sTB = "" Then 40 Call MsgBox("Es wurde der Autotext-Name für die FiBu-Mail noch nicht in der INI gespeichert." _ & vbCrLf & "" _ & vbCrLf & "Bitte tragen Sie erst unter der Rubrik [Autotext] den Autotextnamen ein." _ & vbCrLf & " [Autotext]" _ & vbCrLf & " FiBu=..." _ , vbExclamation, "Autotext FiBu-Mail") 50 Exit Sub 60 End If Dim objWord As Word.Application Dim objDoc As Word.Document Dim objSel As Word.Selection Dim myAT As AutoTextEntry 'On Error Resume Next 70 Set objItem = Application.ActiveInspector.CurrentItem 80 objItem.BodyFormat = olFormatHTML 'immer HTML 90 If Not objItem Is Nothing Then 100 If objItem.Class = olMail Then 110 Set objInsp = objItem.GetInspector 120 If objInsp.EditorType = olEditorWord Then 130 Set objDoc = objInsp.WordEditor 140 Set objWord = objDoc.Application 150 Set objSel = objWord.Selection '170 objWord.ScreenUpdating = False 160 For Each myAT In objDoc.AttachedTemplate.AutoTextEntries 170 If (myAT.Name = sTB) Then Exit For 180 Next 190 myAT.Insert objSel.Range, True 200 With objDoc.Content.Find 210 .Text = "<Anrede>" 220 .Replacement.Text = sAnrede 230 .Forward = True 240 .Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue 250 End With 260 With objDoc.Content.Find 270 .Text = "<FiBu>" 280 .Replacement.Text = txtFiBu_Zeitraum.Text 290 .Forward = True 300 .Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue 310 End With 320 With objDoc.Content.Find 330 .Text = "<Firma>" 340 .Replacement.Text = cmbEmpfänger.Text 350 .Forward = True 360 .Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue 370 End With Dim sSchlusssatz As String Dim cSumme As Currency 380 cSumme = (CCur("0" & txtSVZ.Text) + CCur("0" & txtZahllast.Text)) 390 If cSumme > 0 Then 400 If chkEinzug.Value = True Then 410 sSchlusssatz = "Die Steuerzahlungen werden zum " & dFällig & " vom Finanzamt abgebucht." 420 Else 430 sSchlusssatz = "Bitte überweisen die Steuerzahlungen bis zum " & dFällig & "." 440 End If 450 Else 460 sSchlusssatz = "Das Guthaben wird Ihnen erstattet." 470 End If 480 With objDoc.Content.Find 490 .Text = "<Zahlungsart>" 500 .Replacement.Text = sSchlusssatz 510 .Forward = True 520 .Execute Replace:=wdReplaceAll, Forward:=True, Wrap:=wdFindContinue 530 End With Dim c As Cell Dim aTbl As Word.Table 540 Set aTbl = objDoc.Tables.Item(1) 550 On Error Resume Next 560 With aTbl 570 .Borders(wdBorderLeft).LineStyle = wdLineStyleNone 580 .Borders(wdBorderRight).LineStyle = wdLineStyleNone 590 .Borders(wdBorderTop).LineStyle = wdLineStyleNone 600 .Borders(wdBorderBottom).LineStyle = wdLineStyleNone 610 .Borders(wdBorderHorizontal).LineStyle = wdLineStyleNone 620 .Borders(wdBorderVertical).LineStyle = wdLineStyleNone 630 .Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone 640 .Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone 650 .Borders.Shadow = False .PreferredWidth = objWord.CentimetersToPoints(9) .Columns(1).PreferredWidthType = wdPreferredWidthPoints 660 .Columns(1).Width = objWord.CentimetersToPoints(3) .Columns(2).PreferredWidthType = wdPreferredWidthPoints 670 .Columns(2).Width = objWord.CentimetersToPoints(3) .Columns(3).PreferredWidthType = wdPreferredWidthPoints 680 .Columns(3).Width = objWord.CentimetersToPoints(3) 690 End With 700 On Error GoTo cmdMail_Click_Error 710 With aTbl 720 Set c = .Cell(2, 1) 730 c.Range.InsertAfter "USt.-VA" 740 Set c = .Cell(2, 2) 750 c.Range.InsertAfter txtUStVA_Zeitraum.Text 760 c.Select 770 objSel.ParagraphFormat.Alignment = wdAlignParagraphRight 780 Set c = .Cell(2, 3) 790 c.Range.InsertAfter txtZahllast.Text 800 c.Select 810 objSel.ParagraphFormat.Alignment = wdAlignParagraphRight 820 If txtSVZ.Enabled = False Then 830 .Rows(.Rows.Count).Delete 840 .Rows(.Rows.Count).Delete 850 Else 'SVZ Ja 860 Set c = .Cell(3, 1) 870 c.Range.InsertAfter "USt.-SVZ" 880 Set c = .Cell(3, 2) 890 c.Range.InsertAfter Year(CDate(txtUStVA_Zeitraum.Text)) + 1 900 c.Select 910 objSel.ParagraphFormat.Alignment = wdAlignParagraphRight 920 Set c = .Cell(3, 3) 930 c.Range.InsertAfter txtSVZ.Text 940 c.Select 950 objSel.ParagraphFormat.Alignment = wdAlignParagraphRight 'Summe SVZ 960 Set c = .Cell(4, 3) 970 c.Range.InsertAfter Format(cSumme, "#,##.0,00") 980 c.Select 990 With objSel 1000 .ParagraphFormat.Alignment = wdAlignParagraphRight 1010 .Font.Bold = True 1020 .Borders(wdBorderTop).LineStyle = wdLineStyleSingle 1030 .Borders(wdBorderBottom).LineStyle = wdLineStyleDouble 1040 End With 1050 End If 1060 End With 1070 objDoc.Select 1080 With objSel 1090 .Font.Name = "Calibri" 1100 .Font.Size = 11 1110 End With 1120 Set objSel = Nothing 1130 With objWord 1140 .Selection.EndKey wdStory 1150 .Selection.Collapse 1160 End With Dim colFile As New Collection 1170 Set colFile = FindFiles(sExportPfad, "*" & cmbEmpfänger.List(cmbEmpfänger.ListIndex, 0) & "*.*", False, vbNormal) 1180 With objItem 1190 .To = sMailEmpfänger 1200 .Subject = "FiBu-Auswertung für " & txtFiBu_Zeitraum.Text 1210 For i = 1 To colFile.Count 1220 .Attachments.Add colFile(i) 1230 fDelete colFile(i), True, False 1240 Next 1250 End With 1260 End If 1270 End If 1280 End If 1290 Unload Me 1300 Set objDoc = Nothing 1310 Set objWord = Nothing 1320 Set objSel = Nothing 1330 On Error GoTo 0 1340 Exit Sub cmdMail_Click_Error: 1350 objWord.ScreenUpdating = True 1360 MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Zeile " & Erl() & " procedure cmdMail_Click of Formular frmMailversand" End Sub Das ist zwar nur die Hauptfunktion, enthält aber für einen ambitionierten Anwender so ziemlich alle notwendigen Bestandteile. Wer möchte kann es sich anschauen. Ich nutze dieses Makro jetzt seit wir DATEV nutzen und es hat mich nie im Stich gelassen. Gruß A. Martens Hilf dir selbst, dann hilft dir Gott.
... Mehr anzeigen