VBA: Start Macro, when E-Mail arrives in shared Mailbox?

[Soda]

Hello dear vba forum.

I am new here and hope you can help me.

Unfortunately I only know a little Excel-VBA (and minimal PPT-VBA), that is: I can solve my problems and tasks partly by myself and sometimes I need an idea (from a forum), which brings me on the right way and I can almost solve my problem by myself.
Sometimes I just need someone to show me the code so I can learn something new again. So now I teach myself outlook vba - I peek at the others and learn from it.

Now this is my first outlook project and I have a question where I can't find the solution though and hope someone can show me how to do it.

My script:
I made myself a script that is always started when an email arrives. If it is an order with a certain word in the email body, then copy the mail and add the due date in the subject line.

The script (see below) works quite perfectly.

My problem:
However, it should now work with the shared mailbox in the same way, or rather, I actually need the script exclusively for the shared mailbox.

Can you help me?

Many thanks already...

Patrick


Sub Intialize_Handler()
Set outApp = Outlook.Application
End Sub



Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

'Debug.Print

Dim objEMail, objEMailCopy As Object
Dim intInitial As Integer
Dim intFinal As Integer
Dim strEntryId As String
Dim intLength As Integer
Dim posDatum As Integer 'Position of the order date in the e-mail
Dim datVersanddatum, datFaelligkeit As Date 'order date, due date

intInitial = 1
intLength = Len(EntryIDCollection)
intFinal = InStr(intInitial, EntryIDCollection, ",")

strEntryId = Strings.Mid(EntryIDCollection, intInitial, (intLength - intInitial) + 1)
Set objEMail = Application.Session.GetItemFromID(strEntryId)

If (InStr(objEMail.Subject, "New Order") > 0) Then
If (InStr(objEMail.Body, "Product: Ultimate") > 0) Then

Set objEMailCopy = objEMail.Copy

posDatum = InStr(objEMailCopy.Body, "Order-Date: ")
datVersanddatum = CDate(Mid(objEMailCopy.Body, posDatum + 24, 10))

If Weekday(datVersanddatum) >= 5 Then
datFaelligkeit = datVersanddatum + 40 + (8 - Weekday(datVersanddatum)) ' if weekend, then put next Monday and add 40 days
Else
datFaelligkeit = datVersanddatum + 40
End If

If Weekday(datFaelligkeit) >= 6 Then
datFaelligkeit = datFaelligkeit - (7 - Weekday(datFaelligkeit)) ' if due date = weekend, then set Friday
End If

objEMailCopy.Subject = Right(objEMailCopy.Subject, Len(objEMailCopy.Subject) - 17)
objEMailCopy.Subject = "Due Date: " & Format(datFaelligkeit, "dd.mm.yyyy") & " >> " & objEMailCopy.Subject
objEMailCopy.Save
End If
End If


End Sub

[georgiboy]

Perhaps the below will help, it goes into the 'ThisOutlookSession' module:


Option Explicit

Private WithEvents inboxItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application: Set outlookApp = Outlook.Application
Dim objectNS As Outlook.NameSpace: Set objectNS = outlookApp.GetNamespace("MAPI")
Dim ShrdRecip As Outlook.Recipient: Set ShrdRecip = objectNS.CreateRecipient("YourSharedMailboxAddress@somewhere.com")
Set inboxItems = objectNS.GetSharedDefaultFolder(ShrdRecip, olFolderInbox).Items
End Sub


Private Sub inboxItems_ItemAdd(ByVal Item As Object)
If InStr(UCase(Item.Body), "HI") > 0 Then
macro_1
End If
End Sub


Sub macro_1()
MsgBox "Email with the word: HI was received"
End Sub

If a mail is received with the word "HI" in the body then macro_1 will fire.

Hope this helps

[Soda]

hmm... seems that this is the result of your vba-code:
https://prnt.sc/1uXa7hiWdw9V

JIPPPPPIIIIEEEEE it works.

Thank you so much.

There is a little mistake in the first line (linebreak after "Option Explicit" is missing)



Patrick

[georgiboy]

Glad it worked for you, I have corrected that in case others view the code.

Cheers,

George