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

Please also mark the comments that contributed to the solution of the article

Content-Key: 511174

Url: https://administrator.de/contentid/511174

Printed on: April 23, 2024 at 23:04 o'clock

2 Comments

Latest comment

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

Hallo Chickenwing,

ein ganz großes Dankeschön, das ist genau das was ich gesucht habe.

Gruß aus Duisburg

German solved Question E-Mail Internet

Hotly discussed

Check of ZFW Firewallgleixnerd - 5 Comments

Wireguard VPN on UDM Pro behind Fritzbox - Handshake did not completejstricker - 3 Comments

How to set up and configure a Linux GRE tunnelAlexWisha - 3 Comments