Email from Excel will not work - why?

[stuu3270]

Hi, Bear with me, for some reason the formatting in this post doesn't work...I have this code that I am experimenting with (from a well known resource). I get it to work on my home PC but not at work. Home is Office 2007 or Office 10. Work is Excel 2003 and Outlook 2003.

Option Explicit'Ensure that you select the Microsoft Outlook X.0 Object Library in the references'Outlook needs to be loaded, and account logged inSub CallMailer()        Dim lngLoop As Long 'Programming ethics 1. Always start your first line after leaving a line space, and 1 indentation level        With ActiveSheet        For lngLoop = 2 To .Cells(Rows.Count, 1).End(xlUp).Row ' Programming ethics 3. Always indent your loops, case statements and with constructors            Call SendMessage(strTo:=.Cells(lngLoop, 1).Value, strCC:=.Cells(lngLoop, 2).Value, strBCC:=.Cells(lngLoop, 7).Value, strMessage:=.Cells(lngLoop, 8).Value, strSubject:=.Cells(lngLoop, 3).Value, strAttachmentPath:=.Cells(lngLoop, 6).Value, rngToCopy:=.Cells(lngLoop, 9))        Next lngLoop    End With 'Programming ethics 2. Always end your last line leaving a line space before ending the sub or function, and having indendation level of 1    End Sub Sub SendMessage(strTo As String, Optional strCC As String, Optional strBCC As String, Optional strSubject As String, Optional strMessage As String, Optional strAttachmentPath As String, Optional rngToCopy As Range, Optional blnShowEmailBodyWithoutSending As Boolean = True)    Dim objOutlook As Outlook.Application    Dim objOutlookMsg As Outlook.MailItem    Dim objOutlookRecip As Outlook.Recipient    Dim objOutlookAttach As Outlook.Attachment    If Trim(strTo) & Trim(strCC) & Trim(strBCC) = "" Then        MsgBox "Please provide a mailing address!", vbInformation + vbOKOnly, "Missing mail information"        Exit Sub    End If    ' Create the Outlook session.    On Error Resume Next    Set objOutlook = GetObject(, "Outlook.Application")    Err.Clear: On Error GoTo -1: On Error GoTo 0    If objOutlook Is Nothing Then        Set objOutlook = CreateObject("Outlook.Application")    End If    ' Create the message.    Set objOutlookMsg = objOutlook.CreateItem(olMailItem)    With objOutlookMsg        ' Add the To recipient(s) to the message.        If Trim(strTo) <> "" Then            Set objOutlookRecip = .Recipients.Add(strTo)            objOutlookRecip.Type = olTo        End If                ' Add the CC recipient(s) to the message.        If Trim(strCC) <> "" Then            Set objOutlookRecip = .Recipients.Add(strCC)            objOutlookRecip.Type = olCC        End If       ' Add the BCC recipient(s) to the message.       If Trim(strBCC) <> "" Then            Set objOutlookRecip = .Recipients.Add(strBCC)            objOutlookRecip.Type = olBCC        End If       ' Set the Subject, Body, and Importance of the message.       If strSubject = "" Then            strSubject = ""       End If       .Subject = strSubject       If strMessage = "" Then            strMessage = "This is the body of the message." & vbCrLf & vbCrLf       End If       .Importance = olImportanceNormal  'Normal importance       If Not strMessage = "" Then        .Body = strMessage & vbCrLf & vbCrLf       End If       If Not rngToCopy Is Nothing Then        .HTMLBody = .Body & RangetoHTML(rngToCopy)       End If       ' Add attachments to the message.       If Not IsMissing(strAttachmentPath) Then            If Len(Dir(strAttachmentPath)) <> 0 Then                Set objOutlookAttach = .Attachments.Add(strAttachmentPath)            Else                MsgBox "Unable to find the specified attachment. Sending mail anyway."            End If       End If       ' Resolve each Recipient's name.       For Each objOutlookRecip In .Recipients           objOutlookRecip.Resolve       Next       ' Should we display the message before sending?       If blnShowEmailBodyWithoutSending Then           .Display       Else           .Save           .Send       End If    End With        Set objOutlook = Nothing    Set objOutlookMsg = Nothing    Set objOutlookAttach = Nothing    Set objOutlookRecip = Nothing    End SubFunction RangetoHTML(rng As Range)' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.    Dim fso As Object    Dim ts As Object    Dim TempFile As String    Dim TempWB As Workbook    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"     ' Copy the range and create a workbook to receive the data.    rng.Copy    Set TempWB = Workbooks.Add(1)    With TempWB.Sheets(1)        .Cells(1).PasteSpecial Paste:=8        .Cells(1).PasteSpecial xlPasteValues, , False, False        .Cells(1).PasteSpecial xlPasteFormats, , False, False        .Cells(1).Select        Application.CutCopyMode = False        On Error Resume Next        .DrawingObjects.Visible = True        .DrawingObjects.Delete        On Error GoTo 0    End With     ' Publish the sheet to an .htm file.    With TempWB.PublishObjects.Add( _         SourceType:=xlSourceRange, _         Filename:=TempFile, _         Sheet:=TempWB.Sheets(1).Name, _         Source:=TempWB.Sheets(1).UsedRange.Address, _         HtmlType:=xlHtmlStatic)        .Publish (True)    End With     ' Read all data from the .htm file into the RangetoHTML subroutine.    Set fso = CreateObject("Scripting.FileSystemObject")    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)    RangetoHTML = ts.ReadAll    ts.Close    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _                          "align=left x:publishsource=")     ' Close TempWB.    TempWB.Close savechanges:=False     ' Delete the htm file.    Kill TempFile     Set ts = Nothing    Set fso = Nothing    Set TempWB = Nothing    End Function

When I run this at work I get an error telling me that: "Compile Error, cannot find project library" and the line:

Sub SendMessage(strTo As String, Optional strCC As String, Optional strBCC As String, Optional strSubject As String, Optional strMessage As String, Optional strAttachmentPath As String, Optional rngToCopy As Range, Optional blnShowEmailBodyWithoutSending As Boolean = True)

is highlighted in yellow with the next line down:

objOutlook As Outlook.Application

is highlighted in blue.Any ideas why it won't work? Anything to do with the reference library? Microsoft Office 11.0 Object Library is ticked, as is "MISSING Microsoft Outlook 14.0 Object Library"Any thoughts??Stu

 

[shyy]

Go to VBA environment (Alt + F11), click Tools - Referecnes and make sure Microsoft OFfice Object library is checked. Hope it works.

 

[stuu3270]

Problem solved. I think I did that already, not sure, but I did remove the tick against the missing reference then it seems to work.Thanks.Next question... How can I tell the function to copy across a range or whole sheet from within the same workbook? Is it a simple change; I cannot figure it out.Stu

 

[shyy]

maybe something like

.Body = Range("A1:C1").Value

?

 

[stuu3270]

Shyy,Thanks, I think its in here somewhere that I need to change this

  With ActiveSheet        For lngLoop = 2 To .Cells(Rows.Count, 1).End(xlUp).Row ' Programming ethics 3. Always indent your loops, case statements and with constructors            Call SendMessage(strTo:=.Cells(lngLoop, 1).Value, strCC:=.Cells(lngLoop, 2).Value, strBCC:=.Cells(lngLoop, 7).Value, strMessage:=.Cells(lngLoop, 8).Value, strSubject:=.Cells(lngLoop, 3).Value, strAttachmentPath:=.Cells(lngLoop, 6).Value, rngToCopy:=.Cells(lngLoop, 9))        Next lngLoop    End With 'Programming ethics 2. Always end your last line leaving a line space before ending the sub or function, and having indendation level of 1    End Sub Sub SendMessage(strTo As String, Optional strCC As String, Optional strBCC As String, Optional strSubject As String, Optional strMessage As String, Optional strAttachmentPath As String, Optional rngToCopy As Range, Optional blnShowEmailBodyWithoutSending As Boolean = True)

but I can't get it to work with my limited knowledge. The range to copy across in this code is column I in sheet 1 . What I want copied across into the email is either anything visible in sheet2 or only what I select in sheet2, eg: B2:L20.I am reserving the body for a predetermined message at the top before the data which is pasted below.Stu

 

[James Snyder]

If you are looking for the specific ability to copy an active range that is visible, do something like this:\

Dim bRange As Range
Dim aSheet As WorkSheet

Set bRange = .Range("A1:" & colMax & rowMax)
...filter or .find or .select here...
bRange.SpecialCells(xlCellTypeVisible).Copy
aSheet.Paste   '<---- should be .Body - brain seems to be on vacation,m but forgot to take me...

If you want to copy the selected range, replace the .SpecialCells with .ActiveRange. Note that this is pseudocode and needs a lot more than what is here.

 

[stuu3270]

Still formatting doesn't work, sorry...To make it simpler, this code from Ron De Buin (not sure if I have that right) may be better, if I could work out how to tell it to send Sheet2 or a selection of it.I also want to email all addresses found in a row of sheet one and an attachment, the address of which can be found in a cell on sheet1, where the data will be kept. I cannot attach a file from here but to summarise:Sheet one holds data in rows, populated from a userform.a column will hold email addresses of the people whose data is held, names, address and so on. Let's say the email addresses are column A:A. Column B:B holds a path to a file, C:C holds the file name, D:D combines the two for the full path of the attached file.Sheet2 has all this data copied across to specific cells that are formatted. What is visible on sheet2 needs to be copied into the body of the email under the introductory text.I hope somebody can help...

Option ExplicitSub Send_Selection_Or_ActiveSheet_with_MailEnvelope()'Working in Excel 2002-2013    Dim Sendrng As Range    On Error GoTo StopMacro    With Application        .ScreenUpdating = False        .EnableEvents = False    End With    'Note: if the selection is one cell it will send the whole worksheet    Set Sendrng = Selection    'Create the mail and send it    With Sendrng        ActiveWorkbook.EnvelopeVisible = True        With .Parent.MailEnvelope            ' Set the optional introduction field thats adds            ' some header text to the email body.            .Introduction = "Introdutcion line of text."            With .Item                .To = ""                .CC = ""                .BCC = ""                .Subject = "Data"                .Display            End With        End With    End WithStopMacro:    With Application        .ScreenUpdating = True        .EnableEvents = True    End With    ActiveWorkbook.EnvelopeVisible = TrueEnd Sub