Signature to email

[JFredGoy]

Hi guys,

Hoping that you can help me with adding an outlook signature to the code. I have added it in the past using outlook to prompt (.display) method (from Rondebruin) which is the second part of the code however this method which was given to me by a consultant is different - it uses "[FONT=Verdana, Tahoma, Nimbus Sans L, sans-serif]ActiveWorkbook.EnvelopeVisible = True" which is new to me. It opens the email within excel and sends it off. I cannot for the life of me added the signature anywhere. And I noticed that there is no option to change .send to .display the email before it sends (as it prompts the mail security dialog box - which is annoying)
[/FONT]I am asking you guys as the consultant is off for a while..

    ' All variables must be defined explicitly, for speed and clarity.
    Option Explicit
    ' All arrays start at 1, unless otherwise defined.
    Option Base 1
    
    ' OPOs
    Private Const icAccountIdCol As Integer = 2
    Private Const icPurchIdCol As Integer = 4
    Private Const icStatusCol As Integer = 6
    Private Const icWarehouseCol As Integer = 7
    Private Const icPlacerCol As Integer = 9
    Private Const icApprover1Col As Integer = 10
    Private Const icLimit1Col As Integer = 11
    Private Const icApprover2Col As Integer = 12
    Private Const icLimit2Col As Integer = 13
    Private Const icAmountCol As Integer = 19
    '
    Private Const iOPOsFirstRow As Integer = 2
    
    ' Addresses
    Private Const icEAPersonIdCol As Integer = 1
    Private Const icEAAddressCol As Integer = 2
    
    ' Message
    Private Const icEM1SubjectRow As Integer = 4
    Private Const icEM1BodyRow As Integer = 8
    Private Const icEM2SubjectRow As Integer = 18
    Private Const icEM2BodyRow As Integer = 22
    
    ' Emails
    Private Const icToCol As Integer = 1
    Private Const icCCCol As Integer = 2
    Private Const icSubjectCol As Integer = 3
    Private Const icAttachCol As Integer = 4
    Private Const icBodyCol As Integer = 5
    Private Const icBlockingCol As Integer = 6
    '
    Private Const icEmailsFirstRow As Integer = 3
    
    Private iOPOsRow As Integer
    Private iEmailsRow As Integer
    
    Private bAddressNotFound As Boolean
    
' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =


Public Sub btnGenerate_Click()
    Dim sPathSep As String, sFolder As String, sAttach As String, iAttachRow As Integer
    Dim iOPOsLastRow As Integer, iEmailsLastRow As Integer, bOrder As Boolean, sCCPersonId As String
    Dim sPurchId As String, sPrevPurchId As String, sStatus As String, dAmount As Double
    Dim vSortCols As Variant, iToPass As Integer, sPersonId As String, sPrevPersonId As String
    Dim bCopy As Boolean, bCount As Boolean, iSubjectRow As Integer, iBodyRow As Integer
     Application.EnableEvents = False
     Application.ScreenUpdating = False
    bAddressNotFound = False
     With Sheet6
    iEmailsRow = .Cells(65536, icBodyCol).End(xlUp).Row
    If iEmailsRow >= icEmailsFirstRow Then
        .Range(.Rows(icEmailsFirstRow), .Rows(iEmailsRow)).Delete
    End If
    iEmailsRow = icEmailsFirstRow - 1
     End With
    '
     With Sheet7
    iAttachRow = .Cells(65536, 1).End(xlUp).Row
    If iAttachRow > 1 Then
        .Range(.Rows(2), .Rows(iAttachRow)).ClearContents
    End If
     End With
     sPathSep = Application.PathSeparator
    sFolder = ThisWorkbook.Path & sPathSep & "Attachments"
    ' previous attachments delete
'    If sPathSep = "\" Then
         On Error Resume Next  ' for doesn't exist
         sAttach = Dir(sFolder & sPathSep)
         On Error GoTo 0
         Do While sAttach > ""
             Kill sFolder & sPathSep & sAttach
             sAttach = Dir
         Loop
         On Error Resume Next  ' for already exists
        MkDir sFolder
         On Error GoTo 0
'    End If
     sFolder = sFolder & sPathSep
    
     Sheet7.Visible = True
     With Sheet3.ListObjects(1).Range
    iOPOsLastRow = .Rows(.Rows.Count).Row + 1
    vSortCols = Array(icPlacerCol, icApprover1Col, icApprover2Col)
     iAttachRow = 1
    For iToPass = 1 To 3
        .Sort Key1:=.Cells(iOPOsFirstRow, vSortCols(iToPass)) _
                , Key2:=.Cells(iOPOsFirstRow, icPurchIdCol), Header:=xlYes
         sPrevPersonId = ""
         sPersonId = ""
        For iOPOsRow = iOPOsFirstRow To iOPOsLastRow
            sPurchId = .Cells(iOPOsRow, icPurchIdCol).Value
            If sPurchId <> sPrevPurchId Then
                sStatus = .Cells(iOPOsRow, icStatusCol).Value
                
                 bCopy = False
                Select Case iToPass
                 Case Is = 1
                    Select Case sStatus
                     Case Is = "Initialize" _
                             , "Open Order"
                        sPersonId = .Cells(iOPOsRow, icPlacerCol).Value
                        If sPersonId <> sPrevPersonId Then
                            sAttach = "Placer_" & sPersonId
                            sCCPersonId = ""
                            iSubjectRow = icEM1SubjectRow
                            iBodyRow = icEM1BodyRow
                            bCount = True
                            bCopy = True
                        End If
                    Case Else
                        bCount = False
                    End Select
                    
                 Case Is = 2
                    If sStatus = "Waiting for Approval" _
                     And dAmount <= .Cells(iOPOsRow, icLimit1Col).Value Then  ' <=
                        sPersonId = .Cells(iOPOsRow, icApprover1Col).Value
                        If sPersonId <> sPrevPersonId Then
                            sAttach = "Approver1_" & sPersonId
                            sCCPersonId = .Cells(iOPOsRow, icPlacerCol).Value
                            iSubjectRow = icEM2SubjectRow
                            iBodyRow = icEM2BodyRow
                            bCount = True
                            bCopy = True
                        End If
                    Else
                        bCount = False
                    End If
                 Case Is = 3
                    If sStatus = "Waiting for Approval" _
                     And dAmount > .Cells(iOPOsRow, icLimit1Col).Value Then  ' >
                        sPersonId = .Cells(iOPOsRow, icApprover2Col).Value
                        If sPersonId <> sPrevPersonId Then
                            sAttach = "Approver2_" & sPersonId
                            sCCPersonId = .Cells(iOPOsRow, icPlacerCol).Value
                            iSubjectRow = icEM2SubjectRow
                            iBodyRow = icEM2BodyRow
                            bCount = True
                            bCopy = True
                        End If
                    Else
                        bCount = False
                    End If
                    
                End Select
                
                If dAmount > 0 Then
                    Sheet7.Cells(iAttachRow, 10).Value = dAmount
                    dAmount = 0
                End If
                If sPersonId <> sPrevPersonId _
                Or sPurchId = "" Then  ' sPurchId "" -> cleanup
                    If iAttachRow > 1 Then
                        'Sheet7.SaveAs sFolder & sAttach & ".xlsx"
                        Sheet7.Copy  ' to new book
                         ActiveWorkbook.SaveAs sFolder & sAttach & ".xlsx"
                         ActiveWorkbook.Close
                         With Sheet7
                        .Range(.Rows(2), .Rows(iAttachRow)).ClearContents
                         End With
                         iAttachRow = 1
                    End If
                    '
                    If sPurchId = "" Then  ' cleanup only
                    Else
                        iEmailsRow = iEmailsRow + 1
                        l1Address sPersonId, icToCol
                        If sCCPersonId > "" Then
                            l1Address sCCPersonId, icCCCol
                        End If
                        Sheet6.Cells(iEmailsRow, icSubjectCol).Value _
                                = Sheet5.Cells(iSubjectRow, 1).Value
                        Sheet6.Cells(iEmailsRow, icAttachCol).Value = sAttach
                         With Sheet6.Cells(iEmailsRow, icBodyCol)
                        .Value = Sheet5.Cells(iBodyRow, 1).Value
                         .WrapText = False
                         End With
                    End If
                     
                    sPrevPersonId = sPersonId
                End If
                
                If sPurchId = "" Then  ' cleanup only
                Else
                    If bCopy Then
                        iAttachRow = iAttachRow + 1
                        Sheet7.Cells(iAttachRow, 1).Value _
                                = Sheet3.Cells(iOPOsRow, icAccountIdCol).Value
                        Sheet7.Cells(iAttachRow, 2).Value _
                                = Sheet3.Cells(iOPOsRow, icPurchIdCol).Value
                        Sheet7.Cells(iAttachRow, 3).Value _
                                = Sheet3.Cells(iOPOsRow, icStatusCol).Value
                        Sheet7.Cells(iAttachRow, 4).Value _
                                = Sheet3.Cells(iOPOsRow, icWarehouseCol).Value
                        Sheet7.Cells(iAttachRow, 5).Value _
                                = Sheet3.Cells(iOPOsRow, icPlacerCol).Value
                        Sheet7.Cells(iAttachRow, 6).Value _
                                = Sheet3.Cells(iOPOsRow, icApprover1Col).Value
                        Sheet7.Cells(iAttachRow, 7).Value _
                                = Sheet3.Cells(iOPOsRow, icLimit1Col).Value
                        Sheet7.Cells(iAttachRow, 8).Value _
                                = Sheet3.Cells(iOPOsRow, icApprover2Col).Value
                        Sheet7.Cells(iAttachRow, 9).Value _
                                = Sheet3.Cells(iOPOsRow, icLimit2Col).Value
                        Sheet7.Cells(iAttachRow, 10).Value = 0
                        bCopy = False
                    End If
                End If
                
                sPrevPurchId = sPurchId
            End If
            
            If bCount Then
                dAmount = dAmount + .Cells(iOPOsRow, icAmountCol).Value
            End If
        Next
    Next
     End With
     Sheet7.Visible = False
    iEmailsLastRow = iEmailsRow
    
     Sheet6.Activate
'     Columns(icBodyCol).WrapText = False
    Cells(icEmailsFirstRow, 1).Select
    
    ' sends
    If bAddressNotFound Then
        MsgBox "At least one person does not have an email address." _
                & vbCr & vbCr & "Please add to the Email Addresses sheet, and re-Generate." _
                , Title:="Emails Generator"
        Range(Cells(icEmailsFirstRow, icBlockingCol), Cells(iEmailsLastRow, icBlockingCol)).Value _
                = " "
        Exit Sub
    End If
    For iEmailsRow = icEmailsFirstRow To iEmailsLastRow
         If Cells(iEmailsRow, icToCol).Interior.Color = 12040422 _
         Or Cells(iEmailsRow, icCCCol).Interior.Color = 12040422 Then  ' red
             GoTo Next_Email
         End If
        ActiveWorkbook.EnvelopeVisible = True
         With ActiveSheet.MailEnvelope.Item
        Range(Cells(iEmailsRow, icBodyCol), Cells(iEmailsRow, icBlockingCol)).Select  ' Body =
        .To = Cells(iEmailsRow, icToCol).Value
        If Cells(iEmailsRow, icCCCol).Value > "" Then
            .CC = Cells(iEmailsRow, icCCCol).Value
        Else
            .CC = " "
        End If
        .Subject = Cells(iEmailsRow, icSubjectCol).Value
         Do While .Attachments.Count > 0
             .Attachments(1).Delete
         Loop
        .Attachments.Add sFolder & Cells(iEmailsRow, icAttachCol).Value & ".xlsx"
        .Send
         End With
        ActiveWorkbook.EnvelopeVisible = False
Next_Email:
    Next
    Range(Cells(icEmailsFirstRow, icBlockingCol), Cells(iEmailsLastRow, icBlockingCol)).Value _
            = " "
    
     Application.ScreenUpdating = True
     Application.EnableEvents = True
End Sub


Private Sub l1Address(ByVal sPersonId As String, ByVal iAddressCol As Integer)
    Dim oCell_Address As Range, bFound As Boolean
    Set oCell_Address = Sheet4.Columns(icEAPersonIdCol).Find(sPersonId, LookAt:=xlWhole)
    If oCell_Address Is Nothing Then
        bFound = False
    ElseIf oCell_Address.Address = "$A$1" Then  ' for Within Workbook
        bFound = False
    Else
        bFound = True
    End If
    If bFound Then
        Sheet6.Cells(iEmailsRow, iAddressCol).Value = oCell_Address.Offset(, 1).Value
    Else
         With Sheet6.Cells(iEmailsRow, iAddressCol)
        .Value = sPersonId
        .Interior.Color = 12040422  ' red
         End With
        bAddressNotFound = True
    End If
End Sub

'****************************************

'signature
    Dim SigString As String
    Dim Signature As String


    MailTo = Worksheets("Email Dist.").Range("b2:b2") 'modify range of emails to send to:
    CopyTo = Worksheets("Email Dist.").Range("b3:b3") 'modify range of emails to cc:
    SubjectEmail = Worksheets("Email Dist.").Range("b4:b4") 'subject of email
    EmailBody1 = Worksheets("Email Dist.").Range("b5:b5")
    EmailBody2 = Worksheets("Email Dist.").Range("b6:b6")
    EmailBody3 = Worksheets("Email Dist.").Range("b7:b7")
    EmailBody4 = Worksheets("Email Dist.").Range("b8:b8")
    EmailBody5 = Worksheets("Email Dist.").Range("b9:b9")
    EmailBody0 = EmailBody1 & EmailBody2 & EmailBody3 & EmailBody4
    EmailBody00 = EmailBody5
    


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


    SigString = "Z:\Signature\MySignature.htm"
     
     If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If


    On Error Resume Next
    
    With outMail
        .To = MailTo
        .CC = CopyTo
        .BCC = ""
        .Subject = SubjectEmail
        .HTMLBody = EmailBody0 & _
                    "<A HREF=""file://" & ActiveWorkbook.FullName & _
                    """>Daily Report</A>" & "" & _
                    "" & EmailBody00 & Signature
       .Display True  'or use .Send - using send prompts an authorization to send emails from excel, better to use display to see the email and send out. much faster as well
        
    End With
    On Error GoTo 0


    Set outMail = Nothing
    Set OutApp = Nothing
    MsgBox "Email Sent"
End Sub
Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function