Fill in recipient of email in Outlook

[cheddarthief]

Is there a way to add code to the existing code that will populate the "To" area in an Outlook email directly from source information located within the worksheet being sent?

Sub MailSheet()
    Dim shtName As String
    shtName = ActiveSheet.Name
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs Filename:=Application.GetSaveAsFilename("Request for Quote " & shtName, "Microsoft Excel File, *.xls")
    Application.DisplayAlerts = False
    Application.Dialogs(xlDialogSendMail).Show
    With ActiveWorkbook
        .ChangeFileAccess xlReadOnly
        Kill .FullName
        .Close False
    End With
     
    Application.DisplayAlerts = True
End Sub

[Leith Ross]

Hello cheddarthief,

Here is the revised macro. It uses cell "A1" as the TO address. You can change this to whichever cell you will be using.

Sub MailSheet()

  Dim FileName As String
  Dim olApp As Object
  Dim shtName As String
  
    shtName = ActiveSheet.Name
    
    FileName = Application.GetSaveAsFilename("Request for Quote " & shtName, "Microsoft Excel File, *.xls")
    If FileName = "False" Then Exit Sub
    
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs FileName
    
    Set olApp = CreateObject("Outlook.Application")
    
      With olApp.CreateItem(0)
        .To = Range("A1")
        .Subject = "Request for Quote"
        .Body = ""
        .Attachments.Add FileName, 1
        .Display
      End With
    
Cleanup:
      ActiveWorkbook.Close False
      Kill FileName
    
End Sub

[cheddarthief]

Leith,
Thank you so much for your help. I can't tell you how valuable this is to me. As you can see from my code below, I was able to take what you gave me and through some trial and error rewrite a few small things to better suite my needs. I have two small questions. 1.) Is there a way to skip the "Save As" screeen? 2.)You probably notice that in the ".Body" (super cool of you to add those extra items by the way) I was able to add some custom text that I always add to my email. Could I further that by basically doing what equates to (2) <returns> and then insert my name or better yet my signature? You've been super helpful already and if this is too much work, feel free to decline. Thanks again.

Sub MailSheet()

  Dim FileName As String
  Dim olApp As Object
  Dim shtName As String
  
    shtName = ActiveSheet.Name
    proName = Range("C17") & "-Ref" & Range("C18")
    
    FileName = Application.GetSaveAsFilename("RFQ-" & proName, "Microsoft Excel File, *.xls")
    If FileName = "False" Then Exit Sub
    
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs FileName
    
    Set olApp = CreateObject("Outlook.Application")
    
      With olApp.CreateItem(0)
        .To = Range("C16")
        .Subject = "Request for Quote-" & Range("C17") & "-Ref" & Range("C18")
        .Body = "Please see the attached RFQ."
        .Attachments.Add FileName, 1
        .Display
      End With
    
Cleanup:
      ActiveWorkbook.Close False
      Kill FileName
    
End Sub

[Leith Ross]

Hello cheddarthief,

The "body" can be changed to include the new line characters and your signature. Is your signature plain text or do you have an Outlook signature saved?

[cheddarthief]

I have an Outlook Signature that is saved. I would like to use that if possible. BTW, did you see my question about "save as"?

You have been extremely helpful.

Jim

[Leith Ross]

Hello cheddarthief,

Yes, I did see that part and that is correctable as well. What is the name of the signature file you want to use?

[cheddarthief]

Hello cheddarthief,

Yes, I did see that part and that is correctable as well. What is the name of the signature file you want to use?

Leith,
I'm not sure if you are asking for the file name that holds the signature or just the "signature for new messages" or "signature for replies and forwards". When I view it via the options window the signature is called "James J. Bender".

Does that help?

Jim

[Leith Ross]

Hello cheddarthief,

I can work with that.

[Leith Ross]

Hello cheddarthief,

Finally got this finished. Way too many phone calls this afternoon. This will check for either an HTML or plain text signature file. If both exist then the HTML version will be used.

'Written: April 07, 2010
'Updated: April 08, 2010
'Author:  Leith Ross
'Summary: Email the ActiveSheet as an attachment using Outlook


Sub EmailSheetAsAttachment()

  Dim BodyType As Integer
  Dim FileName As String
  Dim HtmlMsg As String
  Dim olApp As Object
  Dim shtName As String
  Dim SigFile As String
  Dim Signature As String
  Dim SigPath As String
  Dim TextMsg As String
  Dim TextFile As Object
  Dim WshShell As Object
  
    TextMsg = "Please see the attached RFQ."
    HtmlMsg = "<H3>" & TextMsg & "</H3>"
  
    SigFile = "James J. Bender"
    
      Set FSO = CreateObject("Scripting.FileSystemObject")
    
      Set WshShell = CreateObject("WScript.Shell")
    
      SigPath = WshShell.SpecialFolders("Desktop")
      SigPath = Left(SigPath, Len(SigPath) - 8) & "\Application Data\Microsoft\Signatures\"
      SigFile = SigPath & SigFile
    
        If Dir(SigFile & ".htm") <> "" Then
          SigFile = SigFile & ".htm"
          BodyType = 1
        Else
          If Dir(SigFile & ".txt") <> "" Then
            SigFile = SigFile & ".txt"
            BodyType = 0
          Else
            SigFile = ""
          End If
        End If
    
        If SigFile <> "" Then
          Set TextFile = FSO.OpenTextFile(SigFile, 1, False, -2)
            Signature = TextFile.ReadAll
          TextFile.Close
        End If
    
        shtName = ActiveSheet.Name
      
        FileName = "RFQ-" & Range("C17") & "-Ref" & Range("C18")

        ActiveSheet.Copy
        ActiveWorkbook.SaveAs FileName
    
        Set olApp = CreateObject("Outlook.Application")
    
        With olApp.CreateItem(0)
          .To = Range("C16")
          .Subject = "Request for Quote-" & Range("C17") & "-Ref" & Range("C18")
            Select Case BodyType
              Case 0
                .Body = TextMsg & vbCrLf & vbCrLf & Signature
              Case 1
                .HTMLBody = HtmlMsg & "<BR><BR>" & Signature
            End Select
          .Attachments.Add FileName, 1
          .Display
        End With
    
Cleanup:
    ActiveWorkbook.Close False
    Kill FileName
    Set FSO = Nothing
    Set WshShell = Nothing
      
End Sub

[cheddarthief]

Leith,
I copied the macro into my workbook and something is not working correctly. The new workbook is created and the file name is created correctly but at that point there is a break in the macro that prompt the error: "File not found". My thought is that the file the error is referring to is the Signature file. I say this because during my earlier macro adventures when I would try and insert my signature into the email, it was not one that was available. For some reason the only available signature was some sort of Admin that referrs back to my company. Do I need to put a copy of my signature somewhere the macro can find it?

Jim

[Leith Ross]

Hello Jim,

When you create a signature file in Outlook, it is stored on your hard drive to a predetermined location. On Windows 2000 through 2007, that location is generally: C:\Documents and Settings\<user>\Application Data\Microsoft\Signatures.

If your signature file is located elsewhere then the macro will need to know that new location. Also, if you are using VIsta, the default folder location is different than above.

[cheddarthief]

Leith,
My signature is located there but something is still not working. Actually, it doesn't need to go to my physical signature saved somewhere since that seems to be causing a problem. If the body of the email could just say "Please see attached RFQ." then a [return] and my name "James J. Bender" that would be fine. But there is one more issue. When I copy the first worksheet and make a change to cell (C18) then try to email that sheet, the macro is still picking up the information in the original sheet and not the new one. For example:

The first sheet has the folowing values: C17=PENNDOT 29919 and C18=5056-0100. So the created new file per the macro is called RFQ-PENNDOT 29919-Ref5056-0100.xls

The second sheet has the following values: C17=PENNDOT 29919 and C18=5020-0002. So the created new file per the macro should be called RFQ-PENNDOT 29919-Ref5020-0002.xls but instead it's giving it the same file name as the first worksheet.

Not sure what's happening there. Any ideas?

Jim Bender

[Leith Ross]

Hello Jim,'

I need to change the macro to work with the ActiveSheet and change the signature portion of the code as well. I have to go out for a while but will return in about an hour.

[Leith Ross]

Hello Jim,

Got back and took a look at the signature file problem. Th Dir function will only find the signature file if it is a literal string (full file path in double quotes). It will not find the file if it is in a string variable or in a variant variable. I overcame this problem by using the Shell.Application object to retrieve the file. So, long story short everything should be working 100%. Here is the updated macro...

'Written: April 07, 2010
'Updated: April 09, 2010
'Author:  Leith Ross
'Summary: Email the ActiveSheet as an attachment using Outlook


Sub EmailSheetAsAttachemnt()

  Dim BodyType As Integer
  Dim FileName As String
  Dim HtmlMsg As String
  Dim olApp As Object
  Dim oShell As Object
  Dim oShellFolder As Object
  Dim oShellFolderItem As Object
  Dim shtName As String
  Dim SigFile As Variant
  Dim Signature As String
  Dim SigPath As Variant
  Dim TextMsg As String
  Dim TextFile As Object
  Dim WshShell As Object
  
    TextMsg = "Please see the attached RFQ."
    HtmlMsg = "<H3>" & TextMsg & "</H3>"
  
    SigFile =  "James J. Bender"
    
      Set WshShell = CreateObject("WScript.Shell")
        SigPath = WshShell.SpecialFolders("Desktop")
        SigPath = Left(SigPath, Len(SigPath) - 8) & "\Application Data\Microsoft\Signatures\"
      Set WshShell = Nothing
      
        Set oShell = CreateObject("Shell.Application")
        Set oShellFolder = oShell.Namespace(SigPath)
        
        If Not oShellFolder Is Nothing Then
          Set oShellFolderItem = oShellFolder.ParseName(SigFile & ".htm")
          If Not oShellFolderItem Is Nothing Then
            SigFile = SigFile & ".htm": BodyType = 1
          End If
        
          Set oShellFolderItem = oShellFolder.ParseName(SigFile & ".txt")
          If Not oShellFolderItem Is Nothing Then
            SigFile = SigFile & ".txt": BodyType = 0
          Else
            SigFile = ""
          End If
        End If
    
        If SigFile <> "" Then
          Set FSO = CreateObject("Scripting.FileSystemObject")
            Set TextFile = FSO.OpenTextFile(SigPath & SigFile, 1, False, -2)
              Signature = TextFile.ReadAll
            TextFile.Close
          Set FSO = Nothing
        End If
    
        FileName = "RFQ-" & Range("C17") & "-Ref" & Range("C18") & ".xls"

        ActiveSheet.Copy
        ActiveWorkbook.SaveAs FileName
    
        Set olApp = CreateObject("Outlook.Application")
    
        With olApp.CreateItem(0)
          .To = Range("C16")
          .Subject = "Request for Quote-" & Range("C17") & "-Ref" & Range("C18")
            Select Case BodyType
              Case 0
                .Body = TextMsg & vbCrLf & vbCrLf & Signature
              Case 1
                .HTMLBody = HtmlMsg & "<BR><BR>" & Signature
            End Select
          .Attachments.Add CurDir & "\" & FileName, 1
          .Display
        End With
    
Cleanup:
    ActiveWorkbook.Close False
    Kill FileName
    Set olApp = Nothing
    Set obShell = Nothing
    Set oShellFolder = Nothing
    Set oShellFolderItem = Nothing
    
End Sub

[cheddarthief]

I wish I could say that worked, or event that I knew what it all meant but now I'm getting an error in a Microsoft Visual Basic box. The error reads: "Compile error: Invalid Outside Procedure"

The macro looked good it's just not working. Should I attach a copy of the actual Excel file to the link?

Jim

[Leith Ross]

Hello Jim,

That would help.

[cheddarthief]

Did you test this in the actual Excel file? It's still using the first worksheet information for ALL email recipients. Just to confirm, go to the first sheet "QUOTE-MILL-STRUCTURAL" and delete the company name from the drop down list. This should clear out all the other information except for the project and ref. Now run the macro and it should generate only enough emails to match the number of worksheets you have emails populated in the C16 cell. Then, go to each email and open the actual file that was attached to the email. All of the emails will not have information in the company profile area because you don't have any in the first worksheet. If that DOESN'T happen, then I've done something wrong on my side so please just upload the actual Excel file and I'll run it here again. Thanks.

The good news is that you took care of the empty cell variant you referred to in your previous update.

Jim

[Leith Ross]

Hello Jim,

Here is the file I used for the test. It is your file with all the email addresses on the Contacts worksheet set to my own for testing. This includes the macro.

'Written: April 07, 2010
'Updated: April 13, 2010
'Author:  Leith Ross
'Summary: Email the ActiveSheet as an attachment using Outlook and attach a signature
'         if either a TXT or HTML signature file exists. The HTML file will be used first
'         when present.

Sub EmailSheetAsAttachemnt()

  Dim BodyType As Integer
  Dim FileName As String
  Dim HtmlMsg As String
  Dim olApp As Object
  Dim oShell As Object
  Dim oShellFolder As Object
  Dim oShellFolderItem As Object
  Dim Recipient As Variant
  Dim shtName As String
  Dim SigFile As Variant
  Dim Signature As String
  Dim SigPath As Variant
  Dim TextMsg As String
  Dim TextFile As Object
  Dim Wks As Worksheet
  Dim WshShell As Object
  
    TextMsg = "Please see the attached RFQ."
    HtmlMsg = "<H3>" & TextMsg & "</H3>"
  
    SigFile = "James J. Bender"
    
     'Find the Signatures folder
      Set WshShell = CreateObject("WScript.Shell")
        SigPath = WshShell.SpecialFolders("Desktop")
        SigPath = Left(SigPath, Len(SigPath) - 8) & "\Application Data\Microsoft\Signatures\"
      Set WshShell = Nothing
      
       'Use the Shell to locate the Signature files
        Set oShell = CreateObject("Shell.Application")
        Set oShellFolder = oShell.Namespace(SigPath)
        
        If Not oShellFolder Is Nothing Then
         'Look for an HTML Signature file
          Set oShellFolderItem = oShellFolder.ParseName(SigFile & ".htm")
          If Not oShellFolderItem Is Nothing Then
            SigFile = SigFile & ".htm": BodyType = 1
          End If
        
         'Look for a Plain Text Signature file
          Set oShellFolderItem = oShellFolder.ParseName(SigFile & ".txt")
          If Not oShellFolderItem Is Nothing Then
            SigFile = SigFile & ".txt": BodyType = 0
          Else
            SigFile = ""
          End If
        End If
    
       'Read the Signature file if found
        If SigFile <> "" Then
          Set FSO = CreateObject("Scripting.FileSystemObject")
            Set TextFile = FSO.OpenTextFile(SigPath & SigFile, 1, False, -2)
              Signature = TextFile.ReadAll
            TextFile.Close
          Set FSO = Nothing
        End If
    
    
     'Start Outlook
      Set olApp = CreateObject("Outlook.Application")
     
       'Email only the visible worksheets
        For Each Wks In Worksheets
        
          If Wks.Visible = xlSheetVisible Then
         'Check that the recipient cell is not an empty string or formula error
          Recipient = Wks.Range("C16")
            If VarType(Recipient) <> 0 And VarType(Recipient) <> 10 Then
            
              FileName = "RFQ-" & Wks.Range("C17") & "-Ref" & Wks.Range("C18") & ".xls"

             'Save the Active Worksheet as a new workbook
              ActiveSheet.Copy
              ActiveWorkbook.SaveAs FileName
               
               'Email the Worksheet as an attachment
                  With olApp.CreateItem(0)
                    .To = Recipient
                    .Subject = "Request for Quote-" & Wks.Range("C17") & "-Ref" & Wks.Range("C18")
                      Select Case BodyType
                        Case 0
                          .Body = TextMsg & vbCrLf & vbCrLf & Signature
                        Case 1
                          .HTMLBody = HtmlMsg & "<BR><BR>" & Signature
                      End Select
                    .Attachments.Add CurDir & "\" & FileName, 1
                    .Display
                  End With
               
              X = Range("A1").Parent.Name
              Y = "Request for Quote-" & Wks.Range("C17") & "-Ref" & Wks.Range("C18")
              ActiveWorkbook.Close False
              Kill FileName
  
            End If
          End If
        Next Wks
        
Cleanup:
   'Free the objects and memory
    Set olApp = Nothing
    Set obShell = Nothing
    Set oShellFolder = Nothing
    Set oShellFolderItem = Nothing
    
End Sub

[cheddarthief]

Leith,
Here is what I see that is happening. You can confirm on your side. The macro is in fact creating the file name correctly for each email, attaching it to the corresponding emails and filling the body of the email as requested. The problem is that the content of those files is the same for every email. Which ever worksheet is the "active" worksheet at the time the macro is run happens to be the information in all the email attachments. If I had one worksheet and needed to send that same sheet to 50 people that would be great. But I have individual worksheets all with different information that need to go to their corresponding individuals noted in cell C16 of each worksheet. I hope that is clear to understand as I'm not always so good at explaining things when I don't possess the vocabulary needed. Also, it appears as though for the first time the workbooks created for the emails now have the actual macro attached to them. This didn't happen before so I'm not sure what changed in the code. If I try to send an email with an Excel worksheet that actually has a macro attached to it, most company firewalls will block it worrying about viruses.

Jim

[Leith Ross]

Hello Jim,

The problem seems to be the Formulas. When the sheet is copied all the formulas and their references are copied to the new worksheet in the new workbook. I need to make some adjustments to the macro to prevent this. The emailed version will be a "picture" of the actual quote. This should remove the problems.

[cheddarthief]

Leith,
Are you referring to an embedded "picture" of the actual quote in the body of the email vs an attachment? If so, I can't do that. My vendors need the form in Excel format so that they can fill in the values requested and return.

Jim

[cheddarthief]

Leith,
Don't worry about making any changes. I was able to "trim some of the fat" out of the code to get it to do the bare minimum. I will just have to open each worksheet and run the macro for each sheet but at least I won't have to save it, open Outlook, attach it, fill in the subject line, etc. each time. Thank you so much for your help. You have been awesome.

Jim

P.S. I attached my final code in case you're curious.

Sub EmailSheetAsAttachemnt()

  Dim FileName As String
  Dim olApp As Object
  Dim shtName As String
  Dim TextMsg As String
  
    TextMsg = "Please see the attached RFQ." & vbLf & vbLf & "James J. Bender"
  
        FileName = "RFQ-" & Range("C17") & "-Ref" & Range("C18") & ".xls"

        ActiveSheet.Copy
        ActiveWorkbook.SaveAs FileName
    
        Set olApp = CreateObject("Outlook.Application")
    
        With olApp.CreateItem(0)
          .To = ActiveSheet.Range("C16")
          .Subject = "Request for Quote-" & Range("C17") & "-Ref" & Range("C18")
          .Body = TextMsg
          .Attachments.Add CurDir & "\" & FileName, 1
          .Display
        End With
    
Cleanup:
    ActiveWorkbook.Close False
    Kill FileName
    Set olApp = Nothing
    
End Sub