Run Outlook rule

[rollingzep]

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.

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

 

[rollingzep]

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.

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

How to modify the above Outlook VBA code as a Command button Click event in Access VBA?

 

[rollingzep]

Hello,

Can someone check why the email items are not selected from the WeeklyProceedings Mailbox

Private Sub cmdOutlook_Click()


Dim objOL As Outlook.Application
Dim objMsg As Object
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim objAttachments As Outlook.Attachments
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderpath As String
Dim strDeletedFiles As String

    ' Get the path to your My Documents folder
    strFolderpath = "C:\PG\Testing"
    On Error Resume Next

    ' Instantiate an Outlook Application object.
    Set objOL = Application
    Set objNS = objOL.GetNamespace("MAPI")
    Set objFolder = objNS.GetDefaultFolder(olFolderInbox)

    ' Get the collection of selected objects.
    Set objFolder = objNS.Folders.Item("WeeklyProceedings Mailbox").Folders.Item("Folders").Folders.Item("Archive_Proc")

' The attachment folder needs to exist
' You can change this to another folder name of your choice

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

    ' Check each selected item for attachments.
    For Each objMsg In objFolder.Items
        For Each objAttachments In objMsg.Attachments
            strFile = objAttachments.Item(i).FileName
            strFile = strFolderpath & strFile
            objAttachments.SaveAsFile strFile
            i = i + 1
        Next objAttachments

'    Set objAttachments = objMsg.Attachments
'    lngCount = objAttachments.Count
'
'    If lngCount > 0 Then
'
'    ' 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
'
'    ' Get the file name.
'    strFile = objAttachments.Item(i).FileName
'
'    ' Combine with the path to the Temp folder.
'    strFile = strFolderpath & strFile
'
'    ' Save the attachment as a file.
'    objAttachments.Item(i).SaveAsFile strFile
'
'    Next i
'    End If
'
  Next
    
ExitSub:

Set objAttachments = Nothing
Set objMsg = Nothing
Set objOL = Nothing
    
End Sub

 

[welshgasman]

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

 

[rollingzep]

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

Yes, but the value of i is 0 and looks like it is not reading the items.

 

[welshgasman]

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

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

 

[rollingzep]

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

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

How to execute this behind an event or a macro?

 

[rollingzep]

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

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

How and where do I set this code to read from the folder, WeeklyProceedings Mailbox and the attachments inside it?

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

Also, how to set the subject and body to read from the above mailbox?

 

[welshgasman]

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.

 

[rollingzep]

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.