VB Code to email active worksheet (1 Viewer)

[JahJr]

I have the following code of which I have a button on a excel worksheet that is supposed to email the active sheet. I can get the email. I can even get attachments. I just can't get it to work properly with the active sheet. Any help would be greatly appreciated.

Thanks

Sub SendMail()
 
 
 
    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String
    Dim Flds As Variant
 
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
 
    iConf.Load -1 ' CDO Source Defaults
    Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "Full Email Address"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "Password"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
 
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Update
    End With
 
    strbody = "Attached you will find last nights numbers" 
    & vbNewLine 
    & vbNewLine & _
    "Thanks" & vbNewLine & _
    & vbNewLine & _
    "Lee"
 
    ActiveWorkbook.save
 
     CurrFile = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
 
    With iMsg
        Set .Configuration = iConf
        .To = EmailAddress@gggg.com
        .CC = ""
        .BCC = ""
        .From = """Name"" <Email@Email.com>"
        .Subject = "Closing Numbers"
        .Attachment.Add = CurrFile
        .Send
    End With
End Sub

 

[JahJr]

I have it fixed but when you recieve the email it is losing some of the information in the spreadsheet. All the code and macros are still there. It loses whatever data that was in the sheet and the formatting. Any suggestions?

Sub EmailSheet_Click()

ActiveWorkbook.SaveCopyAs Filename:="c:\Temp1\Closing Sheet Email.xls"

Dim iMsg As Object
Dim iConf As Object
Dim strbody As String
Dim Flds As Variant

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")

iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "******@Gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "*****"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"

.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With

strbody = "Hi there"

With iMsg
Set .Configuration = iConf
.To = "****@123.com"
.CC = ""
.BCC = ""
' Note: The reply address is not working if you use this Gmail example
' It will use your Gmail address automatic. But you can add this line
' to change the reply address .ReplyTo = "Reply@something.nl"
.From = """******"" <*****@gmail.com>"
.Subject = "Closing Numbers"
.AddAttachment "c:\Temp1\Closing Sheet Email.xls"
.send

Kill "c:\Temp1\Closing Sheet Email.xls"

ActiveWorkbook.Saved = True
Application.Quit

End With
End Sub

 

[JahJr]

There seems to be a bug with imsg. If you dont put text in the body of the email the attachments lose all formatting. The code below works.

ChDir "c:\Temp1"
    ActiveWorkbook.SaveCopyAs Filename:=Range("FF1").Text & " Closing Sheet" & ".xls"
 
 
    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String
    Dim Flds As Variant
 
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
 
    iConf.Load -1
    Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "*****@Gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "*****"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Update
    End With
 
 
    With iMsg
        Set .Configuration = iConf
        .To = "*****@Gmail.com;******@Bellsouth.net"
        .CC = ""
        .BCC = ""
        .From = """*****"" <*******@gmail.com>"
        .Subject = "Closing Numbers"
        .TextBody = "Attached you will find the closing numbers from last night." & vbCrLf & _
        "" & vbCrLf & _
        "Thanks" & vbCrLf & _
        "" & vbCrLf & _
        "" & vbCrLf & _
        "Management" & vbCrLf & _
        "" & vbCrLf & _
        "This is a auto generated email, please do not reply."
        .AddAttachment "c:\Temp1\" & Range("FF1").Text & " Closing Sheet" & ".xls"
        .send
 
    Kill Range("FF1").Text & " Closing Sheet" & ".xls"
 
 
    ActiveWorkbook.Saved = True
    Application.Quit
 
   End With
End Sub