rjplante
Well-known Member
- Joined
- Oct 31, 2008
- Messages
- 574
- Office Version
- 365
- Platform
- Windows
I have a macro that will transfer the data from the current worksheet to a transfer worksheet, open an email, attach the transfer worksheet, enter the email address on the to and CC lines, enter a subject and a body message. I would like to extract the first and last name as well as the users email, to add to the body of the email message. I have included my code below. I don't know how to get the information from outlook for the users name and email address. Once I have the users name, I would like to be able to parse out the first and last names.
VBA Code:
Sub EMAIL_CORRECTIONS()
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim empFilePath As String
Dim TempFileName As String
Dim ToAdd As String
Dim CCAdd As String
Dim EM_Body As String
Dim LastRow As Long
Dim OutApp As Object
Dim OutMail As Object
Dim Lrow As Long
' Define the list of email addresses to send list to.
ToAdd = Sheets("Intro Page").Range("AA26").Value
' CCAdd = Sheets("Intro Page").Range("AA27").Value
' Sheets("Corrections").Unprotect
' Define last row of data
Sheets("Corrections").Activate
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Corrections").Range("A6:C" & LastRow).Copy
' Paste a copy of the list on the transfer page
Sheets("Transfer Page").Visible = True
Sheets("Transfer Page").Range("A2").PasteSpecial (xlPasteValues)
' Define last row of data on the Transfer page
Sheets("Transfer Page").Select
Lrow = Cells(Rows.Count, 1).End(xlUp).Row
' Define the block of data to create a sheet from.
Set Source = Nothing
On Error Resume Next
Set Source = Sheets("Transfer Page").Range("A1:C" & Lrow).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With
TempFilePath = Environ$("temp") & "\"
TempFileName = "Data Corrections" & " " & Format(Now, "dd-mmm-yyyy")
FileExtStr = ".xlsx": FileFormatNum = 51
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = ToAdd
' .CC = CCAdd
' .BCC = ""
.Subject = "Data Corrections for " & Sheets("Intro Page").Range("C4") & " - Please Review"
.HTMLBody = "<html><body lang=EN-US link='#0563C1' vlink='#954F72'>" & _
"<span style='font-size:12.5pt'>Greetings,<o:p><br><br>" & _
"<span style='font-size:12.5pt'>The attached list of Part Numbers are not found.<o:p>" & _
"</p><span style='font-size:12.5pt'>Please review the list and initiate corrections/additions to the data table." & _
"</body></html>" '& GetEmailSig
.BodyFormat = 2 'html format
.Attachments.Add Dest.FullName
'.Send
.Display
End With
On Error GoTo 0
.Close SaveChanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
' Clear Data from transfer page
Sheets("Transfer Page").Activate
Sheets("Transfer Page").Range("A2:C" & Lrow).EntireRow.Delete
Sheets("Transfer Page").Range("A2").Select
Sheets("Transfer Page").Visible = False
Sheets("Mechanical table").Select
End Sub
