Anomandaris
04-17-2009, 02:44 AM
I'm having trouble with this code that is supposed to send emails from excel......when I press the button that is supposed to send email, it gives me a runtime error, it was working fine before, I dont understand whats wrong now.
Sub SendMailPORT()
Const MatchCode As String = "PORT"
Dim wb As Workbook
Dim LastRow As Long
Dim LastCol As Long
Dim OLApp As Object
Dim EmailItem As Object
Dim EmailRecip As Object
Dim j As Long
With Worksheets("SCORE")
If Range("B1") <> MatchCode Then
MsgBox "Data not for " & MatchCode
Exit Sub
End If
End With
With Worksheets("EMAIL")
Worksheets("SCORE").Copy
Dim shp As Shape
Dim sTopLeft As String
Dim fOK As Boolean
For Each shp In ActiveSheet.Shapes
fOK = True
sTopLeft = ""
On Error Resume Next
sTopLeft = shp.TopLeftCell.Address
On Error GoTo 0
If shp.Type = msoFormControl Then
If shp.FormControlType = xlDropDown Then
If sTopLeft = "" Then
fOK = False 'keep it
End If
End If
End If
If fOK Then
shp.Delete
End If
Next shp
Worksheets("SCORE").Range("H1:H10").Select
Selection.ClearContents
Set wb = ActiveWorkbook
wb.SaveAs "Part of" & ThisWorkbook.Name & "" & ".xls"
wb.ChangeFileAccess xlReadOnly
Set OLApp = CreateObject("Outlook.Application")
Set EmailItem = OLApp.CreateItem(0)
EmailItem.Subject = " Recap - PORT"
LastCol = .Cells(11, .Columns.Count).End(xlToLeft).Column
For j = 2 To LastCol
Set EmailRecip = EmailItem.Recipients.Add(.Cells(11, j).Value)
EmailRecip.Type = 1
Next j
Dim oRecipient As Object
Set oRecipient = _
EmailItem.Recipients.Add(brt@xxx.com)
oRecipient.Type = 2
Dim Msg As String
Msg = "Hello," & vbCrLf & vbCrLf
Msg = Msg & "Confirming the following execution(s):" & vbCrLf & vbCrLf
Msg = Msg & "Thanks,"
EmailItem.Body = Msg
EmailItem.Attachments.Add wb.FullName
EmailItem.Display 'Send
Kill wb.FullName
Set wb = Nothing
Set EmailItem = Nothing
Set OLApp = Nothing
End With
End Sub
Thanks
Sub SendMailPORT()
Const MatchCode As String = "PORT"
Dim wb As Workbook
Dim LastRow As Long
Dim LastCol As Long
Dim OLApp As Object
Dim EmailItem As Object
Dim EmailRecip As Object
Dim j As Long
With Worksheets("SCORE")
If Range("B1") <> MatchCode Then
MsgBox "Data not for " & MatchCode
Exit Sub
End If
End With
With Worksheets("EMAIL")
Worksheets("SCORE").Copy
Dim shp As Shape
Dim sTopLeft As String
Dim fOK As Boolean
For Each shp In ActiveSheet.Shapes
fOK = True
sTopLeft = ""
On Error Resume Next
sTopLeft = shp.TopLeftCell.Address
On Error GoTo 0
If shp.Type = msoFormControl Then
If shp.FormControlType = xlDropDown Then
If sTopLeft = "" Then
fOK = False 'keep it
End If
End If
End If
If fOK Then
shp.Delete
End If
Next shp
Worksheets("SCORE").Range("H1:H10").Select
Selection.ClearContents
Set wb = ActiveWorkbook
wb.SaveAs "Part of" & ThisWorkbook.Name & "" & ".xls"
wb.ChangeFileAccess xlReadOnly
Set OLApp = CreateObject("Outlook.Application")
Set EmailItem = OLApp.CreateItem(0)
EmailItem.Subject = " Recap - PORT"
LastCol = .Cells(11, .Columns.Count).End(xlToLeft).Column
For j = 2 To LastCol
Set EmailRecip = EmailItem.Recipients.Add(.Cells(11, j).Value)
EmailRecip.Type = 1
Next j
Dim oRecipient As Object
Set oRecipient = _
EmailItem.Recipients.Add(brt@xxx.com)
oRecipient.Type = 2
Dim Msg As String
Msg = "Hello," & vbCrLf & vbCrLf
Msg = Msg & "Confirming the following execution(s):" & vbCrLf & vbCrLf
Msg = Msg & "Thanks,"
EmailItem.Body = Msg
EmailItem.Attachments.Add wb.FullName
EmailItem.Display 'Send
Kill wb.FullName
Set wb = Nothing
Set EmailItem = Nothing
Set OLApp = Nothing
End With
End Sub
Thanks