Setting up a personalized body and attachments to outlook from excel

coryjacques

New Member
Joined
May 17, 2019
Messages
14
[FONT=\&quot]Hello,

I found/modified the below code, which is pretty close to what I need done.




<code data-editor="34b16c" data-block="true" data-offset-key="edq1k-0-0">
Code:
Sub MailBlast()
</code><code data-editor="34b16c" data-block="true" data-offset-key="628t3-0-0">    Dim xRg As Range
</code><code data-editor="34b16c" data-block="true" data-offset-key="b36sn-0-0">    Dim xRgEach As Range
</code><code data-editor="34b16c" data-block="true" data-offset-key="a2b45-0-0">    Dim xRgVal As String
</code><code data-editor="34b16c" data-block="true" data-offset-key="44da3-0-0">    Dim xAddress As String
</code><code data-editor="34b16c" data-block="true" data-offset-key="2366s-0-0">    Dim xOutApp As Outlook.Application
</code><code data-editor="34b16c" data-block="true" data-offset-key="5gq7r-0-0">    Dim xMailOut As Outlook.MailItem
</code><code data-editor="34b16c" data-block="true" data-offset-key="apnhh-0-0">    Dim myAtt As Variant
</code><code data-editor="34b16c" data-block="true" data-offset-key="1h77k-0-0">    Dim myCC As Variant
</code><code data-editor="34b16c" data-block="true" data-offset-key="8fb4t-0-0">    Dim xSubj As String
</code><code data-editor="34b16c" data-block="true" data-offset-key="2dvjj-0-0">    Dim mySub As Variant
</code><code data-editor="34b16c" data-block="true" data-offset-key="861fd-0-0">    Dim xTxt As String
</code><code data-editor="34b16c" data-block="true" data-offset-key="9h9fu-0-0">    Dim SigString As String
</code><code data-editor="34b16c" data-block="true" data-offset-key="fburf-0-0">    Dim Signature As String
</code><code data-editor="34b16c" data-block="true" data-offset-key="3sd2n-0-0">    Dim bRg As Range
</code><code data-editor="34b16c" data-block="true" data-offset-key="2k43k-0-0">    
</code><code data-editor="34b16c" data-block="true" data-offset-key="2av8d-0-0">    
</code><code data-editor="34b16c" data-block="true" data-offset-key="cpeo4-0-0">    
</code><code data-editor="34b16c" data-block="true" data-offset-key="ao9d6-0-0">    mySub = InputBox("Select the Subject for your Message.", "Subject")
</code><code data-editor="34b16c" data-block="true" data-offset-key="3p9hs-0-0">Do
</code><code data-editor="34b16c" data-block="true" data-offset-key="dcio7-0-0">    myAtt = InputBox("Add the full file path to your file location. Select Cancel if no attachment, or no additional attachments are needed", "Attachments")
</code><code data-editor="34b16c" data-block="true" data-offset-key="b6dii-0-0">Loop Until myAtt.InputBox = vbCancel
</code><code data-editor="34b16c" data-block="true" data-offset-key="54pa4-0-0">    myCC = InputBox("Add your CC line, separated by a ; if using multiple", "CC")
</code><code data-editor="34b16c" data-block="true" data-offset-key="7tsqv-0-0">

</code><code data-editor="34b16c" data-block="true" data-offset-key="btudr-0-0">

</code><code data-editor="34b16c" data-block="true" data-offset-key="4k87-0-0">   Set olApp = CreateObject("Outlook.Application")
</code><code data-editor="34b16c" data-block="true" data-offset-key="bu0en-0-0">   Set olMailItm = olApp.CreateItem(0)
</code><code data-editor="34b16c" data-block="true" data-offset-key="56j8b-0-0">   SigString = Environ("appdata") & _
</code><code data-editor="34b16c" data-block="true" data-offset-key="2p5ji-0-0">            "\Microsoft\Signatures\Cory.htm" '<Replace cory with the name of your signature'
</code><code data-editor="34b16c" data-block="true" data-offset-key="cs1n4-0-0">            
</code><code data-editor="34b16c" data-block="true" data-offset-key="bag9q-0-0">     If Dir(SigString) <> "" Then
</code><code data-editor="34b16c" data-block="true" data-offset-key="2mkfn-0-0">        Signature = GetBoiler(SigString)
</code><code data-editor="34b16c" data-block="true" data-offset-key="bhcjo-0-0">    Else
</code><code data-editor="34b16c" data-block="true" data-offset-key="1o765-0-0">        Signature = ""
</code><code data-editor="34b16c" data-block="true" data-offset-key="c81cl-0-0">    End If
</code><code data-editor="34b16c" data-block="true" data-offset-key="9gvcf-0-0">   
</code><code data-editor="34b16c" data-block="true" data-offset-key="d9s77-0-0">    On Error Resume Next
</code><code data-editor="34b16c" data-block="true" data-offset-key="f6c7p-0-0">    xAddress = ActiveWindow.RangeSelection.Address
</code><code data-editor="34b16c" data-block="true" data-offset-key="cccqo-0-0">    Set xRg = Application.InputBox("Please select Data range", "Data", xTxt, , , , , 8)
</code><code data-editor="34b16c" data-block="true" data-offset-key="f4t3-0-0">    If xRg Is Nothing Then Exit Sub
</code><code data-editor="34b16c" data-block="true" data-offset-key="2qral-0-0">

</code><code data-editor="34b16c" data-block="true" data-offset-key="2sia0-0-0">    
</code><code data-editor="34b16c" data-block="true" data-offset-key="9kmje-0-0">    Application.ScreenUpdating = False
</code><code data-editor="34b16c" data-block="true" data-offset-key="bha5q-0-0">    Set xOutApp = CreateObject("Outlook.Application")
</code><code data-editor="34b16c" data-block="true" data-offset-key="2d9hf-0-0">    Set xRg = xRg.SpecialCells(xlCellTypeConstants, xlTextValues)
</code><code data-editor="34b16c" data-block="true" data-offset-key="29ep7-0-0">    
</code><code data-editor="34b16c" data-block="true" data-offset-key="a1k31-0-0">    For Each xRgEach In xRg
</code><code data-editor="34b16c" data-block="true" data-offset-key="8f55t-0-0">        xRgVal = xRgEach.Value
</code><code data-editor="34b16c" data-block="true" data-offset-key="32bvh-0-0">        If xRgVal Like "?*@?*.?*" Then
</code><code data-editor="34b16c" data-block="true" data-offset-key="5r7qk-0-0">            Set xMailOut = xOutApp.CreateItem(olMailItem)
</code><code data-editor="34b16c" data-block="true" data-offset-key="1ogue-0-0">            With xMailOut
</code><code data-editor="34b16c" data-block="true" data-offset-key="fk3dv-0-0">            .Display
</code><code data-editor="34b16c" data-block="true" data-offset-key="a73kq-0-0">                .To = xRgVal
</code><code data-editor="34b16c" data-block="true" data-offset-key="bcm63-0-0">                .CC = myCC
</code><code data-editor="34b16c" data-block="true" data-offset-key="9f99c-0-0">                .Subject = mySub
</code><code data-editor="34b16c" data-block="true" data-offset-key="61bck-0-0">                .HTMLBody = ActiveSheet.TextBoxes(1).Text & "<br><br>" & Signature
</code><code data-editor="34b16c" data-block="true" data-offset-key="8p5g7-0-0">                .Attachments.Add myAtt
</code><code data-editor="34b16c" data-block="true" data-offset-key="63dm5-0-0">                .Send
</code><code data-editor="34b16c" data-block="true" data-offset-key="4p99o-0-0">            End With
</code><code data-editor="34b16c" data-block="true" data-offset-key="9baqs-0-0">        End If
</code><code data-editor="34b16c" data-block="true" data-offset-key="1vvmn-0-0">    Next
</code><code data-editor="34b16c" data-block="true" data-offset-key="7n719-0-0">    Set xMailOut = Nothing
</code><code data-editor="34b16c" data-block="true" data-offset-key="2a43u-0-0">    Set xOutApp = Nothing
</code><code data-editor="34b16c" data-block="true" data-offset-key="6ac3t-0-0">    Application.ScreenUpdating = True
</code><code data-editor="34b16c" data-block="true" data-offset-key="6gru4-0-0">End Sub
</code><code data-editor="34b16c" data-block="true" data-offset-key="amtbj-0-0">

</code><code data-editor="34b16c" data-block="true" data-offset-key="c2v7k-0-0">Function GetBoiler(ByVal sFile As String) As String
</code><code data-editor="34b16c" data-block="true" data-offset-key="443bk-0-0">

</code><code data-editor="34b16c" data-block="true" data-offset-key="f3r0s-0-0">    Dim fso As Object
</code><code data-editor="34b16c" data-block="true" data-offset-key="1tri-0-0">    Dim ts As Object
</code><code data-editor="34b16c" data-block="true" data-offset-key="1ap8r-0-0">    Set fso = CreateObject("Scripting.FileSystemObject")
</code><code data-editor="34b16c" data-block="true" data-offset-key="7d6je-0-0">    Set ts = fso.getfile(sFile).OpenAsTextStream(1, -2)
</code><code data-editor="34b16c" data-block="true" data-offset-key="83p1s-0-0">    GetBoiler = ts.readall
</code><code data-editor="34b16c" data-block="true" data-offset-key="blpug-0-0">    ts.Close
</code><code data-editor="34b16c" data-block="true" data-offset-key="d942b-0-0">End Function
</code><code data-editor="34b16c" data-block="true" data-offset-key="5taru-0-0">

</code><code data-editor="34b16c" data-block="true" data-offset-key="5rtqd-0-0">Sub htm()
</code><code data-editor="34b16c" data-block="true" data-offset-key="4tjmk-0-0">ActiveCell.FormulaR1C1 = _
</code><code data-editor="34b16c" data-block="true" data-offset-key="epuar-0-0">        "<p style=""font-family:""[your font]"" font size=""[your size]pt"">. Add ""</font>"" at the end of your message."
</code><code data-editor="34b16c" data-block="true" data-offset-key="734vc-0-0">End Sub [/CODE/
</code><code data-editor="34b16c" data-block="true" data-offset-key="e69f5-0-0">

</code>I was wondering if there was a way to duplicate the process for how this find the .To (xRgVal) line to .Attachments.Add and .HTMLBody?




Currently the way this works is to select a range (one column) that represents email address which are input into .To. I want to have a second and third column added to the range which would represent a path to a file to be attached, and the body of an email respectively. I have msgBoxes for inputting a file path and selecting the CC line, etc. This is fulyl functional for sending out one generic message with one attachment. Ultimately this would mean that as the code scans down, the contact from row 1 gets a personalized message and specific file whereas the contact in row 2 gets a totally different message and attachment.




Additionally, there are some issues with the "Do Until" loop on myAtt. If I take out Do Until, I can successfully add one attachment, but this does not allow me to add multiple. Is there a way to get this to add attachments until someone hits cancel or leaves the box blank?




Is this possible?

[/FONT]
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.

Forum statistics

Threads
1,213,543
Messages
6,114,237
Members
448,555
Latest member
RobertJones1986

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top