FlimbosQuest
New Member
- Joined
- Mar 14, 2008
- Messages
- 2
Afternoon,
First off I will admit that I am a complete novice, so please forgive my ignorance/lack of knowledge.
I have 1 script that does exactly what I want, minus one thing which I have another script for....so here it goes.
Script 1 takes the email address from column B and sends an email to it if there is a 'Yes' in column C. After running the Macro, it will then put 'sent' in column D to prevent duplicate emails being sent to the same person if the Macro is run again. This is great, as it even allows me to add an attachment. The only problem is I also want it to include a signature from Outlook, which I have the code for, but have no idea on how to add that to script 1 so it does all of the above.
Here are the culprits....
Script 1
Send_Email
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
On Error GoTo cleanup
For Each cell In Sheets("Sheet1").Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0, 1).Value) = "yes" _
And LCase(cell.Offset(0, 2).Value) <> "sent" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Test"
.Body = "Dear " & cell.Offset(0, -1).Value & vbNewLine & vbNewLine & _
"Test test test test test test test test test test"
.Attachments.Add ("C:\scan0001.pdf")
.Send 'Or use Display
End With
On Error GoTo 0
cell.Offset(0, 2).Value = "sent"
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Script 2
Email_with_sig
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim SigString As String
Dim Signature As String
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
strbody = "Testing" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
SigString = "C:\Documents and Settings\" & Environ("username") & _
"\Application Data\Microsoft\Signatures\Mysig.txt"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.To = "flimbo@test.com"
.CC = ""
.BCC = ""
.Subject = "Test"
.Body = strbody & vbNewLine & vbNewLine & Signature
.Attachments.Add ("C:\test.txt")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
For this one to work to work this function needs to be added too:
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
I hope this all makes sense and I'm also hoping someone will point me in the right direction, it would be much appreciated as I am pulling my hair out!!
Cheers,
Kim
First off I will admit that I am a complete novice, so please forgive my ignorance/lack of knowledge.
I have 1 script that does exactly what I want, minus one thing which I have another script for....so here it goes.
Script 1 takes the email address from column B and sends an email to it if there is a 'Yes' in column C. After running the Macro, it will then put 'sent' in column D to prevent duplicate emails being sent to the same person if the Macro is run again. This is great, as it even allows me to add an attachment. The only problem is I also want it to include a signature from Outlook, which I have the code for, but have no idea on how to add that to script 1 so it does all of the above.
Here are the culprits....
Script 1
Send_Email
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
On Error GoTo cleanup
For Each cell In Sheets("Sheet1").Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0, 1).Value) = "yes" _
And LCase(cell.Offset(0, 2).Value) <> "sent" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Test"
.Body = "Dear " & cell.Offset(0, -1).Value & vbNewLine & vbNewLine & _
"Test test test test test test test test test test"
.Attachments.Add ("C:\scan0001.pdf")
.Send 'Or use Display
End With
On Error GoTo 0
cell.Offset(0, 2).Value = "sent"
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Script 2
Email_with_sig
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim SigString As String
Dim Signature As String
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
strbody = "Testing" & vbNewLine & vbNewLine & _
"This is line 1" & vbNewLine & _
"This is line 2" & vbNewLine & _
"This is line 3" & vbNewLine & _
"This is line 4"
SigString = "C:\Documents and Settings\" & Environ("username") & _
"\Application Data\Microsoft\Signatures\Mysig.txt"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
On Error Resume Next
With OutMail
.To = "flimbo@test.com"
.CC = ""
.BCC = ""
.Subject = "Test"
.Body = strbody & vbNewLine & vbNewLine & Signature
.Attachments.Add ("C:\test.txt")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
For this one to work to work this function needs to be added too:
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
I hope this all makes sense and I'm also hoping someone will point me in the right direction, it would be much appreciated as I am pulling my hair out!!
Cheers,
Kim