Consulting

Page 2 of 3 FirstFirst 1 2 3 LastLast
Results 21 to 40 of 41

Thread: Macro to send out email based on criteria via outlook

  1. #21
    Sorry - my error . It should be
    oRng.Text = "Notification of email arrival" & vbCr & vbCr & _
                                                "Sender: " & olMail.Sender & vbCr & _
                                                "Subject: " & olMail.Subject & vbCr & _
                                                "Attachment: " & oAtt.FileName
    which replaces

    oRng.Text = "Notification of email arrival"
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  2. #22
    VBAX Regular
    Joined
    Apr 2015
    Posts
    18
    Location
    Thank you so much, i REALLY appreciate all of the effort you have put into this, it is perfect

  3. #23
    VBAX Regular
    Joined
    Apr 2015
    Posts
    18
    Location
    Sorry to be a pain but if possible there are a couple of minor things that I may need adding.

    My situation - I monitor a variety of mailbox accounts.

    Therefore if possible i need the following additions:

    Need to be able to specify the email address the message is to be sent from in the code (This would be the same for each message) - The address needs to be

    I also need to be able to specify a specific email signature to use (This would be the same for each message) - e.g. This message is brought to you courtesy of Matt

    Thank you once again in advance for your kind assistance.
    Last edited by MD011; 05-19-2015 at 02:50 AM.

  4. #24
    Assuming these are not Exchange accounts then use the following. I have repeated all the required code. Put the sending address in place of someone@somewhere.com (and edit it out of your earlier message or Matt Williams will be inundated with junk mail). The code will use the default signature associated with that account, so create the signature in Outlook and associate it with the account.

    Note it will now only work if there is an account called by the name in the strAcc constant. If not, no message will be created.

    Option Explicit
    Const strWorkbook As String = "C:\Path\Excel forum.xlsx" 'The path of the workbook
    Const strSheet As String = "Sheet1" 'The name of the worksheet
    Const strAcc As String = "someone@somewhere.com" 'The sending account
     
    Sub TestMsg()
        Dim olMsg As MailItem
        On Error Resume Next
        Set olMsg = ActiveExplorer.Selection.Item(1)
        AutoReply olMsg
    lbl_Exit:
        Exit Sub
    End Sub
    
    Sub AutoReply(olMail As Outlook.MailItem)
    Dim olReply As Outlook.MailItem
    Dim olInsp As Outlook.Inspector
    Dim oAccount As Outlook.Account
    Dim wdDoc As Object
    Dim oRng As Object
    Dim Arr() As Variant
    Dim iCols As Long
    Dim iRows As Long
    Dim strName As String
    Dim oAtt As Attachment
        'load the worksheet into an array
        Arr = xlFillArray(strWorkbook, strSheet)
        With olMail
            For iRows = 0 To UBound(Arr, 2)        'Check each row of the array
                'If column 2 (starting at column 0) contains the e-mail address of the message
                If .SenderEmailAddress = Arr(2, iRows) Then
                    'If the subject value is in the message subject
                    If InStr(1, .Subject, Arr(1, iRows)) > 0 Then
                        'process the attachments to the message
                        For Each oAtt In .Attachments
                            'If any attachment filename has the text in column 0
                            If InStr(1, oAtt.FileName, Arr(0, iRows)) > 0 Then
                                For Each oAccount In Session.Accounts
                                    If oAccount.DisplayName = strAcc Then
                                        'Create a message
                                        Set olReply = CreateItem(olMailItem)
                                        With olReply
                                            .Subject = Arr(1, iRows)
                                            .To = Arr(3, iRows)
                                            .SendUsingAccount = oAccount
                                            .BodyFormat = olFormatHTML
                                            .Display
                                            Set olInsp = .GetInspector
                                            Set wdDoc = olInsp.WordEditor
                                            Set oRng = wdDoc.Range(0, 0)
                                            oRng.Text = "Notification of email arrival" & vbCr & vbCr & _
                                                        "Sender: " & olMail.Sender & vbCr & _
                                                        "Subject: " & olMail.Subject & vbCr & _
                                                        "Attachment: " & oAtt.FileName
                                            '.sEnd 'Restore after testing
                                        End With
                                    End If
                                Next oAccount
                                Exit For
                            End If
                        Next oAtt
                    End If
                End If
            Next iRows
        End With
    lbl_Exit:
        Set olReply = Nothing
        Set olInsp = Nothing
        Set wdDoc = Nothing
        Set oRng = Nothing
        Exit Sub
    End Sub
     
    Private Function xlFillArray(strWorkbook As String, _
        strWorksheetName As String) As Variant
        Dim RS As Object
        Dim CN As Object
        Dim iRows As Long
         
        strWorksheetName = strWorksheetName & "$]"
        Set CN = CreateObject("ADODB.Connection")
        CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & strWorkbook & ";" & _
        "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
         
        Set RS = CreateObject("ADODB.Recordset")
        RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1
         
        With RS
            .MoveLast
            iRows = .RecordCount
            .MoveFirst
        End With
        xlFillArray = RS.GetRows(iRows)
        If RS.State = 1 Then RS.Close
        Set RS = Nothing
        If CN.State = 1 Then CN.Close
        Set CN = Nothing
    lbl_Exit:
        Exit Function
    End Function
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #25
    VBAX Regular
    Joined
    Apr 2015
    Posts
    18
    Location
    Thanks very much again however there is a slight issue.

    Firstly I have managed to specify which mailbox the message gets sent from by simply using ".SentOnBehalfOfName = (email address here)".

    The problem I am having is getting the email to include one of the signatures that I have setup.

    My situation is, i monitor a variety of mailboxes through one mail account if that makes sense? And i need one of the signatures to be assigned to one of these mailboxes which has a specific address.

  6. #26
    Did you try the code as posted?
    Did you associate the signature with the account?
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  7. #27
    VBAX Regular
    Joined
    Apr 2015
    Posts
    18
    Location
    Thanks very much the only remaining problem now is that for some reason the messages are getting stuck in the outbox....I can send them normally but when using the macro they get stuck!

    FYI - These are Microsoft Exchange Accounts
    Last edited by MD011; 05-19-2015 at 04:24 AM.

  8. #28
    The following macro should clear the Outbox

    Sub SendAndReceiveAll()
    Dim olNS As NameSpace
    Dim olSyncs As SyncObjects
    Dim olSync As SyncObject
    Dim olItems As Items
    Dim olItem As MailItem
    Dim i As Long
    
        Set olNS = Application.GetNamespace("MAPI")
        Set olSyncs = olNS.SyncObjects
        Set olItems = olNS.GetDefaultFolder(4).Items
        For i = olItems.Count To 1 Step -1
            Set olItem = olItems(i)
            olItem.sEnd
            DoEvents
        Next i
        For i = 1 To olSyncs.Count
            Set olSync = olSyncs.Item(i)
            olSync.Start
            DoEvents
        Next
    CleanUp:
        Set olItems = Nothing
        Set olItem = Nothing
        Set olNS = Nothing
        Set olSyncs = Nothing
        Set olSync = Nothing
    lbl_Exit:
        Exit Sub
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  9. #29
    VBAX Regular
    Joined
    Apr 2015
    Posts
    18
    Location
    Still stuck in my outbox unfortunately . The email signature isnt a HUGE issue, i could use my default one that works okay, however ideally it woould be this custom one. Is there a some code that my be stopping it being sent?

  10. #30
    You can lose the signature if you change

    Set oRng = wdDoc.Range(0, 0)
    to
    Set oRng = wdDoc.Range
    Then include the required signature in the text written to oRng

    As for the blockage in the outbox. I have no idea why that is happening, but it is probably something to do with Exchange Server. As this is Exchange server you should be able to lose the lines
    For Each oAccount In Session.Accounts 
           If oAccount.DisplayName = strAcc Then
    and the corresponding
    EndIf
    Next oAccount
    as you are using
    .SentOnBehalfOfName = (email address here)


    Thus
    Sub AutoReply(olMail As Outlook.MailItem)
    Dim olReply As Outlook.MailItem
    Dim olInsp As Outlook.Inspector
    Dim wdDoc As Object
    Dim oRng As Object
    Dim Arr() As Variant
    Dim iCols As Long
    Dim iRows As Long
    Dim strName As String
    Dim oAtt As Attachment
        'load the worksheet into an array
        Arr = xlFillArray(strWorkbook, strSheet)
        With olMail
            For iRows = 0 To UBound(Arr, 2)        'Check each row of the array
                'If column 2 (starting at column 0) contains the e-mail address of the message
                If .SenderEmailAddress = Arr(2, iRows) Then
                    'If the subject value is in the message subject
                    If InStr(1, .Subject, Arr(1, iRows)) > 0 Then
                        'process the attachments to the message
                        For Each oAtt In .Attachments
                            'If any attachment filename has the text in column 0
                            If InStr(1, oAtt.FileName, Arr(0, iRows)) > 0 Then
                                'Create a message
                                Set olReply = CreateItem(olMailItem)
                                With olReply
                                    .Subject = Arr(1, iRows)
                                    .To = Arr(3, iRows)
                                    .SentOnBehalfOfName = "someone@somewhere.com"
                                    .BodyFormat = olFormatHTML
                                    .Display
                                    Set olInsp = .GetInspector
                                    Set wdDoc = olInsp.WordEditor
                                    Set oRng = wdDoc.Range
                                    oRng.Text = "Notification of email arrival" & vbCr & vbCr & _
                                                "Sender: " & olMail.Sender & vbCr & _
                                                "Subject: " & olMail.Subject & vbCr & _
                                                "Attachment: " & oAtt.FileName & vbCr & vbCr & _
                                                "This message is brought to you courtesy of Matt"
                                    '.sEnd 'Restore after testing
                                End With
                                Exit For
                            End If
                        Next oAtt
                    End If
                End If
            Next iRows
        End With
    lbl_Exit:
        Set olReply = Nothing
        Set olInsp = Nothing
        Set wdDoc = Nothing
        Set oRng = Nothing
        Exit Sub
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  11. #31
    VBAX Regular
    Joined
    Apr 2015
    Posts
    18
    Location
    Ok that seems perfect, thank you so much, it is REALLY appreciated

  12. #32
    VBAX Regular
    Joined
    Oct 2016
    Posts
    6
    Location
    Quote Originally Posted by gmayor View Post
    What you ask is reasonably straightforward given the type of workbook you envisage. The macro is probably best run as a script from a rule to check the messages as they arrive, but you can run the TestMsg macro to both test and process individual messages. Change the path and worksheet name as appropriate. Select a message and run TestMsg.
    The macro reads the named worksheet into an array. This is very fast in practice, as is the search. The values are then compared with the subject, sender and attachment. Anything that meets the criteria results in a raised message.

    Option Explicit
    Const strWorkbook As String = "C:\Path\Excel forum.xlsx"        'The path of the workbook
    Const strSheet As String = "Sheet1"        'The name of the worksheet
    
    Sub TestMsg()
    Dim olMsg As MailItem
        On Error Resume Next
        Set olMsg = ActiveExplorer.Selection.Item(1)
        AutoReply olMsg
    lbl_Exit:
        Exit Sub
    End Sub
    
    Sub AutoReply(olMail As Outlook.MailItem)
    Dim olReply As Outlook.MailItem
    Dim olInsp As Outlook.Inspector
    Dim wdDoc As Object
    Dim oRng As Object
    Dim Arr() As Variant
    Dim iCols As Long
    Dim iRows As Long
    Dim strName As String
    Dim oAtt As Attachment
        'load the worksheet into an array
        Arr = xlFillArray(strWorkbook, strSheet)
        With olMail
            For iRows = 0 To UBound(Arr, 2)        'Check each row of the array
                'If column 2 (starting at column 0) contains the e-mail address of the message
                If .SenderEmailAddress = Arr(2, iRows) Then
                    'If the subject value is in the message subject
                    If InStr(1, .Subject, Arr(1, iRows)) > 0 Then
                        'process the attachments to the message
                        For Each oAtt In .Attachments
                            'If any attachment filename has the text in column 0
                            If InStr(1, oAtt.Filename, Arr(0, iRows)) > 0 Then
                                'Create a message
                                Set olReply = CreateItem(olMailItem)
                                With olReply
                                    .Subject = Arr(1, iRows)
                                    .To = Arr(3, iRows)
                                    .BodyFormat = olFormatHTML
                                    .Display
                                    Set olInsp = .GetInspector
                                    Set wdDoc = olInsp.WordEditor
                                    Set oRng = wdDoc.Range(0, 0)
                                    oRng.Text = "Notification of email arrival"
                                    '.sEnd 'Restore after testing
                                End With
                                Exit For
                            End If
                        Next oAtt
                    End If
                End If
            Next iRows
        End With
    lbl_Exit:
        Set olReply = Nothing
        Set olInsp = Nothing
        Set wdDoc = Nothing
        Set oRng = Nothing
        Exit Sub
    End Sub
    
    Private Function xlFillArray(strWorkbook As String, _
                                 strWorksheetName As String) As Variant
    Dim RS As Object
    Dim CN As Object
    Dim iRows As Long
    
        strWorksheetName = strWorksheetName & "$]"
        Set CN = CreateObject("ADODB.Connection")
        CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                                  "Data Source=" & strWorkbook & ";" & _
                                  "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
    
        Set RS = CreateObject("ADODB.Recordset")
        RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1
    
        With RS
            .MoveLast
            iRows = .RecordCount
            .MoveFirst
        End With
        xlFillArray = RS.GetRows(iRows)
        If RS.State = 1 Then RS.Close
        Set RS = Nothing
        If CN.State = 1 Then CN.Close
        Set CN = Nothing
    lbl_Exit:
        Exit Function
    End Function
    Hi Graham,

    This code looks like it could be adaptable to be used in a project I'm working on.

    I can normally pull together and manipulate VB code in excel to get the result I want however when looking for Outlook code, the structure and how to form the commands I'm finding it difficult to grasp.

    Effectively what I'm trying to do is export a list of e-mails into excel with sender, subject & time received (which includes the date). That part I've done and it works.

    Then I will be comparing the matching up the data with another source of info that relates to the e-mails and in a fourth column a conclusion of what's to be done with the e-mail.

    Before I go to the effort of the last bit I wanted to make sure there was a way to feed the conclusion back to outlook then either mark the e-mails as read and move them into a folder or set a flag to the e-mail.

    I'm confident it's possible but I'm struggling to find enough info to put it together.

    Any help would be greatly appreciated.

    Cheers

    John

  13. #33
    You will have to clarify - "I wanted to make sure there was a way to feed the conclusion back to outlook"

    The incoming message here is olMail - Sub AutoReply(olMail As Outlook.MailItem).
    Once you have control of the message, you can do what you want with it.
    You can set it as read i.e. at the end of the With olMail section

    .UnRead = False

    or you can categorize it

    .categories = "Processed"

    or you can move it to an existing folder here a sub folder of inbox

    .Move Session.GetDefaultFolder(olFolderInbox).folders("foldername")

    or any combination of the threee.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  14. #34
    VBAX Regular
    Joined
    Oct 2016
    Posts
    6
    Location

    Thumbs up

    Quote Originally Posted by gmayor View Post
    You will have to clarify - "I wanted to make sure there was a way to feed the conclusion back to outlook"

    The incoming message here is olMail - Sub AutoReply(olMail As Outlook.MailItem).
    Once you have control of the message, you can do what you want with it.
    You can set it as read i.e. at the end of the With olMail section

    .UnRead = False

    or you can categorize it

    .categories = "Processed"

    or you can move it to an existing folder here a sub folder of inbox

    .Move Session.GetDefaultFolder(olFolderInbox).folders("foldername")

    or any combination of the threee.
    Great, thanks. I'd always rather learn than just copy and paste, I'd come across .unread = True/False but wasn't sure of the context to use it in.

    As mentioned I wanted to match the e-mails in outlook to the extracted data in excel then depending on the string in column 4 (of a set of 3 or 4) take the appropriate action above.

    I understand roughly what this section of the code does(matches e-mails against the array before taking any action),I'll need to include another match against the received time, which parameters would I need to change in order for it to work from this 'If InStr(1, oAtt.Filename, Arr(0, iRows)) > 0 Then ', (if I repeat this to match with each of the different 'conclusion', which in effect will just be a text string)

    What I'm not sure of is at which point I call .Unread = False or any other action in order for it to work but still go through the 'For Each' Loop'.

    With olMail 
            For iRows = 0 To UBound(Arr, 2) 'Check each row of the array
                 'If column 2 (starting at column 0) contains the e-mail address of the message
                If .SenderEmailAddress = Arr(2, iRows) Then 
                     'If the subject value is in the message subject
                    If InStr(1, .Subject, Arr(1, iRows)) > 0 Then 
                         'process the attachments to the message
                        For Each oAtt In .Attachments 
                             'If any attachment filename has the text in column 0
                            If InStr(1, oAtt.Filename, Arr(0, iRows)) > 0 Then

    Thanks again

    John

  15. #35
    You can issue the instruction at any time before End With closes the book on oMail. I guess before End If when the condition you are looking for is met
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  16. #36
    VBAX Regular
    Joined
    Oct 2016
    Posts
    6
    Location
    Great OK,

    So, I've had a look at it and come back with this, will this work?

    Option ExplicitConst strWorkbook As String = "path" 'The path of the workbook
    Const strSheet As String = "Sheet1" 'The name of the worksheet
    Sub TestMsg()
        Dim olMsg As MailItem
        On Error Resume Next
        Set olMsg = ActiveExplorer.Selection.Item(1)
        AutoReply olMsg
    lbl_Exit:
        Exit Sub
    End Sub
     
    Sub AutoReply(olMail As Outlook.MailItem)
        Dim olReply As Outlook.MailItem
        Dim olInsp As Outlook.Inspector
        Dim wdDoc As Object
        Dim oRng As Object
        Dim Arr() As Variant
        Dim iCols As Long
        Dim iRows As Long
        Dim strName As String
         'load the worksheet into an array
        Arr = xlFillArray(strWorkbook, strSheet)
        With olMail
            For iRows = 0 To UBound(Arr, 2) 'Check each row of the array
                 'If column 2 (starting at column 0) contains the e-mail address of the message
                If .SenderEmailAddress = Arr(2, iRows) Then
                     'If the subject value is in the message subject
                    If InStr(1, .Subject, Arr(1, iRows)) > 0 Then
                         If InStr(1, .ReceivedTime, Arr(1, iRows)) > 0 Then
                         'If the received time is in the message subject
                            If InStr(1, "Yes", Arr(1, iRows)) > 0 Then
                            'If The string above matches then mark the email as unread and move to 'Closed' folder
                                .UnRead = False
                                .Move
                                Session.Folders ("Closed")
                                Exit For
                            End If
                        Next oAtt
                        End If
                    End If
                End If
            Next iRows
        End With
    lbl_Exit:
        Set olReply = Nothing
        Set olInsp = Nothing
        Set wdDoc = Nothing
        Set oRng = Nothing
        Exit Sub
    End Sub
     
    Private Function xlFillArray(strWorkbook As String, _
        strWorksheetName As String) As Variant
        Dim RS As Object
        Dim CN As Object
        Dim iRows As Long
         
        strWorksheetName = strWorksheetName & "$]"
        Set CN = CreateObject("ADODB.Connection")
        CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & strWorkbook & ";" & _
        "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
         
        Set RS = CreateObject("ADODB.Recordset")
        RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1
         
        With RS
            .MoveLast
            iRows = .RecordCount
            .MoveFirst
        End With
        xlFillArray = RS.GetRows(iRows)
        If RS.State = 1 Then RS.Close
        Set RS = Nothing
        If CN.State = 1 Then CN.Close
        Set CN = Nothing
    lbl_Exit:
        Exit Function
    End Function
    If not where am I going wrong?

    I think if anything I'm not entirely sure what the below is pointing at (specifically the number parameters)
     If InStr(1, .ReceivedTime, Arr(1, iRows))
    Thanks again

    John

  17. #37
    In short, it won't work, but it might if you fix a few obvious errors

    Option ExplicitConst strWorkbook As String = "path" 'The path of the workbook
    should be on two lines
    Option Explicit
    Const strWorkbook As String = "path" 'The path of the workbook
    .Move 
    Session.Folders ("Closed")
    should be
    .Move Session.Folders ("Closed")
    Next oAtt
    is an orphan command from a loop that no longer appears in the code and should be removed
    'Arr' is a multidimensional array that is essentially a copy of your worksheet. The two numbered parameters in the brackets are column number and row number however the numbers start at 0 and not 1 as they are in the sheet.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  18. #38
    VBAX Regular
    Joined
    Oct 2016
    Posts
    6
    Location
    Thanks, everything so far has been really helpful!

    I've been using 'Step Into' and messages to troubleshoot my way to this point .

    So far everything works apart from

    .Move Session.Folders("No Response")
    So far this is how it looks:
    Option ExplicitConst strWorkbook As String = "C:\Users\John\Desktop\OE.xlsx" 'The path of the workbook
    Const strSheet As String = "Sheet1" 'The name of the worksheet
    Sub MailFilter()
        Dim olMsg As MailItem
        On Error Resume Next
        Set olMsg = ActiveExplorer.Selection.Item(1)
        MoveToFolder olMsg
    lbl_Exit:
        Exit Sub
    End Sub
     
    Sub MoveToFolder(olMail As Outlook.MailItem)
        Dim olReply As Outlook.MailItem
        Dim olInsp As Outlook.Inspector
        Dim wdDoc As Object
        Dim oRng As Object
        Dim Arr() As Variant
        Dim iCols As Long
        Dim iRows As Long
        Dim strName As String
         'load the worksheet into an array
        Arr = xlFillArray(strWorkbook, strSheet)
        With olMail
            For iRows = 0 To UBound(Arr, 2) 'Check each row of the array
                 'If column 2 (starting at column 0) contains the e-mail address of the message
                If .SenderName = Arr(0, iRows) Then
                     'If the subject value is in the message subject
                    If InStr(1, .Subject, Arr(1, iRows)) > 0 Then
                         If InStr(1, .ReceivedTime, Arr(2, iRows)) > 0 Then
                         'If the received time is in the message subject
                            If InStr(1, "Yes", Arr(3, iRows)) > 0 Then
                            'If The string above matches then mark the email as unread and move to 'No Response' folder
                                MsgBox "Match Found", vbOKOnly, "Match"
                                .UnRead = False
                                .Move Session.Folders("No Response")
                                Exit For
                            End If
                        End If
                    End If
                End If
            Next iRows
        End With
    lbl_Exit:
        Set olReply = Nothing
        Set olInsp = Nothing
        Set wdDoc = Nothing
        Set oRng = Nothing
        Exit Sub
    End Sub
     
    Private Function xlFillArray(strWorkbook As String, _
        strWorksheetName As String) As Variant
        Dim RS As Object
        Dim CN As Object
        Dim iRows As Long
         
        strWorksheetName = strWorksheetName & "$]"
        Set CN = CreateObject("ADODB.Connection")
        CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & strWorkbook & ";" & _
        "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
         
        Set RS = CreateObject("ADODB.Recordset")
        RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1
         
        With RS
            .MoveLast
            iRows = .RecordCount
            .MoveFirst
        End With
        xlFillArray = RS.GetRows(iRows)
        If RS.State = 1 Then RS.Close
        Set RS = Nothing
        If CN.State = 1 Then CN.Close
        Set CN = Nothing
    lbl_Exit:
        Exit Function
    End Function
    I've also come to realised that this only acts on the selected e-mail . How could I adapt this to apply this code to every message in the a selected folder (in my case an inbox)?

    Huge thanks

    John
    Last edited by John87; 11-02-2016 at 09:59 AM.

  19. #39
    The code was intended to run from a rule as the messages arrive, however it is easy enough to process a folder
    Sub ProcessFolder()
    'Graham Mayor - http://www.gmayor.com - 03/11/2016 
    Dim olItem As Object
    Dim olFolder As Folder
        Set olFolder = Session.PickFolder 'select the folder
        For Each olItem In olFolder.Items 'loop through the items
            If TypeName(olItem) = "MailItem" Then
                MoveToFolder olItem 'run the macro
            End If
            Exit For
        Next olItem
        Set olItem = Nothing
    lbl_Exit:
        Exit Sub
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  20. #40
    VBAX Regular
    Joined
    Oct 2016
    Posts
    6
    Location
    That's awesome, I was really hoping that would be possible!

    I've tried a few different permutations of .Move and struggling to grasp the way it works

    No matter how I put it together, I can't seem to get it to work

    How do you get that to Move the olMailItem to a parent folder similar to the below?

      Dim Ns As Outlook.NameSpace
    
    
      Set Ns = Application.GetNamespace("MAPI")
    
    
    Set Items = Ns.GetDefaultFolder(olFolderCalendar).Items
    
    Ns.Move Items
    Thanks again

    John

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •