PDA

View Full Version : Email code problem, stopped working



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

Bob Phillips
05-28-2009, 05:06 AM
Don't think so, but as you are hardly using it it seems redundant anyway.

Post the workbook so we can follow it.

Anomandaris
05-28-2009, 05:26 AM
ive attached 2 sheets from the file

Anomandaris
05-29-2009, 01:55 AM
sorry, just bumping this up