Composing Email using Macro

[inderdaad]

Hello,

the code below puts some excel data on the clipboard and generates an Email message
The address and subject are filled in (generated by Hyperlink)
Today I manually paste the clipboard's content into the body of the Email, works fine
Could this be done using VBA



Range("N4:U38").Select
Selection.Copy
Dim FindString As String
Dim rng As Range
FindString = Sheets("Externe bestelling").Range("O3").Value
If Trim(FindString) <> "" Then
With Sheets("Externe bestelling").Range("N:N")
Set rng = .Find(What:=FindString)

If Not rng Is Nothing Then
Application.Goto rng, True
Else
MsgBox "Nothing found"
End If
End With
End If
Selection.Hyperlinks(1).Follow NewWindow:=True, AddHistory:=True


Hope someone could help me

Thanks in advance

[nathandavies]

Have a look at this code. this creates an email using a macro.

Function GetBoiler(ByVal sFile As String) As String    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.ReadAll
    ts.Close
End Function


Sub HTMLHandoverForm()
'This should work in Office 2000-2010


    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
 
    'Set the wording of the email
    strbody = "<FONT color=#000000 face=Calibri size=3>" & _
                "- This is handover form has been raised manually for the contract referenced below because sales requested the need for a handover and you quoted this contract <br>" & _
                "- By replying to this email you are confirming that a handover took place <br>" & _
                "- During the handover meeting if you uncover topics/actions <u>THAT ARE NOT ALREADY</u> on the work instruction, then summarise in your reply. Otherwise leave your reply blank. <br> <br> <br>" & _
                "Quote - " & Sheets("Summary").Range("CQuoteNumber") & "<br>" & _
                "Job Number - " & Sheets("Summary").Range("CJobNumber") & "-" & Sheets("Summary").Range("CJobNumberSub") & "<br>" & _
                "Company - " & Sheets("Summary").Range("CCompanyName") & "<br>" & _
                "Site - " & Sheets("Summary").Range("CSiteName") & "<br>" & _
                "Description - " & Sheets("Summary").Range("CDescription")




    'Set the subject of the email
    If Sheets("Summary").Range("CQuoteNumber") = "" Then
    strsubject = "HANDOVER FORM. " & Sheets("Summary").Range("CCompanyName") & ". Job " & Sheets("Summary").Range("CJobNumber") & "-" & Sheets("Summary").Range("CJobNumberSub")
    Else
    strsubject = "HANDOVER FORM. " & Sheets("Summary").Range("CCompanyName") & ". Job " & Sheets("Summary").Range("CJobNumber") & "-" & Sheets("Summary").Range("CJobNumberSub") & " and Quote " & Sheets("Summary").Range("CQuoteNumber")
    End If
    
    'Specify where the signature file is
    SigString = Environ("appdata") & "\Microsoft\Signatures\excelsignature.htm"
    'This uses the GetBoiler code above
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    'If there is no signature file then the email will have no signature
    Else
        Signature = ""
    End If


    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
    On Error Resume Next
    With OutMail
        .To = Sheets("Summary").Range("CQEEmail")
        .Subject = strsubject
        .HTMLBody = strbody
        .Attachments.Add ActiveWorkbook.FullName
        .Display   'or use .Send
    End With
    On Error GoTo 0
 
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
 
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    ActiveWorkbook.Save
    
End Sub

[inderdaad]

Hi,

indeed your code creates an email but from the looks of it there is predefined text and subject in it
I think it is not helping in my case

Thanks anyway

[nathandavies]

You can use the cell names for the email & subject if the range doesn't change

"Quote - " & Sheets("Summary").Range("CQuoteNumber") & "<br>" & 

[inderdaad]

Commng back to your code there is a line wich is interesting

.To = Sheets("Summary").Range("CQEEmail")

Does this refer to one email adres or to list of adresses
Actually I am looking for a variable here

Some advise?

[nathandavies]

Yes, this is just 1 email address which is found using a v lookup and the value returned to that cell.

[greyangel]

I use this macro all the time for mass e-mailing. It is kind of self explanatory. You can put as many recipients as you want and they each get a customized file or you can just remove the customized file by deleting the .attachment.add line.

Sub Sed_Email()
'Created by Robbie DePalma
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Range("B2").Select
     
     Body_text = Range("H2").Value
    
     
     Do Until ActiveCell.Offset(-1).Value = ""
     recipipent = ActiveCell.Value
     Sending_file = ActiveCell.Offset(, 1).Value
     
    'Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Dim iFile As Integer
    Dim strVar As String
     
     
    iFile = FreeFile
             
            Set OutMail = OutApp.CreateItem(0)
            
            With OutMail
                .To = recipipent
                .Subject = Range("G2").Value
                .Body = Body_text ' here will be the body of first value
                .Display 'Or use Display
                .Attachments.Add (Sending_file)
                .send
            End With
            On Error GoTo 0
            Set OutMail = Nothing
            With ActiveCell.Offset(, 2)
 .Value = Date
 .NumberFormat = "mm/dd/yy"
 End With
            ActiveCell.Offset(1).Select
            Loop
        
  
     
    
     
     
End Sub