Anomandaris
05-28-2009, 04:45 AM
Hi there I got this code earlier from here and it was working till now. However today it stopped working....now it just makes a copy of the sheet 'SCORE' and stops, it doesnt go through with the rest of the process..
SCORE is a sheet that needs to be emailed
EMAIL is the sheet that has all teh email addresses of clients.
its quite bizarre
any thoughts? I'm thinking the long With "EMAIL" function may be the problem...
thanks
Sub SendMail()
Const MatchCode As String = "BP"
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
Dim strDate As String
strDate = Format(Date, "dd-mm-yy") & "." & Format(Time, "hh-mm-ss")
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
Worksheets("SCORE").Range("L1:S200").Select
Selection.Interior.ColorIndex = xlNone
Worksheets("SCORE").Range("G1").Select
Set wb = ActiveWorkbook
wb.SaveAs "Part of" & ThisWorkbook.Name & "" & strDate & ".xls"
wb.ChangeFileAccess xlReadOnly
Set OLApp = CreateObject("Outlook.Application")
Set EmailItem = OLApp.CreateItem(0)
EmailItem.Subject = " Recap"
LastCol = .Cells(8, .Columns.Count).End(xlToLeft).Column
For j = 2 To LastCol
Set EmailRecip = EmailItem.Recipients.Add(.Cells(8, j).Value)
EmailRecip.Type = 1
Next j
Dim oRecipient As Object
Set oRecipient = _
EmailItem.Recipients.Add("team")
oRecipient.Type = 2
Dim Msg As String
Msg = "Hello," & vbCrLf & vbCrLf
Msg = Msg & "Confirming" & 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
SCORE is a sheet that needs to be emailed
EMAIL is the sheet that has all teh email addresses of clients.
its quite bizarre
any thoughts? I'm thinking the long With "EMAIL" function may be the problem...
thanks
Sub SendMail()
Const MatchCode As String = "BP"
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
Dim strDate As String
strDate = Format(Date, "dd-mm-yy") & "." & Format(Time, "hh-mm-ss")
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
Worksheets("SCORE").Range("L1:S200").Select
Selection.Interior.ColorIndex = xlNone
Worksheets("SCORE").Range("G1").Select
Set wb = ActiveWorkbook
wb.SaveAs "Part of" & ThisWorkbook.Name & "" & strDate & ".xls"
wb.ChangeFileAccess xlReadOnly
Set OLApp = CreateObject("Outlook.Application")
Set EmailItem = OLApp.CreateItem(0)
EmailItem.Subject = " Recap"
LastCol = .Cells(8, .Columns.Count).End(xlToLeft).Column
For j = 2 To LastCol
Set EmailRecip = EmailItem.Recipients.Add(.Cells(8, j).Value)
EmailRecip.Type = 1
Next j
Dim oRecipient As Object
Set oRecipient = _
EmailItem.Recipients.Add("team")
oRecipient.Type = 2
Dim Msg As String
Msg = "Hello," & vbCrLf & vbCrLf
Msg = Msg & "Confirming" & 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