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.