asked on

Macro and Email Macro for Excel

I have this excel spreadsheet that will be passed back and forth between my supplier and me. This list has consigned material and all we do is put in the date when material is pulled. I would like to set-up a macro that at the end of the day will send email of this form back to the supplier and will also send email to our AP department showing what material was pulled for the day. A simple click of the button. I am familiar with doing this in access, but not excel.

Any help would greatly be appreciated.

Thanks,
Glenn
Mursix-INV-2012-08-17.xls

ScriptAddict

Hey,

Here's some code you can attach to a command button. You'll need to be able to relay from your computer and have the SMTP connection information from you IT deparment.

This isn't a drop and use solution, but should be easily edited by someone familiar with VBA.

Function LastSheet()
  Dim i&
  For i = Sheets.Count To 1 Step -1
    If Sheets(i).Visible And TypeName(Sheets(i)) <> "Module" Then
      LastSheet = i
      ' MsgBox LastSheet
      Exit Function
      End If
  Next i
End Function



''Sheets("Master").Copy After:=Worksheets(Worksheets.Count)
''NewPageName = InputBox("What would you like to call your new Worksheet")
''ActiveWindow.ActiveSheet.Name = NewPageName
''Sheets("Master").Visible = False

Sub FindUsedRange()
     
    Dim Rng1            As Range
     
    Set Rng1 = RealUsedRange
    If Rng1 Is Nothing Then
        MsgBox "There is no used range, the worksheet is empty."
    Else
        MsgBox "The real used range is: " & Rng1.Address
    End If
     
End Sub
 
Public Function RealUsedRange() As Range
     
    Dim FirstRow        As Long
    Dim LastRow         As Long
    Dim FirstColumn     As Integer
    Dim LastColumn      As Integer
     
    On Error Resume Next
     
    FirstRow = Cells.Find(What:="*", After:=Range("IV65536"), LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).Row
     
    FirstColumn = Cells.Find(What:="*", After:=Range("IV65536"), LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext).Column
     
    LastRow = Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
     
    LastColumn = Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
     
    Set RealUsedRange = Range(Cells(FirstRow, FirstColumn), Cells(LastRow, LastColumn))
     
    On Error GoTo 0
     
End Function


Private Sub CommandButton2_Click()
Dim x As Range
Dim its As String
Dim email As String
Dim smtpresponse As String

smtpresponse = ""

'Prevent alerts from displaying to users
Me.Application.DisplayAlerts = False
'turns off screen updating for speed gains
Me.Application.ScreenUpdating = False

ews = Me.Application.Worksheets("Control Sheet").ComboBox1.Value

'determines the range to work with for loop
    FirstRow = Worksheets(ews).Range("M3:M65536").Find(What:="?", After:=Range("M65536"), LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).Row
    
     LastRow = Worksheets(ews).Range("M:M").Find(What:="?", After:=Range("M1"), LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'MsgBox Cells(FirstRow, 13).Address
'MsgBox Cells(LastRow, 13).Address
'MsgBox Range(Cells(FirstRow, 13), Cells(LastRow, 13)).Address

'MsgBox Worksheets(ews).Range(Range(Cells(FirstRow, 13), Cells(LastRow, 13)).Address).Address
For Each x In ThisWorkbook.Worksheets(ews).Range(Range(Cells(FirstRow, 13), Cells(LastRow, 13)).Address)
  
    If x.Value = "y" Or x.Value = "Y" Or x.Value = "yes" Or x.Value = "Yes" Or x.Value = "YES" Then
        Me.Application.Worksheets(ews).Activate
        Me.Application.Worksheets(ews).Cells(x.Row, 12).Select
        email = Selection.Value
        its = "<TR>"
        For i = 1 To 11
        Me.Application.Worksheets(ews).Cells(x.Row, i).Select
        its = its & "<TD>" & Selection.Text & "</TD>"
        Next i
        its = its & "</TR>"
        smtpresponse = smtpresponse & CDO_Mail_Small_Text(email, its)
        
        
    End If

Next
meh = CDO_Mail_Small_Text(Me.Application.Worksheets("Control Sheet").Range("D8").Value, smtpresponse)
Me.Application.Worksheets("Control Sheet").Activate
'Activates alerts displaying to users
Me.Application.DisplayAlerts = True
'turns on screen updating for speed gains
Me.Application.ScreenUpdating = True
meh = MsgBox("Your emails have been sent please check" & vbCr & _
        Me.Application.Worksheets("Control Sheet").Range("D8").Value & _
        " for your summary email", vbInformation, "Schedule Emails Have Been Sent")
End Sub


Function CDO_Mail_Small_Text(email As String, ttw As String)

On Error GoTo emailnotsent

    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String
    Debug.Print email
    Debug.Print ttw
    '    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/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") _
                           = "SMTP.server.com"
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "username"
            .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
            .Update
        End With
    
    'Prevent alerts from displaying to users
    Me.Application.DisplayAlerts = False
    'turns off screen updating for speed gains
    Me.Application.ScreenUpdating = False
    'allows us to see and work with the master worksheet
    Sheets("Master").Visible = True
    
    strbody = "" 'using html code in this is allowed.  It is sent as an HTML email.
              '"This is line 3" & vbNewLine & _
              '"This is line 4"

    With iMsg
        Set .Configuration = iConf
        .To = email
        .CC = ""
        .BCC = ""
        .From = """sender"" <sender@url.com>"
        .Subject = "blah " & Me.Application.Worksheets("Control Sheet").ComboBox1.Value
        .HTMLBody = strbody
        .Send
    End With
    
     Sheets("Master").Visible = False
    'Activates alerts displaying to users
    Me.Application.DisplayAlerts = True
    'turns on screen updating for speed gains
    Me.Application.ScreenUpdating = True
    CDO_Mail_Small_Text = ttw & "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;" & email & "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;" & "Sent"
    Exit Function
    
emailnotsent:
    CDO_Mail_Small_Text = ttw & "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;" & email & "&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;" & "<span style=""color:#FF0000""> Failed </span>"
    Sheets("Master").Visible = False
    'Activates alerts displaying to users
    Me.Application.DisplayAlerts = True
    'turns on screen updating for speed gains
    Me.Application.ScreenUpdating = True
    On Error GoTo 0
End Function

Open in new window

ASKER CERTIFIED SOLUTION

Steve

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Steve

The following code is a tad more involved than the envelope method:
I find that this is not too hard to modify, but can be a bit daunting if not farmiliar with VBA

Sub Mail_ActiveSheet()
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010
    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 Object
    Dim OutMail As Object

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

    Set Sourcewb = ActiveWorkbook

    ' Next, copy the sheet to a new workbook.
    ' You can also use the following line, instead of using the ActiveSheet object, 
   ' if you know the name of the sheet you want to mail : 
    ' Sheets("Sheet5").Copy 
    ActiveSheet.Copy
    Set Destwb = ActiveWorkbook

    ' Determine the Excel version, and file extension and format.
    With Destwb
        If Val(Application.Version) < 12 Then
            ' For Excel 2000-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            ' For Excel 2007-2010, exit the subroutine if you answer 
            ' NO in the security dialog that is displayed when you copy
            ' a sheet from an .xlsm file with macros disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "You answered 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

    ' You can use the following statements to change all cells in the 
   ' worksheet to values.
    '    With Destwb.Sheets(1).UsedRange
    '        .Cells.Copy
    '        .Cells.PasteSpecial xlPasteValues
    '        .Cells(1).Select
    '    End With
    '    Application.CutCopyMode = False

    ' Save the new workbook, mail, and then delete it.
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " _
                 & Format(Now, "dd-mmm-yy h-mm-ss")

    Set OutApp = CreateObject("Outlook.Application")
    
    Set OutMail = OutApp.CreateItem(0)

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, _
                FileFormat:=FileFormatNum
        On Error Resume Next
       ' Change the mail address and subject in the macro before 
       ' running the procedure.
        With OutMail
            .To = "ron@debruin.nl"
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line"
            .Body = "Hello World!"
            .Attachments.Add Destwb.FullName
            ' You can add other files by uncommenting the following statement.
            '.Attachments.Add ("C:\test.txt")
            ' In place of the following statement, you can use ".Display" to
            ' display the mail.
            .Send   
        End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With

    ' Delete the file after sending.
    Kill TempFilePath & TempFileName & FileExtStr

    Set OutMail = Nothing
    Set OutApp = Nothing

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

Open in new window