Outlook VBA Issue fix

I have some vba to save sent emails from outlook.

All works well but the .msg file is saved before it is sent so if we open the .msg it does not show the sent time and date.

If I add a button and save a highlighted email it works ok.

I need someone to give me the VBA code to send the email and then save it. Need it to trigger on clicking the button to send in outlook.

I tried adding item.send before saving but it will not allow this. All the VBA on application.itemsend works well but saves too early. The ideal thing would be to have an application.itemsent so it happens after the mailitem has been sent but I cannot see this trigger.

If you can fix this please let me know and put **FixMyVBA** at the front of your bid so I know you have read and understood this task.


--Current code--
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim wsh As Object
Set wsh = VBA.CreateObject("WScript.Shell")
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
Dim oAttachments As Outlook.Attachments

sName = "email.msg"
hName = "email.mhtml"
sPath = enviro & "c:\compliance\"
sSaveFolder = "C:\compliance\attachments\"

If Item.MessageClass = "IPM.Note" Then

For Each oAttachment In Item.Attachments


Location = InStr(1, oAttachment.FileName, "image", 0)
If Location = 0 Then
oAttachment.SaveAsFile sSaveFolder & oAttachment.FileName
End If

Next
End If


Item.SaveAs sPath & sName, olMSG
Item.SaveAs sPath & hName, olMHTML
Item.Save


If Item.Subject <> "Email to Approve and Send" Then

If TypeName(Item) = "MailItem" Then
ErrorCode = wsh.Run("Z:\compliance\OulookVisualtime\Debug\Win32\outlookvisualtime.exe """ + Item.Subject + """ " + Item.To, windowStyle, waitOnReturn)

If ErrorCode = 99 Then

Dim strFilename As String:
strFilename = "C:\compliance\emailmatter.txt"

Dim strTextLine As String
Dim iFile As Integer: iFile = FreeFile
Open strFilename For Input As #iFile
Line Input #1, strTextLine
Close #iFile
Dim pos As Integer
pos = InStr(Item.Subject, "DM Ref:")


If pos = 0 And strTextLine <> "" Then
Item.Subject = Item.Subject + " - [DM Ref: " + strTextLine + "]"
End If




Else
MsgBox "Time Recording / Document Management exited with error code " & ErrorCode & ". Your email has not been sent. Try again."
Cancel = True

End If
End If
End If


End Sub