VBA to automate sending emails and copy date/time and subject for other sheet

[Antonio Costa]

Hi to every member's of MRExcel.com, hoping that all feel fine . I need some help to find if my vba is right :

* I need to send email's with this macro and using my signature of outlook
* Copy date/time and subject of the email send to a sheet in the same worksheet

Sub Email()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set rng = Selection.SpecialCells(xlCellTypeVisible)
Set rng = Sheets("******").Range("C12:D36").SpecialCells(xlCellTypeVisible)
On Error Resume Next
With OutMail
    .To = Range("C5").Value
    .CC = Range("C6").Value
    .BCC = Range("C7").Value
    .Subject = Range("C8").Value
    .HTMLBody = RangetoHTML(rng)
    .Display

End With
On Error GoTo 0
Set OutMail = Nothing
End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".html"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
TempWB.Close SaveChanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

At this moment the macro is working to send email, but not to entrer the signature or make a copy of the send.

Thank you all

 

[DanteAmor]

Hi @Antonio Costa
I also hope you are well.

* I need to send email's with this macro and using my signature of outlook

For that, change these lines

    .HTMLBody = RangetoHTML(rng)
    .Display

to this:

    .Display
    .HTMLBody = RangetoHTML(rng) & .HTMLBody
    .Display

--------------------------------------​

* Copy date/time and subject of the email send to a sheet in the same worksheet

I don't understand what you mean, you can put an image of what you want.
I'm going to assume that you want to put that data on sheet "Sheet1" in cell F2.
So after this line:

On Error GoTo 0

Put this line:

Sheets("Sheet1").Range("F2").Value = Now & " " & Sheets("Sheet1").Range("C8").Value

--------------------------------------​

And finally, I don't understand what you mean by this:

or make a copy of the send

--------------------------------------​

If something that I am giving you does not work for you or is not correct, then explain in more detail and with images what you want.

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

 

[Antonio Costa]

Thank you @DanteAmor for your help. The first two answers help me to solve those problems, for the third i think that i gone try something like this , what do you think:

Sub GetFromOutlook()
Dim OutlookApp  As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder      As MAPIFolder
Dim OutlookMail As Variant
Dim i           As Integer
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
'For entire mailbox
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox)
'For specific folder
'Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("****")
i = 4
For Each OutlookMail In Folder.Items 
'Subject
Cells(i, 1) = OutlookMail.Subject
'Received Date
Cells(i, 2) = OutlookMail.ReceivedTime
'Sender Name
Cells(i, 3) = OutlookMail.SenderName
'Body
Cells(i, 4) = OutlookMail.Body
'Importance
Cells(i, 5) = OutlookMail.Importance
'cc
Cells(i, 6) = OutlookMail.CC
'bcc
Cells(i, 7) = OutlookMail.BCC
i = i + 1
Next OutlookMail
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub

 

[DanteAmor]

The first two answers help me to solve those problems, for the third i think that i gone try something like this , what do you think:

I don't know what to think, like I said, I don't understand what you mean.

But if that code works for you, perfect.

Much of this programming consists of trying and trying until you get what you want.