derbyron
Goto Top

Outlook VBA - Mail senden, verschieben, Optionen anpassen

Hallo erstmal,
ich bräuchte einmal ein wenig Unterstützung von den Outlook / VBA / Makro Spezialisten.

Zum Hintergrund:
Wir haben 8 Kollegen die jeweils Ihren eigenen Mailaccount nutzen, aber auch immer wieder
Mails aus einem Gruppenaccount verschicken müssen.

Um die Fehlerquellen zu minimieren würde die folgenden Schritte gerne per Makro automatisieren:

- Neue Mail öffnen
- Subject eintragen
- Sent on behalf Adresse eintragen
- Reply to Adresse setzen
- eigene Signatur löschen und die vom Gruppenaccount einfügen

Nach dem Verschicken der Mail soll diese vom Sent Folder des Users in den Sent Folder
des Gruppenaccounts kopiert werden.


Durch diesen Code

Sub Mail_SHD()
Dim myOLApp As New Outlook.Application
Dim myOLItem As Outlook.MailItem
Set myOLItem = myOLApp.CreateItem(olMailItem)
With myOLItem
.SentOnBehalfOfName = "gruppenaccount@domain.com"  
.Subject = "Mail aus DACH SERVICE DESK"  

End With
myOLItem.Display

Set objOLItem = Nothing

End Sub

wird schon mal eine neue Mail erstellt, die Sent on behalf Adresse eingetragen.


Nun zu meinen Problemen:

- Ich kriege es trotz einiger Info aus der Google Suche nicht hin die Reply To Adresse automatisiert setzen zu lassen.

- Ich bekomme die Signatur nicht gelöscht und neu gesetzt.

- Ich kriege es leider nicht hin das die Mail nach dem Verschicken in den Sent Folder der Gruppenmailbox verschoben wird.
Der unten gezeigte CODE soll dies ermöglichen, erstens verschiebt er die Mails bei mir garnicht und zweitens hätte ich
gerne das er die Mails immer, ohne Nachfrage nach "Gruppenmailbox\Sent Items" verschiebt.

Private Sub Application_ItemSend(ByVal Item As Object, _
    Cancel As Boolean)
  Dim objNS As NameSpace
  Dim objFolder As MAPIFolder
  Set objNS = Application.GetNamespace("MAPI")  
  Set objFolder = objNS.PickFolder
  If TypeName(objFolder) <> "Nothing" And _  
     IsInDefaultStore(objFolder) Then
      Set Item.SaveSentMessageFolder = objFolder
  End If
  Set objFolder = Nothing
  Set objNS = Nothing
End Sub


Public Function IsInDefaultStore(objOL As Object) As Boolean
  Dim objApp As Outlook.Application
  Dim objNS As Outlook.NameSpace
  Dim objInbox As Outlook.MAPIFolder
  On Error Resume Next
  Set objApp = CreateObject("Outlook.Application")  
  Set objNS = objApp.GetNamespace("MAPI")  
  Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
  Select Case objOL.Class
    Case olFolder
      If objOL.StoreID = objInbox.StoreID Then
        IsInDefaultStore = True
      End If
    Case olAppointment, olContact, olDistributionList, _
         olJournal, olMail, olNote, olPost, olTask
      If objOL.Parent.StoreID = objInbox.StoreID Then
        IsInDefaultStore = True
      End If
    Case Else
      MsgBox "This function isn't designed to work " & _  
             "with " & TypeName(objOL) & _  
             " items and will return False.", _  
             , "IsInDefaultStore"  
  End Select
  Set objApp = Nothing
  Set objNS = Nothing
  Set objInbox = Nothing
End Function

Vielen Dank für eure Mühe ich hoffe ihr könnt mit dabei helfen. Ich bin
nicht wirklich VBA bewandert, wenn ich was lese verstehe ich es aber
meistens ;)

Gruß Jan

Content-Key: 99850

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

Printed on: April 25, 2024 at 05:04 o'clock