Schedule and Send a Message to People Who Have Sent You a Message


I put this solution together for a reader who goes by the name birdmanjrmd. Birdmanjrmd asked for a script that will

  • Create a new email
  • Process all the messages in a given Outlook folder. For each message
    • Add the sender’s address to the new email’s list of recipients.
    • Move the message out of the source folder to a target folder.
  • Set the new message’s subject and body.
  • Send the message.

Birdmanjrmd wants the script to run once each day, so I wrote it in VBscript. This will allow him to run it from a scheduled task using Windows Task Scheduler.

Instructions.

  1. Open Notepad.
  2. Copy the code below and paste it into Notepad.
  3. Edit the code as needed. I included a comment where changes are needed.
  4. Save the file. You can name it anything you want so long as the file extension is .vbs.
  5. Test the script by double-clicking it.
  6. Open Windows Task Scheduler.
  7. Create a new task.
  8. Set the task to run at whatever interval you choose.
  9. Set the task’s action to run a script and select this script as the one to run.
'On the next line edit the message subject
    Const MSG_SUBJECT = "Test"
    'On the next line edit the message body.  You can use HTML formatting.
    Const MSG_BODY = "TEST 12"
    'On the next line edit the path to the source folder in Outlook
    Const SRC_FOLDER = "davist@qutech.com\Inbox\test"
    'On the next line edit the path to the target folder in Outlook
    Const TGT_FOLDER = "davist@qutech.com\Inbox\test\testc"
    Const olMailItem = 0
    Const olBCC = 3
'--> Declare some variables
    Dim olkApp, olkSes, olkFld, olkFin, olkItm, olkMsg, olkRcp, intPtr
'--> Connect to Outlook
    Set olkApp = CreateObject("Outlook.Application")
    Set olkSes = olkApp.GetNamespace("MAPI")
    olkSes.Logon olkApp.DefaultProfileName
'--> Open the folders
    Set olkFld = OpenOutlookFolder(SRC_FOLDER)
    Set olkFin = OpenOutlookFolder(TGT_FOLDER)
'--> Create a new email
    Set olkMsg = olkApp.CreateItem(olMailItem)
'--> Process the items in the soure folder
    For intPtr = olkFld.Items.Count To 1 Step -1
        Set olkItm = olkFld.Items.Item(intPtr)
        Set olkRcp = olkMsg.Recipients.Add(olkItm.SenderEmailAddress)
        olkRcp.Type = olBCC
        olkItm.Move olkFin
    Next
'--> Finalize and send the email
    With olkMsg
        .Recipients.ResolveAll
        .Subject = MSG_SUBJECT
        .HTMLBody = MSG_BODY
        .Display
    End With
'--> Disconnect from Outlook
    olkSes.Logoff
'--> Destroy all objects
    Set olkMsg = Nothing
    Set olkItm = Nothing
    Set olkFin = Nothing
    Set olkFld = Nothing
    Set olkSes = Nothing
    Set olkApp = Nothing
'--> Terminate the script
    Wscript.Quit

Function OpenOutlookFolder(strFolderPath)
    Dim arrFolders, varFolder, bolBeyondRoot
    On Error Resume Next
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            Select Case bolBeyondRoot
                Case False
                    Set OpenOutlookFolder = olkApp.Session.Folders(varFolder)
                    bolBeyondRoot = True
                Case True
                    Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
            End Select
            If Err.Number  0 Then
                Set OpenOutlookFolder = Nothing
                Exit For
            End If
        Next
    End If
    On Error GoTo 0
End Function
Advertisements

4 comments on “Schedule and Send a Message to People Who Have Sent You a Message

  1. it was not able to work for me. i tried to run it in VBA before i created the task to test it out and i got the error “invalid outside Procedure and it pointed to set olkapp

     'On the next line edit the message subject
        Const MSG_SUBJECT = "Test"
        'On the next line edit the message body.  You can use HTML formatting.
        Const MSG_BODY = "TEST 12"
        'On the next line edit the path to the source folder in Outlook
        Const SRC_FOLDER = "davist@qutech.com\Inbox\test"
        'On the next line edit the path to the target folder in Outlook
        Const TGT_FOLDER = "davist@qutech.com\Inbox\test\testc"
        Const olMailItem = 0
        Const olBCC = 3
    '--> Declare some variables
        Dim olkApp, olkSes, olkFld, olkFin, olkItm, olkMsg, olkRcp, intPtr
    '--> Connect to Outlook
        Set olkApp = CreateObject("Outlook.Application")
        Set olkSes = olkApp.GetNamespace("MAPI")
        olkSes.Logon olkApp.DefaultProfileName
    '--> Open the folders
        Set olkFld = OpenOutlookFolder(SRC_FOLDER)
        Set olkFin = OpenOutlookFolder(TGT_FOLDER)
    '--> Create a new email
        Set olkMsg = olkApp.CreateItem(olMailItem)
    '--> Process the items in the soure folder
        For intPtr = olkFld.Items.Count To 1 Step -1
            Set olkItm = olkFld.Items.Item(intPtr)
            Set olkRcp = olkMsg.Recipients.Add(olkItm.SenderEmailAddress)
            olkRcp.Type = olBCC
            olkItm.Move olkFin
        Next
    '--> Finalize and send the email
        With olkMsg
            .Recipients.ResolveAll
            .Subject = MSG_SUBJECT
            .HTMLBody = MSG_BODY
            .Display
        End With
    '--> Disconnect from Outlook
        olkSes.Logoff
    '--> Destroy all objects
        Set olkMsg = Nothing
        Set olkItm = Nothing
        Set olkFin = Nothing
        Set olkFld = Nothing
        Set olkSes = Nothing
        Set olkApp = Nothing
    '--> Terminate the script
        Wscript.Quit
     
    Function OpenOutlookFolder(strFolderPath)
        Dim arrFolders, varFolder, bolBeyondRoot
        On Error Resume Next
        If strFolderPath = "" Then
            Set OpenOutlookFolder = Nothing
        Else
            Do While Left(strFolderPath, 1) = "\"
                strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
            Loop
            arrFolders = Split(strFolderPath, "\")
            For Each varFolder In arrFolders
                Select Case bolBeyondRoot
                    Case False
                        Set OpenOutlookFolder = olkApp.Session.Folders(varFolder)
                        bolBeyondRoot = True
                    Case True
                        Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
                End Select
                If Err.Number  0 Then
                    Set OpenOutlookFolder = Nothing
                    Exit For
                End If
            Next
        End If
        On Error GoTo 0
    End Function
    

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s