Не запускаются макросы Outlook - VB

Private Sub AppLication_NewMail()
Dim tema As String
Dim Olbody As String
Dim zadacha As String
Dim OlTime As Date
Dim srok As Date
Dim fail As String
Dim poluchatel As String

tema = "ÅÏÌ:"
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myfolder1 = myfolder.Folders("ÅÏÌ").Items
Set myitem = myfolder1.GetLast 'getlast - ïîñëåäíåå ïèñüìî!!!!
OlSubject = myitem.Subject

If myitem.UnRead = False Then 'áëîê
'Quit (WB)
Exit Sub
End If

If InStr(1, OlSubject, tema) <= 1 Then

 Z = MsgBox("Ðàáîòåíêà ïðèëåòåëà, äîáàâëÿåì â ÅÏÌ?", vbYesNo)
 If Z = 7 Then
 Exit Sub
 End If

 Olbody = myitem.Body
 OlTime = myitem.SentOn
 
 Set EX = CreateObject("Excel.Application")
 Set WB = EX.Workbooks.Open("1.xlsm")
 
 a = InStr(1, Olbody, "Çàäà÷à: ")
 b = InStr(a, Olbody, "%%") 'ïîìåíÿòü íà %%
 c = b - a
 zadacha = Mid(Olbody, a + 8, c - 8)
 WB.Worksheets("Ëèñò1").Range("A2").Value = zadacha
 
 WB.Worksheets("Ëèñò1").Range("B2").Value = OlTime
 
 a = InStr(1, Olbody, "Ñðîê: äî ")
 b = InStr(a, Olbody, "%%") 'ïîìåíÿòü íà %%
 c = b - a
 srok = Mid(Olbody, a + 9, c - 9)
 WB.Worksheets("Ëèñò1").Range("C2").Value = srok
  
 If InStr(1, Olbody, "Ðàáî÷èé ôàéë: ") > 0 Then
 a = InStr(1, Olbody, "Ðàáî÷èé ôàéë: ") 'ïîìåíÿòü íà Ðàáî÷èé ôàéë
 b = InStr(a, Olbody, "%%") 'ïîìåíÿòü íà %%
 c = b - a
 fail = Mid(Olbody, a + 10, c - 10) 'ïîñëå èçìåíåíèÿ áóäåò íå 10
 WB.Worksheets("Ëèñò1").Range("D2").Value = fail
 End If
 
 poluchatel = myitem.CC + "; " + myitem.To
 
 WB.Worksheets("Ëèñò1").Range("E2").Value = poluchatel

 MsgBox "åñòü"

 Else
  MsgBox "íåòó"
  Exit Sub
 End If
 WB.Application.Visible = True
 On Error GoTo 111
 WB.Application.Run "EMP_copy"
111
End Sub