Outlook rule to run script

[Clemm]

Hi,

Was wondering if anyone could enlighten me as to what i am misiing...

I've managed to piece together the below code using various sources (some from here) and bits of code (amended to what i need). I am tying to use the rule function in outlook and it seems to work until the 'run script' part. The rules i've set are for new messages into my inbox 'move e-mail to folder --> copy to another folder location (i have copied as the script deletes the original) --> run script --> display desktop alert'.

I can open up the editor and run it manually and it goes through fine. When the rule is active i can see the copied e-mail in the other folder location but no sent e-mail.

There are two parts to this code, one to save the attachments (Sub SaveAttachments) and one to call up an excel macro then send the output of that macro (Sub AttachFiles).

Sub SaveAttachments()
Dim olApp As Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olMail As Outlook.MailItem
Dim olFolder As Outlook.MAPIFolder
Dim olAttachment As Outlook.Attachment
Dim lngAttachmentCounter As Long
Dim SFolder As String
Dim MFolder As String
Dim DFolder As String
Dim XLApp As Object ' Excel.Application
Dim XlWK As Object ' Excel.Workbook
 
'Create an instance of Outlook and allow the user to choose
'which folder they want to process
Set olApp = New Outlook.Application
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Folders("Transfer")
SFolder = "c:\Test"
MFolder = "c:\Documens\[URL="file://\\Sw-lonthc-fil01\users-uk$\T1013935\Documents\Macros\BEMacro.xlsm"]Macro.xlsm[/URL]"
If olFolder Is Nothing Then Exit Sub    'User cancelled
For Each olMail In olFolder.Items
    If olMail.UnRead = True Then    'If you want ALL messages processed then take this line out and the End If
        For Each olAttachment In olMail.Attachments
            lngAttachmentCounter = lngAttachmentCounter + 1
            olAttachment.SaveAsFile SFolder & olAttachment.DisplayName
            DFolder = SFolder & olAttachment.DisplayName
            
            Set XLApp = CreateObject("Excel.Application")
                XLApp.Workbooks.Open MFolder
                XLApp.Workbooks.Open DFolder
                XLApp.Run ("Macro.xlsm!Macro")
                
                XLApp.Application.DisplayAlerts = False
                XLApp.Workbooks.Close
                XLApp.Application.DisplayAlerts = True
                XLApp.Quit
                Kill DFolder
                
                
                Set XLApp = Nothing
            
          Call AttachFiles
          
          olMail.UnRead = False
          olMail.Delete
            
        Next olAttachment
    End If
Next olMail
End Sub


Sub AttachFiles()

Dim strFolder As String
Dim FileType As String
Dim SD As String
Dim StrBody
    SD = Format(Date, "DD MMM YY")
    
    StrBody = "<H3><B>Hi</B></H3>" & _
              "<H3><B>XXXXXXXXXXXXXXXXXXX.</B><H3>"
    
FileType = "*.xls"
strFolder = "c:\Test"
' check if folder exists
If Dir(strFolder, vbDirectory) = "" Then
GoTo ExitProc
End If
' check if folder contains specified items
Dim strFileN As String
strFileN = Dir(strFolder & FileType)
If Len(strFileN) = 0 Then
GoTo ExitProc
End If
' create mailitem
Dim olApp As Outlook.Application
Dim msg As Outlook.MailItem
Dim olAttach As Outlook.Attachments
Dim Signature As String
     
Set olApp = Application
Set msg = olApp.CreateItem(olMailItem)
Set olAttach = msg.Attachments
    With msg
        .Display
        .Recipients.Add "[EMAIL="xxxxxx@xxxxx.com"]xxxxxx@xxxxx.com[/EMAIL]"
       
        .Subject = "XXXXXXXXXXXXX" & SD
        .HTMLBody = StrBody & "<br>" & .HTMLBody
    End With
' loop through folder and add attachments'
'if we got this far, strFileN will already contain the'
'name of the first file in the dir
Do While Len(strFileN) > 0
olAttach.Add strFolder & strFileN
Kill strFolder & strFileN
strFileN = Dir
Loop
msg.Send
ExitProc:
Set olApp = Nothing
End Sub

Any help would be appreciated