Please post some of the preceeding thread when you reply, it makes it much
harder to follow the thread otherwise.
At some point, IT person or not, you're going to need to be able to step
your code and debug things to get things working the way you want. I'd
recommend buying a good beginner VBA book so you know how to do the basics.
You really should have something in the To field, a lot of email programs
will consider an email with only Bcc as a spam. Also, usually it's best to
set a Recipient object as olBCC instead of the way it's being done here.
I haven't tested this code. I cleaned up undeclared Outlook and Redemption
objects, released them all, and merged the Outlook and Redemption code
together. Anything else is your responsibility.
Sub Mail_New_Version()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim sh As Worksheet
Dim oNS As Outlook.NameSpace
Dim oSession As Redemption.RDOSession
Dim oAccount As Redemption.RDOAccount
Dim sID As String
Dim Msg As Redemption.RDOMail
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the sheets to a new workbook
Sourcewb.Sheets(Array("Mail", "YTD")).Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
'We exit the sub when your answer is NO in the security
dialog that you only
'see when you copy a sheet from a xlsm file with macro's
disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-
mmm-yy h-mm")
ActiveWindow.TabRatio = 0.908
For Each cell In ThisWorkbook.Sheets("Mail") _
.Columns("BA").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" Then
strto = strto & cell.Value & ";"
End If
Next
strto = Left(strto, Len(strto) - 1)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr,
FileFormat:=FileFormatNum
On Error Resume Next
Set OutApp = CreateObject("Outlook.Application")
Set oNS = OutApp.GetNamespace("MAPI")
oNS.Logon
Set OutMail = OutApp.CreateItem(0)
Set oSession = CreateObject("Redemption.RDOSession")
MsgBox TypeName(oNS)
oSession.MAPIOBJECT = oNS.MAPIOBJECT
Set oAccount = oSession.Accounts("ABC Reporting")
With OutMail
.To = ""
.CC = ""
.BCC = strto
.Subject = ThisWorkbook.Sheets("Mail").Range("A1").Value
.Body = ""
.Attachments.Add Destwb.FullName
.ReadReceiptRequested = True
.Importance = 1
.Save
sID = .EntryID
Set Msg = oSession.GetMessageFromID(sID)
Msg.Account = oAccount
.Subject = .Subject
.Save
.Send
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Set Sourcewb = Nothing
Set Destwb = Nothing
Set sh = Nothing
Set oAccount = Nothing
Set Msg = Nothing
oSession.Logoff
Set oSession = Nothing
Set OutMail = Nothing
Set oNS = Nothing
OutApp.Quit
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
