Run Outlook rule

rollingzep said:

Hi,

Currently, I run a rule in Outlook which saves the MS Edge html files in the emails inbox folder to an attachments folder in the shared drive.
I then open an Access DB and click the Import button to import these files from the attachments folder.
The process works fine.

Is there a way to run the Outlook rule from the Access DB to download the Outlook files to the attachments folder
and then use the Import button to load the data into the table?

Also, I want to use a scheduler to run the above job on a specific time everyday at 8.15 am before everyone logs in, is that possible?

This is my Outlook code, which I run as a rule.

VBA Code:

Sub NEW_AutoProcessXML(mymail As MailItem)



Dim MYNAMESPACE As NameSpace
Dim MYFOLDER As Outlook.Folder
Dim objAttachments As Outlook.Attachments

Set MYNAMESPACE = Outlook.GetNamespace("MAPI")
Set MYFOLDER = MYNAMESPACE.GetDefaultFolder(olFolderInbox)


Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
'Dim strDeletedFiles As String
Dim objSubject As String
Dim objDestfolder As Outlook.Folder


strFolderpath = "S:\beData\prof_data"
'On Error Resume Next

' Set the Attachment folder.
strFolderpath = strFolderpath & "\Attachments\"

'Set the Destination folder
Set objDestfolder = MYNAMESPACE.Folders.Item("WeeklyProceedings Mailbox").Folders.Item("Folders").Folders.Item("Archive_Proc")


objSubject = mymail.Subject

sreplace = "_"
'create an array to loop through and replace any potential illegal characters

For Each mychar In Array("/", "\", "^", "*", "%", "$", "#", "@", "~", "`", "{", "}", "[", "]", "|", ";", ":", ",", ".", "'", "+", "=", "?", "!", " ", Chr(34), "<", ">", "¦")
   objSubject = Replace(objSubject, mychar, sreplace)
Next mychar

    Set objAttachments = mymail.Attachments
    lngCount = objAttachments.Count
    'strDeletedFiles = ""

    If lngCount > 0 Then

        ' We need to use a count down loop for removing items
        ' from a collection. Otherwise, the loop counter gets
        ' confused and only every other item is removed.

        For i = lngCount To 1 Step -1

           strFile = objSubject & ".XML"

            ' Combine with the path to the Temp folder.
           strFile = strFolderpath & strFile

            ' Save the attachment as a file.
            objAttachments.Item(i).SaveAsFile strFile
       Next i

       
        mymail.Body = mymail.Body & vbCrLf & "The file was processed " & Now()
             
        mymail.Subject = "Processed - " & objSubject
        mymail.Save

    End If
 
   
    mymail.Move objDestfolder
'Next


Set objAttachments = Nothing
Set mymail = Nothing
End Sub

TIA

Click to expand...

welshgasman said:

Have you tried walking your code with a breakpoint and F8?

Click to expand...

welshgasman said:

Here is something I used to use to save attachments and replace them with links to the files.
Perhaps you can amend that, or see what you are not doing.?

HTH

Code:

Public Sub ReplaceAttachmentsToLink()
Dim objApp As Outlook.Application
Dim aMail As Outlook.MailItem 'Object
Dim oAttachments As Outlook.Attachments
Dim oSelection As Outlook.Selection
Dim i As Long
Dim iCount As Long
Dim sFile As String, strFileType As String
Dim sFolderPath As String
Dim sDeletedFiles As String
Dim strDate As String, strTime As String
Dim blnSaveFile As Boolean

 
    ' Get the path to your My Documents folder
    sFolderPath = CreateObject("WScript.Shell").SpecialFolders(16)
    On Error Resume Next
 
    ' Instantiate an Outlook Application object.
    Set objApp = CreateObject("Outlook.Application")
 
    ' Get the collection of selected objects.
    Set oSelection = objApp.ActiveExplorer.Selection
 
    ' Set the Attachment folder.
    sFolderPath = sFolderPath & "\OLAttachments"
   
    ' Now allow a different folder from the default
   
    sFolderPath = GetFileFolder(sFolderPath)
   
    'Create folder if it does not exist
    If Dir(sFolderPath, vbDirectory) = "" Then
        MkDir sFolderPath
    End If
 
    
    ' Check each selected item for attachments. If attachments exist,
    ' save them to the Temp folder and strip them from the item.
    For Each aMail In oSelection
 
    ' This code only strips attachments from mail items.
    ' If aMail.class=olMail Then
    ' Get the Attachments collection of the item.
    Set oAttachments = aMail.Attachments
    iCount = oAttachments.Count
     
       
    If iCount > 0 Then
     
        ' We need to use a count down loop for removing items
        ' from a collection. Otherwise, the loop counter gets
        ' confused and only every other item is removed.
         
        For i = iCount To 1 Step -1
            blnSaveFile = True
            ' This code looks at the last 4 characters in a filename
            sFile = oAttachments.item(i).fileName
            strFileType = LCase$(Right$(sFile, 4))

            Select Case strFileType
            ' Add additional file types below
            Case ".jpg", ".png", ".gif"
                If oAttachments.item(i).Size < 5200 Then
                    blnSaveFile = False
                End If
            End Select

            If blnSaveFile Then
                ' Save attachment before deleting from item.
                ' Get the file name.
                ' sFile = oAttachments.Item(i).FileName
             
                ' Combine with the path to the Temp folder. Add date and time strings as filenames can be the same
                 strDate = Format(aMail.ReceivedTime, "yyyymmdd")
                 strTime = Format(aMail.ReceivedTime, "hhmmss")
                 sFile = sFolderPath & "\" & strDate & "_" & strTime & "_" & sFile
             
                ' Save the attachment as a file.
                oAttachments.item(i).SaveAsFile sFile
             
                ' Delete the attachment.
                oAttachments.item(i).Delete
             
                'write the save as path to a string to add to the message
                'check for html and use html tags in link
                If aMail.BodyFormat <> olFormatHTML Then
                    sDeletedFiles = sDeletedFiles & vbCrLf & "<file://" & sFile & ">"
                Else
                    sDeletedFiles = sDeletedFiles & "<br>" & "<a href='file://" & _
                    sFile & "'>" & sFile & "</a>"
                End If
              End If
                         
        Next i
        'End If
             
       ' Adds the filename string to the message body and save it
       ' Check for HTML body
       If aMail.BodyFormat <> olFormatHTML Then
           aMail.Body = aMail.Body & vbCrLf & _
           "The file(s) were saved to " & sDeletedFiles
       Else
           aMail.HTMLBody = aMail.HTMLBody & "<p>" & _
           "The file(s) were saved to " & sDeletedFiles & "</p>"
       End If
      
       ' Now flag the email so we know which emails had attachments

       aMail.Categories = aMail.Categories & ", Attached"
       aMail.FlagStatus = olFlagMarked
       'aMail.FlagIcon = 6
       
       aMail.Save
       'sets the attachment path to nothing before it moves on to the next message.
       sDeletedFiles = ""
    
       End If
    Next 'end aMail
     
ExitSub:
 
Set oAttachments = Nothing
Set aMail = Nothing
Set oSelection = Nothing
Set objApp = Nothing
End Sub

Click to expand...

welshgasman said:

Here is something I used to use to save attachments and replace them with links to the files.
Perhaps you can amend that, or see what you are not doing.?

HTH

Code:

Public Sub ReplaceAttachmentsToLink()
Dim objApp As Outlook.Application
Dim aMail As Outlook.MailItem 'Object
Dim oAttachments As Outlook.Attachments
Dim oSelection As Outlook.Selection
Dim i As Long
Dim iCount As Long
Dim sFile As String, strFileType As String
Dim sFolderPath As String
Dim sDeletedFiles As String
Dim strDate As String, strTime As String
Dim blnSaveFile As Boolean

 
    ' Get the path to your My Documents folder
    sFolderPath = CreateObject("WScript.Shell").SpecialFolders(16)
    On Error Resume Next
 
    ' Instantiate an Outlook Application object.
    Set objApp = CreateObject("Outlook.Application")
 
    ' Get the collection of selected objects.
    Set oSelection = objApp.ActiveExplorer.Selection
 
    ' Set the Attachment folder.
    sFolderPath = sFolderPath & "\OLAttachments"
   
    ' Now allow a different folder from the default
   
    sFolderPath = GetFileFolder(sFolderPath)
   
    'Create folder if it does not exist
    If Dir(sFolderPath, vbDirectory) = "" Then
        MkDir sFolderPath
    End If
 
    
    ' Check each selected item for attachments. If attachments exist,
    ' save them to the Temp folder and strip them from the item.
    For Each aMail In oSelection
 
    ' This code only strips attachments from mail items.
    ' If aMail.class=olMail Then
    ' Get the Attachments collection of the item.
    Set oAttachments = aMail.Attachments
    iCount = oAttachments.Count
     
       
    If iCount > 0 Then
     
        ' We need to use a count down loop for removing items
        ' from a collection. Otherwise, the loop counter gets
        ' confused and only every other item is removed.
         
        For i = iCount To 1 Step -1
            blnSaveFile = True
            ' This code looks at the last 4 characters in a filename
            sFile = oAttachments.item(i).fileName
            strFileType = LCase$(Right$(sFile, 4))

            Select Case strFileType
            ' Add additional file types below
            Case ".jpg", ".png", ".gif"
                If oAttachments.item(i).Size < 5200 Then
                    blnSaveFile = False
                End If
            End Select

            If blnSaveFile Then
                ' Save attachment before deleting from item.
                ' Get the file name.
                ' sFile = oAttachments.Item(i).FileName
             
                ' Combine with the path to the Temp folder. Add date and time strings as filenames can be the same
                 strDate = Format(aMail.ReceivedTime, "yyyymmdd")
                 strTime = Format(aMail.ReceivedTime, "hhmmss")
                 sFile = sFolderPath & "\" & strDate & "_" & strTime & "_" & sFile
             
                ' Save the attachment as a file.
                oAttachments.item(i).SaveAsFile sFile
             
                ' Delete the attachment.
                oAttachments.item(i).Delete
             
                'write the save as path to a string to add to the message
                'check for html and use html tags in link
                If aMail.BodyFormat <> olFormatHTML Then
                    sDeletedFiles = sDeletedFiles & vbCrLf & "<file://" & sFile & ">"
                Else
                    sDeletedFiles = sDeletedFiles & "<br>" & "<a href='file://" & _
                    sFile & "'>" & sFile & "</a>"
                End If
              End If
                         
        Next i
        'End If
             
       ' Adds the filename string to the message body and save it
       ' Check for HTML body
       If aMail.BodyFormat <> olFormatHTML Then
           aMail.Body = aMail.Body & vbCrLf & _
           "The file(s) were saved to " & sDeletedFiles
       Else
           aMail.HTMLBody = aMail.HTMLBody & "<p>" & _
           "The file(s) were saved to " & sDeletedFiles & "</p>"
       End If
      
       ' Now flag the email so we know which emails had attachments

       aMail.Categories = aMail.Categories & ", Attached"
       aMail.FlagStatus = olFlagMarked
       'aMail.FlagIcon = 6
       
       aMail.Save
       'sets the attachment path to nothing before it moves on to the next message.
       sDeletedFiles = ""
    
       End If
    Next 'end aMail
     
ExitSub:
 
Set oAttachments = Nothing
Set aMail = Nothing
Set oSelection = Nothing
Set objApp = Nothing
End Sub

Click to expand...

welshgasman said:

It has been over 8 years since I cobbled that code together from snippets I found on the net.
I am not and was not then conversant with the Outlook object model.
It was all trial and error.
In my version I selected a bunch of emails and it worked on those.

TBH Set objDestfolder = MYNAMESPACE.Folders.Item("WeeklyProceedings Mailbox").Folders.Item("Folders").Folders.Item("Archive_Proc") looks a little strange to me.
Have you checked the Locals window that that is a correct path?

Put a few debug.print lines in to see what you are getting.
If i is still zero then your inner for loop is not being processed. Is the outer loop?

You could also ask here but do say it is a crosspost and link back to this thread and also say here that you have crossposted if you do.
There is an expert over there called GMayor who has helped me a good few times in Outlook code.

Sorry I cannot help more.

Click to expand...