View Single Post
  #1   Report Post  
Posted to microsoft.public.excel.programming
Steved Steved is offline
external usenet poster
 
Posts: 519
Default Creating Email using Windows XP, Office 2007, Outlook 2007 "worksh

Hello from Steved I've copied the below from another computer which worked
fine but now we have upgraded it partly works. What is required please.
The below macro will use the only the bottom three and works like a treat
but it will not email the rest. "1-Depot", has 2 email address and works
along with 2-Roskill, but it will not send Addr = Array "4-Depot" for
speadsheets Shname = Array "3-Papakura","4-Wiri" and Addr = Array 5-Depot for
speadsheets Shname = Array "5-Shore","6-Orewa" and Addr = Array "7-Depot",
for Spreadsheet Shname = Array "7-Swanson", and also Addr = Array 1-City for
Spreadsheet Shname = Array "8-Panmure"

?-Depots each have 2 email address ( Distribution List )

Shname = Array("1-City", "2-Roskill", "2-Roskill"
Addr = Array("1-Depot", "2-Depot", "Roskill Tutor",


Sub MailToDepots()
'Working in 97-2007
Dim wb As Workbook
Dim Shname As Variant
Dim Addr As Variant
Dim N As Integer
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long

Shname = Array("1-City", "2-Roskill", "2-Roskill", "3-Papakura",
"4-Wiri", "5-Shore", "6-Orewa", "7-Swanson", "8-Panmure")
Addr = Array("1-Depot", "2-Depot", "Roskill Tutor", "4-Depot",
"4-Depot", "5-Depot", "5-Depot", "7-Depot", "1-Depot")


If Val(Application.Version) = 12 Then
'You run Excel 2007
FileExtStr = ".xls": FileFormatNum = 56
Else
'You run Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
End If

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

TempFilePath = Environ$("temp") & "\"

'Create the new workbooks/Mail it/Delete it
For N = LBound(Shname) To UBound(Shname)

TempFileName = "Sheet " & Shname(N) & " " & Format(Now, "dd-mmm-yy
h-mm-ss")

ThisWorkbook.Sheets(Shname(N)).Copy
With ActiveSheet.UsedRange
.Copy
.PasteSpecial Paste:=xlPasteValues
End With
Set wb = ActiveWorkbook

With wb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormatNum
On Error Resume Next
.SendMail Addr(N), _
"Driver Annulments"
On Error Resume Next
.Close SaveChanges:=False
End With

Kill TempFilePath & TempFileName & FileExtStr

Next N

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Thankyou.