[µo°Ý] VBA ¹q¶l¥[¤J¹w³]ñ¸p

missbb

invitation.pdf (16.3 KB)

¤U¸ü¦¸¼Æ: 2

2017-1-23 19:49

½Ð°Ý¦p¦ó¥i¥H¦b¹q¶l¤º¥[¤J¹w³]ªºÃ±¸p? ¦]¬°¸Õ¤F«Ü¤[¤]¤£¯à³B²z, ¨D§U¤j¤j?
dinner test.zip (20.6 KB)

¤U¸ü¦¸¼Æ: 1

2017-1-23 19:50

Sub annualsporemailtestonly()

' sent annual sponsorship email and input content to in this vba.

'Column A holds name of the company
'Column B holds sex
'Column C holds name of the person
'Column E holds email addressn (column d is empty for future use)
'Column F holds Yes or No to send
   
        
    Dim xPath As String
    Dim EBody As String
    Dim strSignature As String
        
    xPath = Application.ActiveWorkbook.Path
   
  
EBody = "<b><u>" & "Re : TEST" & "</b></u>" & "<br>" & "<br>" _
    & "How are you" & " <br/>" & "<br>" _
    & "Thank you" & "<br>" & "<br>"

   
   
   
Worksheets("email").Activate

On Error GoTo EndOfSub
    For Each cell In Columns("d").Cells.SpecialCells(2, 2)
        If cell.Text Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "e").Text) = "yes" Then

            On Error Resume Next
            With CreateObject("Outlook.Application").CreateItem(0)
                .To = cell.Text
                .Subject = "Test"
                .HTMLBody = Replace("Dear " & Cells(cell.Row, "B").Value & " " & Cells(cell.Row, "C") & "," & vbNew & "#" & Cells(cell.Row, "f").Value & "<br>" & "<br>" & EBody, "#", vbNew & vbNew)
                .Attachments.Add (ActiveWorkbook.Path & "\test.pdf")
                    

                .display  'Or use .Display
            End With
            On Error GoTo 0
        End If
    Next

EndOfSub:


End Sub
[/code]