I have this code
It runs through a list of companies and emails an attachment to each company selected. But I do not have an email address for certian companies. Is there a way to make it send the emails to the companies we do have and have a message pop up listing the companies that didn't have email adresses?
Thanks!
Code:
Option Explicit
Sub RunOnAll()
Dim sh As Object
Set sh = ActiveSheet.Shapes.AddShape(msoShapeCloud, 125.25, 30, 118.5, 96.75)
sh.Name = "Popup"
ActiveSheet.Shapes("Popup").Select
Selection.Characters.Text = "Running Macro..."
Selection.Font.Size = "24"
With Selection.Characters.Font
.ColorIndex = xlAutomatic
End With
Dim myPicture As Shape
Set myPicture = ActiveSheet.Shapes("Popup")
With ActiveWindow.VisibleRange
myPicture.Top = .Top + .Height / 2 - myPicture.Height / 1
myPicture.Left = .Left + .Width / 6 - myPicture.Width / 60
myPicture.Height = myPicture.Height * 3
myPicture.Width = myPicture.Width * 3
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 49
Selection.ShapeRange.Line.ForeColor.SchemeColor = 45
End With
myPicture.Visible = True
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
Mail_small_Text_Outlook ws
Next ws
myPicture.Delete
Dim sha As Object
Set sha = ActiveSheet.Shapes.AddShape(msoShapeSmileyFace, 125.25, 30, 118.5, 96.75)
sha.Name = "Popu"
ActiveSheet.Shapes("Popu").Select
Selection.Characters.Text = "Done!"
Selection.Font.Size = "30"
With Selection.Characters.Font
.ColorIndex = "2"
End With
Dim myPic As Shape
Set myPic = ActiveSheet.Shapes("Popu")
With ActiveWindow.VisibleRange
myPic.Top = .Top + .Height / 2 - myPic.Height / 1
myPic.Left = .Left + .Width / 6 - myPic.Width / 60
myPic.Height = myPic.Height * 3
myPic.Width = myPic.Width * 3
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 57
Selection.ShapeRange.Line.ForeColor.SchemeColor = 61
End With
myPic.Visible = True
End Sub
Sub Mail_small_Text_Outlook(ws As Worksheet)
Dim cell As Range
Dim OutApp As Object
Dim OutMail As Object
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In ws.Columns("G").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(ws.Cells(cell.Row, "H").Value) = "y" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Request for Quotation"
.Body = "Dear " & ws.Cells(cell.Row, "F").Value _
& vbNewLine & vbNewLine & _
"Please review the attachment and " & _
"let us know your quote."
.Attachments.Add ("T:\KATY IKEDA\KATY IKEDA\request for quote.xls")
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End SubIt runs through a list of companies and emails an attachment to each company selected. But I do not have an email address for certian companies. Is there a way to make it send the emails to the companies we do have and have a message pop up listing the companies that didn't have email adresses?
Thanks!
