Attachments.Add mehrere Dateien als E-Mailanhang VBS-Script

Hallo zusammen,

ich würde gerne mal eure Hilfe in Anspruch nehmen, und zwar habe ich mir mit hilfe von google ein script zusammengewerkelt was soweit auch funktioniert.

einziges Problem, ich habe überhaubt keine Ahnung wie ich die ausgewählten Dateien an ".Attachments.Add" übergeben.

Aufgabe soll einfach sein:

Verschiedene Word-Dateien aus Ordnern und Unterordnern die ein " #" Zeichen beinhalten (Dateiname #.docx) als E-Mailanhang zu versenden und das " #" zu löschen (Dateiname.docx).

Mein Script sieht folgendermaßen aus:

On Error Resume Next
Dim strList

Set FSO = WScript.CreateObject("Scripting.FilesystemObject")  
ProcFolders FSO.GetFolder("C:\Users\frost\Desktop\Test VBS\Test\")  
 
If strList = "" Then strList = "Keine Datei" & vbCrLf  

   Set objOutlook = CreateObject("Outlook.Application")  
   Set objMail = objOutlook.CreateItem(0)

With objMail

   .To = "test@gmx.de"                            'Empfänger-Adresse.                       
   .CC = ""                                       'Sendet die Email in Kopie an die angegebene Emailadresse.  
   .BCC = ""                                      'Sendet die Email in Blind-Kopie an die angegebene Emaildadresse.  
   .Subject = "Dokumente"                         'Mail-Betreff.  
                                                  'Text                                             
   .Body = "Hallo ...," & vbCrLf & vbCrLf & _  
           "sende Dir hiermit die Dokumente im Anhang." & vbCrLf & vbCrLf & _  
           "Gruß ..." & vbCrLf & vbCrLf & vbCrLf & _  
           "Anhang:" & vbCrLf & vbCrLf & _  
           "" & strList                                    
   '.HTMLBody = ""                                'HTML-Text  

   .Attachments.Add

   .ReadReceiptRequested = False                  'Lesebestätigung anforndern. (True = wahr, False = falsch)  
   .OriginatorDeliveryReportRequested = False     'Übermittlungsbestätigung anfordern. (True = wahr / False = falsch)  
   .Sensitivity = 0                               'Vertraulichkeit. (0 = Normal, 1 = Persönlich, 2 = Privat, 3 = Vertraulich)  
   .Importance = 1                                'Wichtigkeit. (0 = Niedrig, 1 = Normal, 2 = Hoch)  
   .Display                                       'Erstellt die Email und öffnet diese. Der Versand erfolgt anschließend manuell vom User!  
   '.Send                                         'Sendet die Email automatisch.  

Set objOutlook = Nothing
Set objMail = Nothing

End With

MsgBox strList & vbCrLf & "wird gesendet:",0,""  

Sub ProcFolders(Folder)
   For Each File In Folder.Files
   If LCase(Right(File.Name,7)) = " #.docx" Then  

   NewName = Replace(File.Name, " #", "")  
   File.Name = NewName

   strList = strList & File.Name & vbCrLf

   End If

Next

   For Each SubFolder In Folder.SubFolders
   On Error Resume Next
   ProcFolders(SubFolder)
   On Error Goto 0

Next

End Sub

Danke und Grüße aus Duisburg

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 511174

Url: https://administrator.de/forum/attachments-add-mehrere-dateien-als-e-mailanhang-vbs-script-511174.html

Ausgedruckt am: 05.05.2025 um 03:05 Uhr

2 Kommentare

Neuester Kommentar

Dim myfiles(), cnt
Set fso = CreateObject("Scripting.Filesystemobject")  
Set objOutlook = CreateObject("Outlook.Application")  

cnt = 0
findfiles fso.GetFolder("C:\Users\frost\Desktop\Test VBS\Test")  
If cnt > 0 Then
	Set objMail = objOutlook.CreateItem(0)
	
	With objMail
	   .To = "test@gmx.de"                            'Empfänger-Adresse.                       
	   .CC = ""                                       'Sendet die Email in Kopie an die angegebene Emailadresse.  
	   .BCC = ""                                      'Sendet die Email in Blind-Kopie an die angegebene Emaildadresse.  
	   .Subject = "Dokumente"                         'Mail-Betreff.  
	                                                  'Text                                             
	   .Body = "Hallo ...," & vbCrLf & vbCrLf & _  
	           "sende Dir hiermit die Dokumente im Anhang." & vbCrLf & vbCrLf & _  
	           "Gruß ..." & vbCrLf & vbCrLf & vbCrLf & _  
	           "Anhang:" & vbCrLf & vbCrLf                        
	
	    For Each f In myfiles
			.Attachments.Add f
                        .Body = .Body & fso.GetFileName(f) & vbNewline
	    Next
	
	   .ReadReceiptRequested = False                  'Lesebestätigung anforndern. (True = wahr, False = falsch)  
	   .OriginatorDeliveryReportRequested = False     'Übermittlungsbestätigung anfordern. (True = wahr / False = falsch)  
	   .Sensitivity = 0                               'Vertraulichkeit. (0 = Normal, 1 = Persönlich, 2 = Privat, 3 = Vertraulich)  
	   .Importance = 1                                'Wichtigkeit. (0 = Niedrig, 1 = Normal, 2 = Hoch)  
	   .Display                                       'Erstellt die Email und öffnet diese. Der Versand erfolgt anschließend manuell vom User!  
	   '.Send                                         'Sendet die Email automatisch.  
	End With
Else
	MsgBox "Keine passenden Dateien gefunden.",vbExclamation  
End If

Function findfiles(strFldr)
	For each file In strFldr.Files
		If LCase(fso.GetExtensionName(file.Name)) = "docx" and InStr(1,file.Name,"#",vbTextCompare) > 0 Then  
			strNew = Replace(file.Name,"#","",1,-1,1)  
			ReDim Preserve myfiles(cnt)
			myfiles(cnt) = fso.GetParentFolderName(file.Path) & "\" & strNew  
			cnt = cnt + 1
			file.Name = strNew
		End If
	Next
	For Each subFolder in strFldr.SubFolders
		findfiles subFolder
	Next
End Function


Set objOutlook = Nothing
Set objMail = Nothing
Set fso = Nothing