VBA Micro outlook

[Omer]

help please,
how do I move the files from

c:\Reports to c:\Complete

once its been send out successfully.
Help on this is greatly appreciated.

I am using outlook 2010 with win 7

Option Explicit
Sub SendMessage(Optional AttachmentPath)
    Dim eOutlook As Outlook.Application
    Dim eOutlookMsg As Outlook.MailItem
    Dim eOutlookRecip As Outlook.Recipient
    Dim eOutlookAttach As Outlook.Attachment
    Dim eOutlookFile As String
    
    '// Attachment Path
    AttachmentPath = "C:\Reports\"
    
    '// Create the Outlook session.
    Set eOutlook = CreateObject("Outlook.Application")
    
    '// Create the message.
    Set eOutlookMsg = eOutlook.CreateItem(olMailItem)
    
    With eOutlookMsg
        '// Add the To recipient(s) to the message.
        Set eOutlookRecip = .Recipients.Add("Omer")
        Set eOutlookRecip = .Recipients.Add("Omer")
            eOutlookRecip.Type = olTo
    
        '// Add the CC recipient(s) to the message.
        Set eOutlookRecip = .Recipients.Add("Omer")
            eOutlookRecip.Type = olCC
    
        '// Set the Subject, Body, and Importance of the message.
        .Subject = "Project Status"
        .Body = "This is VB email test!" & vbCrLf & vbCrLf
        .Importance = olImportanceHigh  '//High importance
        
        '// Add attachments to the message.
        eOutlookFile = Dir(AttachmentPath & "*.*")
        
        Do While Len(eOutlookFile) > 0
            .Attachments.Add AttachmentPath & eOutlookFile
            eOutlookFile = Dir
        Loop
       
        '// Resolve each Recipient's name.
        For Each eOutlookRecip In .Recipients
            eOutlookRecip.Resolve
            If Not eOutlookRecip.Resolve Then
            eOutlookMsg.Display
        End If
        Next
        '//.DeleteAfterSubmit = True
        '//.Send
        .Display
        
    End With
    Set eOutlookMsg = Nothing
    Set eOutlook = Nothing
End Sub

[gmayor]

It is easy enough to move the files as they are processed. Can we assume that the code is being run from Outlook VBA? In that case you don't need to create an Outlook application, you are already in it. You only need to do that if you are running the code from another Office application, but then there may need to be other modifications to the code below.

You can edit the message body direcvtly and thuse easily retail the default signature:

Sub SendMessage(Optional strAttachmentPath As String, Optional strCompletePath As String)
Dim eOutlook As Outlook.Application
Dim eOutlookMsg As Outlook.MailItem
Dim eOutlookRecip As Outlook.Recipient
Dim eOutlookAttach As Outlook.Attachment
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim strAttachmentFile As String

    '// Attachment Path
    If strAttachmentPath = "" Then strAttachmentPath = "C:\Reports\"
    '// Completed Path
   If strCompletePath = "" Then strAttachmentPath = "C:\Complete\"

    On Error GoTo lbl_Exit
    '// Create the Outlook session - if you are running from Outlook you don't need to create an Outlook
    '// application as you are already in it.
    '// Set eOutlookMsg = eOutlook.CreateItem(olMailItem)
    Set eOutlook = Outlook.Application

    '// Create the message.
    Set eOutlookMsg = eOutlook.CreateItem(olMailItem)

    With eOutlookMsg
        '// Add the To recipient(s) to the message.
        Set eOutlookRecip = .Recipients.Add("Omer")
        Set eOutlookRecip = .Recipients.Add("Omer")
        eOutlookRecip.Type = olTo

        '// Add the CC recipient(s) to the message.
        Set eOutlookRecip = .Recipients.Add("Omer")
        eOutlookRecip.Type = olCC

        '// Set the Subject, Body, and Importance of the message.
        .Subject = "Project Status"
        .Importance = olImportanceHigh        '//High importance
        .BodyFormat = olFormatHTML
        '// Edit the message body
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        '// Set a range at the start of the message body (to retain the signature)
        Set oRng = wdDoc.Range(0, 0)
        '// add the text
        oRng.Text = "This is VB email test!" & vbCrLf & vbCrLf


        '// Add attachments to the message.
        strAttachmentFile = Dir(strAttachmentPath & "*.*")

        Do While Len(strAttachmentFile) > 0
            .Attachments.Add strAttachmentPath & strAttachmentFile
            '// Move the file.
            Name strAttachmentPath & strAttachmentFile As strCompletePath & strAttachmentFile
            strAttachmentFile = Dir
        Loop

        '// Resolve each Recipient's name.
        For Each eOutlookRecip In .Recipients
            eOutlookRecip.Resolve
            If Not eOutlookRecip.Resolve Then
                eOutlookMsg.Display
            End If
        Next
        .Display        '//This line must be retained
        '//.DeleteAfterSubmit = True
        '//.Send '//This line optional

    End With
lbl_Exit:
    Set eOutlookMsg = Nothing
    Set eOutlook = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

[Omer]

Graham, thanks for taking the time to help me on this vba macro.
I am running this macro from outlook 2010 vba Module1, after making the changes you posted here, for some reason the macro is not running or doing anything if I hit F5 or run sub

[gmayor]

The macro has an error trap to end the macro if there is a problem. If you comment out the line

On Error GoTo lbl_Exit

it will stop at the error. My guess is that the attachment size exceeds the limits.

Call the macro from a sub that contains the names of two folders that exist with the first containing a small number of small files:

Sub TestCode()
SendMessage "c:\Path\Forms\", "c:\Path\Test\"
End Sub

[Omer]

Hello Graham sorry for the late reply,
after playing around with macro I go it working, here is the changes I made

Sub SendMessage()
    Dim eOutlook As Outlook.Application
    Dim eOutlookMsg As Outlook.MailItem
    Dim eOutlookRecip As Outlook.Recipient
    Dim eOutlookAttach As Outlook.Attachment
    Dim strAttachmentPath As String
    Dim strCompletePath As String
    Dim olInsp As Outlook.Inspector
    Dim wdDoc As Object
    Dim oRng As Object
    Dim strAttachmentFile As String

and

'// Completed Path
    If strCompletePath = "" Then strCompletePath = "C:\Complete\"

about the error trap, can we use that to stop outgoing email if there is no files to send or in

"C:\Reports\"

Thanks for you time again..

[Omer]

opss I ran into one more error just now, error '58' file already exists.
If the files I am sending out already exists "C:\Complete\" then macro stops working, can it be overwritten? can you show me how to do that, Thanks again..

[gmayor]

You can use the function below to check if the file exists before proceeding

i.e.

IF Not FileExists(strCompletePath & strAttachmentFile) then
    Name strAttachmentPath & strAttachmentFile As strCompletePath & strAttachmentFile
End If

Public Function FileExists(filespec) As Boolean
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function

You changes also show why the other code didn't work.

The macro was written to pass parameters to it i.e.

Sub SendMessage(Optional strAttachmentPath As String, Optional strCompletePath As String)

Even though the parameters are optional, you still have to call it from another process. Your second version eliminates those parameters so can be run directly, but you should change the lines

'// Attachment Path
    If strAttachmentPath = "" Then strAttachmentPath = "C:\Reports\"
    '// Completed Path
   If strCompletePath = "" Then strAttachmentPath = "C:\Complete\"

to

strAttachmentPath = "C:\Reports\"
strCompletePath = "C:\Complete\"

as there is no need for the error trap

[Omer]

hey graham, I am getting (error 75 path/file access error ) do know why is that??
here is the complete macro..

Option Explicit
'(11)
Public Function FileExists(filespec) As Boolean
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function

'(1)
Sub SendMessage()
    Dim eOutlook As Outlook.Application
    Dim eOutlookMsg As Outlook.MailItem
    Dim eOutlookRecip As Outlook.Recipient
    Dim eOutlookAttach As Outlook.Attachment
    Dim strAttachmentPath As String
    Dim strCompletePath As String
    Dim olInsp As Outlook.Inspector
    Dim wdDoc As Object
    Dim oRng As Object
    Dim strAttachmentFile As String


    '// Attachment Path. (2)
    strAttachmentPath = "C:\Reports\"
    '// Completed Path. (3)
    strCompletePath = "C:\Complete\"


'On Error GoTo lbl_Exit
    '// Set Outlook. (4)
    Set eOutlook = Outlook.Application


    '// Create the message. (5)
    Set eOutlookMsg = eOutlook.CreateItem(olMailItem)
    With eOutlookMsg
        '// Add the To recipient(s) to the message.
        Set eOutlookRecip = .Recipients.Add("Omer")
        Set eOutlookRecip = .Recipients.Add("Omer")
            eOutlookRecip.Type = olTo
        '// Add the CC recipient(s) to the message.(6)
        Set eOutlookRecip = .Recipients.Add("Omer")
            eOutlookRecip.Type = olCC

        
        '// Set the Subject, Body, and Importance of the message.(7)
        .Subject = "Reports" & Now
        .Importance = olImportanceHigh '// High importance
        .BodyFormat = olFormatHTML

        
        '// Edit the message body. (8)
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        '// Set a range at the start of the message body (to retain the signature)
        Set oRng = wdDoc.Range(0, 0)
        '// add the text
        oRng.Text = "See Attach files for complete reports:" & vbCrLf & vbCrLf

        '// Check if the file exists before proceeding (10)
        If Not FileExists(strCompletePath & strAttachmentFile) Then
            Name strAttachmentPath & strAttachmentFile As strCompletePath & strAttachmentFile
        End If

        
        '// Add attachments to the message.(9)
        strAttachmentFile = Dir(strAttachmentPath & "*.*")

        
        Do While Len(strAttachmentFile) > 0
            .Attachments.Add strAttachmentPath & strAttachmentFile
            '// Move the file.
            Name strAttachmentPath & strAttachmentFile As strCompletePath & strAttachmentFile
            strAttachmentFile = Dir
        Loop

        
        '// Resolve each Recipient's name.
        For Each eOutlookRecip In .Recipients
                eOutlookRecip.Resolve
            If Not eOutlookRecip.Resolve Then
                eOutlookMsg.Display
            End If
        Next
        .Display        '//This line must be retained
        '.DeleteAfterSubmit = True
        '.Send '//This line optional
    End With
lbl_Exit:
    Set eOutlookMsg = Nothing
    Set eOutlook = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

[gmayor]

You have the check in the wrong place

 '// Edit the message body. (8)
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        '// Set a range at the start of the message body (to retain the signature)
        Set oRng = wdDoc.Range(0, 0)
        '// add the text
        oRng.Text = "See Attach files for complete reports:" & vbCrLf & vbCrLf


        '// Add attachments to the message.(9)
        strAttachmentFile = Dir(strAttachmentPath & "*.*")

        Do While Len(strAttachmentFile) > 0
            .Attachments.Add strAttachmentPath & strAttachmentFile
            '// Move the file.
            '// Check if the file exists before proceeding (10)
            If Not FileExists(strCompletePath & strAttachmentFile) Then
                Name strAttachmentPath & strAttachmentFile As strCompletePath & strAttachmentFile
            End If
            strAttachmentFile = Dir
        Loop

[Omer]

okay the error is gone now - thank you, but it is still sending the email out if the file don't exists at "C:\Reports\"
I have noticed when I run the macro step by step into (F8) it skips the following code

            .Attachments.Add strAttachmentPath & strAttachmentFile
            '// Check if the file exists before proceeding
            If Not FileExists(strCompletePath & strAttachmentFile) Then
                '// Move the file.
                Name strAttachmentPath & strAttachmentFile As strCompletePath & strAttachmentFile
            End If
            strAttachmentFile = Dir
        Loop

and then goes to the following code

'// Resolve each Recipient's name.
        For Each eOutlookRecip In .Recipients
                eOutlookRecip.Resolve
            If Not eOutlookRecip.Resolve Then
                eOutlookMsg.Display
            End If
        Next
        .Display        '//This line must be retained

by the way very interesting website you have there.....

[gmayor]

Include whatever you want to happen inside the loop, everything outside the loop is processed.

[Omer]

its also skipping the following code

Public Function FileExists(filespec) As Boolean
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(filespec) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function

but If I have files in "C:\Reports\" then the macro runs all the codes , could it be the following line of code?

Do While Len(strAttachmentFile) > 0

I would like it to stop processing if there is no file to send.

[gmayor]

OK the following should do that. I have added in a function to ensure that if the target file name does exist, it is not overwrittenInstead a number is appended to the name. If there is no file to send it reports that and closes the message.

Option Explicit

'(1)
Sub SendMessage()
Dim eOutlook As Outlook.Application
Dim eOutlookMsg As Outlook.MailItem
Dim eOutlookRecip As Outlook.Recipient
Dim eOutlookAttach As Outlook.Attachment
Dim strAttachmentPath As String
Dim strCompletePath As String
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim strAttachmentFile As String
Dim strExtension As String
Dim strNewName As String
Dim strOldName As String

    '// Attachment Path. (2)
    strAttachmentPath = "C:\Reports\"
    '// Completed Path. (3)
    strCompletePath = "C:\Complete\"


    'On Error GoTo lbl_Exit
    '// Set Outlook. (4)
    Set eOutlook = Outlook.Application

    '// Create the message. (5)
    Set eOutlookMsg = eOutlook.CreateItem(olMailItem)
    With eOutlookMsg
        .Display        '//This line must be retained
        strAttachmentFile = Dir(strAttachmentPath & "*.*")
        Do While Len(strAttachmentFile) > 0
            .Attachments.Add strAttachmentPath & strAttachmentFile
            strExtension = Right(strAttachmentFile, _
                                 Len(strAttachmentFile) - InStrRev(strAttachmentFile, Chr(46)))
            '// Check if the file exists and save with unique name (10)
            strOldName = strAttachmentFile
            strNewName = FileNameUnique(strCompletePath, strAttachmentFile, strExtension)
            Name strAttachmentPath & strOldName As strCompletePath & strNewName

            strAttachmentFile = Dir
        Loop
        If .Attachments.Count = 0 Then
            MsgBox "There are no reports to attach.", vbInformation
            .Close 0
        Else
            '// Add the To recipient(s) to the message.
            Set eOutlookRecip = .Recipients.Add("Omer")
            Set eOutlookRecip = .Recipients.Add("Omer")
            eOutlookRecip.Type = olTo

            '// Add the CC recipient(s) to the message.(6)
            Set eOutlookRecip = .Recipients.Add("Omer")
            eOutlookRecip.Type = olCC


            '// Set the Subject, Body, and Importance of the message.(7)
            .Subject = "Reports - " & Format(Now, "Long Date")
            .Importance = olImportanceHigh        '// High importance
            .BodyFormat = olFormatHTML


            '// Edit the message body. (8)
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            '// Set a range at the start of the message body (to retain the signature)
            Set oRng = wdDoc.Range(0, 0)
            '// add the text
            oRng.Text = "See attached files for complete reports."

            '// Resolve each Recipient's name.
            For Each eOutlookRecip In .Recipients
                eOutlookRecip.Resolve
                If Not eOutlookRecip.Resolve Then
                    eOutlookMsg.Display
                End If
            Next
            '.DeleteAfterSubmit = True
            '.Send '//This line optional
        End If
    End With
lbl_Exit:
    Set eOutlookMsg = Nothing
    Set eOutlook = Nothing
    Set olInsp = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

'(11)
Private Function FileExists(strFullName As String) As Boolean
Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(strFullName) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Exit Function
End Function

Private Function FileNameUnique(strPath As String, _
                               strFilename As String, _
                               strExtension As String) As String
Dim lngF As Long
Dim lngName As Long
    lngF = 1
    lngName = Len(strFilename) - (Len(strExtension) + 1)
    strFilename = Left(strFilename, lngName)
    Do While FileExists(strPath & strFilename & Chr(46) & strExtension) = True
        strFilename = Left(strFilename, lngName) & "(" & lngF & ")"
        lngF = lngF + 1
    Loop
    FileNameUnique = strFilename & Chr(46) & strExtension
lbl_Exit:
    Exit Function
End Function

[Omer]

Thank you very much for your time Graham, I have not tested your code yet but as soon as get home tomorrow I will let you know.

[Omer]

Perfect it worked thank you very much.