VB to track approve/reject voting options for purchase order email

[sttombiz]

Any help would be greatly appreciated. Some background, I have a purchase order template which after completion needs to be emailed and approved/rejected by a manager. I have written the code for the email but I am also tracking each purchase order and subsequently would like to know whether the order was approved or rejected in a different file. I have been searching for a starting point for code to export from Outlook but to no avail. Any ideas? Currently, here is my code:

Sub Mail_Sheet_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim MailSub As String
Dim MailSub2 As String
Dim Supplier As String
Dim PONumber As String
Dim ToAddress As String
Dim CCAddress As String
Dim CCAddress2 As String
Dim CCAddress3 As String
Dim SRNumber As String
Dim fname As String
Dim strdata As String
Dim sSource As String
Dim sDestination As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Set rng = Nothing
Set rng = Range("A1:h32")
ToAddress = Range("reqapp")
CCAddress = Range("reqadmin")
CCAddress2 = Range("accounting")
CCAddress3 = CCAddress & "; " & CCAddress2
Supplier = Range("Supplier")
PONumber = Range("ponumber")
SRNumber = Range("srnumber")
MailSub2 = "New " & Supplier & " Purchase Order Raised: " & PONumber & " SR: #" & SRNumber
todaydate = Format(Date, "d-mmm-yy")
nowtime = Format(Time, "hhmm")
fname = "PO#" & PONumber & "_-" & todaydate & "_" & nowtime & "(" & Supplier & ")"


'Generate PDF document to c:\
strdata = "C:\Documents\" & fname & ".pdf"
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
strdata, Quality:=xlQualityStandard, _
IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:= _
False

'Create Mail & attach PDF
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
End If


'Create a new message
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem
.To = ToAddress
.CC = CCAddress3
.votingoptions = "Approve;Reject"
.Subject = MailSub2
.HTMLBody = RangetoHTML(rng)


'Bring up new mail window
oItem.Display


'Add attachment
oItem.Attachments.Add strdata


'Move PDF Document to network drive
sSource = strdata
sDestination = "C:\Documents\AnotherFolder\" & fname & ".pdf"
Set fs = CreateObject("Scripting.FileSystemObject")
fs.movefile sSource, sDestination


'Cleanup, baby
Set OutMail = Nothing
Set OutApp = Nothing

End With




End Sub


Sub UpDateLog()
Dim wb As Workbook, wbTemp As Workbook
Dim ws As Worksheet, wsTemp As Worksheet
Dim lastRow As Long


'Setting source workbook
Set wb = ThisWorkbook
Set ws = wb.Sheets("Template")


'Setting destination workbook
Set wbTemp = Workbooks.Open("C:\Documents\Purchase Order Log.xlsx")
Set wsTemp = wbTemp.Sheets("Sheet1")


'Paste to next row
lastRow = wsTemp.Range("I" & Rows.Count).End(xlUp).Row + 1
ws.Range("A51:K51").Copy
wsTemp.Range("I" & lastRow).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False


'Cleanup
wbTemp.Close savechanges:=True
Set wb = Nothing: Set wbTemp = Nothing
Set ws = Nothing: Set wsTemp = Nothing


End Sub