Setting up a personalized body and attachments to outlook from excel

[coryjacques]

[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">

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]

 

[coryjacques]

Oops, disregard the Sub htm() piece