Default Signature new outlook current user

[duplaly]

I'm trying to adapt this code from (Ron de Bruin) which allows me to insert my signature in emails.

How can I modify it so that any user's signature can be inserted in emails. I'm working on a multi-user project.

I'm in the process of converting my codes so that I can use the new Outlook.

Thanks for any help!

Note : You only have to change the mail address and name of your signature file before you run the code

Sub Mail_Outlook_With_Signature_Html_2()
' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2016
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim SigString As String
    Dim Signature As String

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

    strbody = "<H3><B>Dear Customer Ron de Bruin</B></H3>" & _
              "Please visit this website to download the new version.<br>" & _
              "Let me know if you have problems.<br>" & _
              "<A HREF=""/rdb/tips.htm"">Ron's Excel Page</A>" & _
              "<br><br><B>Thank you</B>"

    'Change only Mysig.htm to the name of your signature
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\Mysig.htm"

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

    On Error Resume Next

    With OutMail
        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = strbody & "<br>" & Signature
        .Send    'or use .Display
    End With

    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
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

 

[gemma-the-husky]

We think you may not be able to automate Outlook with the new Outlook. Currently outlook may include the code that integrated access apps, but we think new outlook will eventually remove that code, and then you won't be able to use your code.

We aren't sure how MS intends to fix that?

Are you just actually talking about pasting a small png file of the signature into an email?

I've never done that, and don't know.

 

[Gasman]

I thought New outlook did not work with VBA?

Each user would need that signature file called by a common name in that location, currently mysig.htm

 

[duplaly]

We think you may not be able to automate Outlook with the new Outlook. Currently outlook may include the code that integrated access apps, but we think new outlook will eventually remove that code, and then you won't be able to use your code.

We aren't sure how MS intends to fix that?

Are you just actually talking about pasting a small png file of the signature into an email?

I've never done that, and don't know.

Hi
I want to add text signature to emails.
Thank you!

 

[arnelgp]

change GetBoliler() function to:

Private Function GetBoiler(sigName As String) As String
' arnelgp
'
' sigName should include the .htm extension
'
    Dim appDataDir  As String
    Dim sig         As String
    Dim sigPath     As String
    Dim fileName    As String
    appDataDir = Environ$("APPDATA") & "\Microsoft\Signatures"
    sigPath = appDataDir & "\" & sigName
    If Len(Dir$(sigPath)) = 0 Then Exit Function
    With CreateObject("Scripting.FileSystemObject")
        sig = .OpenTextFile(sigPath).ReadAll
    End With
    ' fix relative references to images, etc. in sig
    ' by making them absolute paths, OL will find the image
    fileName = Replace$(sigName, ".htm", "_files/")
    sig = Replace$(sig, fileName, appDataDir & "\" & fileName)
    GetBoiler= sig
End Function

 

[duplaly]

change GetBoliler() function to:

Private Function GetBoiler(sigName As String) As String
' arnelgp
'
' sigName should include the .htm extension
'
    Dim appDataDir  As String
    Dim sig         As String
    Dim sigPath     As String
    Dim fileName    As String
    appDataDir = Environ$("APPDATA") & "\Microsoft\Signatures"
    sigPath = appDataDir & "\" & sigName
    If Len(Dir$(sigPath)) = 0 Then Exit Function
    With CreateObject("Scripting.FileSystemObject")
        sig = .OpenTextFile(sigPath).ReadAll
    End With
    ' fix relative references to images, etc. in sig
    ' by making them absolute paths, OL will find the image
    fileName = Replace$(sigName, ".htm", "_files/")
    sig = Replace$(sig, fileName, appDataDir & "\" & fileName)
    GetBoiler= sig
End Function

Hi
When i change it as mentioned, doesn't work?

Thank you!

 

[Gasman]

Hi
When i change it as mentioned, doesn't work?

Thank you!

So where is the original code?

 

[theDBguy]

Hi
When i change it as mentioned, doesn't work?

Thank you!

Hi. Welcome to AWF!

Did you change GetBoiler or did you delete it? I don't see it in your screenshot.

Also, have you verified if you can use VBA against the New Outlook?

 

[duplaly]

Hi. Welcome to AWF!

Did you change GetBoiler or did you delete it? I don't see it in your screenshot.

Also, have you verified if you can use VBA against the New Outlook?

So where is the original code?
View attachment 115854

 

[Minty]

It doesn't need to be that complicated - if you create a blank new email and your settings are to include your default signature you can capture that and then add it the end of the message you are then creating from Access.

Sub Client_Email(sEmailAdd As String, sQuote As String)

    Dim OutApp As Object
    Dim OutMail As Object
    Dim Signature As String
    '-- Standard Email Variables
    Dim Variable_To As String
    Dim Variable_Subject As String
    Dim Variable_Body As String
    Dim Variable_AttachmentFile As String
    Dim Variable_savepath As String
    Dim Current_Time As Integer, Greeting As String
    Dim sModel As String
    Dim sContact As String
    Dim sLastMonth As String

    Current_Time = Hour(Now())
   
    If Current_Time < 12 Then
        Greeting = "Morning "
    ElseIf Current_Time >= 18 Then
        Greeting = "Evening"
    Else
        Greeting = "Afternoon"
    End If
   
    Variable_Body = "<style> " & _
        "p {font-size:11pt; font-family:Calibri}" & _
        "</style>" & _
        "<p>" & "Good " & Greeting & "," & "</p>" & _
        "<p>" & "" & "</p>" & _
        "<p>" & "Please find attached your quote reference number " & sQuote & "." & _
        "<p>" & "" & "</p>" & _
        "<p>" & "Should you have any queries in connection to this quote please do not hesitate to contact me on any of the details below. " & _
        "<p>" & "" & "</p>" & _
        "<p>" & "Thank You,"
 
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .BodyFormat = olFormatHTML
        .Display
    End With
   
    ''''    Put the default signature into a variable
    Signature = OutMail.HTMLBody
       
    Variable_To = sEmailAdd
    Variable_Subject = "Quote Ref: " & sQuote
   
    With OutMail
   
        .To = Variable_To
        .CC = ""
        .BCC = ""
        .Subject = Variable_Subject
       
        '.MailItem.ReplyRecipients.Add = "flibble@somehwhere.com"
        '.SentOnBehalfOfName = "flibble@somehwhere.com"
        '.Attachments.Add (Variable_AttachmentFile)
       
        ''''    Add the saved signature back onto the email body
        .HTMLBody = Variable_Body & Signature
        .Display   'or use .Send
        .ReadReceiptRequested = False
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing

   
End Sub

 

[duplaly]

It doesn't need to be that complicated - if you create a blank new email and your settings are to include your default signature you can capture that and then add it the end of the message you are then creating from Access.

Sub Client_Email(sEmailAdd As String, sQuote As String)

    Dim OutApp As Object
    Dim OutMail As Object
    Dim Signature As String
    '-- Standard Email Variables
    Dim Variable_To As String
    Dim Variable_Subject As String
    Dim Variable_Body As String
    Dim Variable_AttachmentFile As String
    Dim Variable_savepath As String
    Dim Current_Time As Integer, Greeting As String
    Dim sModel As String
    Dim sContact As String
    Dim sLastMonth As String

    Current_Time = Hour(Now())
   
    If Current_Time < 12 Then
        Greeting = "Morning "
    ElseIf Current_Time >= 18 Then
        Greeting = "Evening"
    Else
        Greeting = "Afternoon"
    End If
   
    Variable_Body = "<style> " & _
        "p {font-size:11pt; font-family:Calibri}" & _
        "</style>" & _
        "<p>" & "Good " & Greeting & "," & "</p>" & _
        "<p>" & "" & "</p>" & _
        "<p>" & "Please find attached your quote reference number " & sQuote & "." & _
        "<p>" & "" & "</p>" & _
        "<p>" & "Should you have any queries in connection to this quote please do not hesitate to contact me on any of the details below. " & _
        "<p>" & "" & "</p>" & _
        "<p>" & "Thank You,"
 
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .BodyFormat = olFormatHTML
        .Display
    End With
   
    ''''    Put the defult signature into a variable
    Signature = OutMail.HTMLBody
       
    Variable_To = sEmailAdd
    Variable_Subject = "Quote Ref: " & sQuote
   
    With OutMail
   
        .To = Variable_To
        .CC = ""
        .BCC = ""
        .Subject = Variable_Subject
       
        '.MailItem.ReplyRecipients.Add = "flibble@somehwhere.com"
        '.SentOnBehalfOfName = "flibble@somehwhere.com"
        '.Attachments.Add (Variable_AttachmentFile)
       
        ''''    Add the saved signature back onto the email body
        .HTMLBody = Variable_Body & Signature
        .Display   'or use .Send
        .ReadReceiptRequested = False
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing

   
End Sub

Hi
I'm working on Excel vba, just a fyi!
Could explain how works that code?

 

[Minty]

It's pretty well commented on what does what (for my code anyway)...
It's designed to create an email to an email address with a quote number you pass in as parameters.
Obviously the text will need amending for your circumstances.

Walk though it and let us know what bit(s) you don't understand?

If not just run it and see what happens?

I'm pretty certain it would work in Excel as well.

 

[arnelgp]

change the code to this:

Sub Mail_Outlook_With_Signature_Html_2()
' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2016
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim SigString As String
    Dim Signature As String

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

    strbody = "<H3><B>Dear Customer Ron de Bruin</B></H3>" & _
              "Please visit this website to download the new version.<br>" & _
              "Let me know if you have problems.<br>" & _
              "<A HREF=""/rdb/tips.htm"">Ron's Excel Page</A>" & _
              "<br><br><B>Thank you</B>"

    'Change only Mysig.htm to the name of your signature
    SigString = "Mysig.htm"

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

    On Error Resume Next

    With OutMail
        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = strbody & "<br>" & Signature
        .Send    'or use .Display
    End With

    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Public Function GetBoiler(sigName As String) As String
' arnelgp
'
' sigName should include the .htm extension
'
    Dim appDataDir  As String
    Dim sig         As String
    Dim sigPath     As String
    Dim fileName    As String
    appDataDir = Environ$("APPDATA") & "\Microsoft\Signatures"
    sigPath = appDataDir & "\" & sigName
    If Len(Dir$(sigPath)) = 0 Then Exit Function
    With CreateObject("Scripting.FileSystemObject")
        sig = .OpenTextFile(sigPath).ReadAll
    End With
    ' fix relative references to images, etc. in sig
    ' by making them absolute paths, OL will find the image
    fileName = Replace$(sigName, ".htm", "_files/")
    sig = Replace$(sig, fileName, appDataDir & "\" & fileName)
    ReadSignature = sig
End Function

 

[duplaly]

It's pretty well commented on what does what (for my code anyway)...
It's designed to create an email to an email address with a quote number you pass in as parameters.
Obviously the text will need amending for your circumstances.

Walk though it and let us know what bit(s) you don't understand?

If not just run it and see what happens?

I'm pretty certain it would work in Excel as well.

Hi
Doesn't work for me in Excel!

 

[duplaly]

change the code to this:

Sub Mail_Outlook_With_Signature_Html_2()
' Don't forget to copy the function GetBoiler in the module.
' Working in Office 2000-2016
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim SigString As String
    Dim Signature As String

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

    strbody = "<H3><B>Dear Customer Ron de Bruin</B></H3>" & _
              "Please visit this website to download the new version.<br>" & _
              "Let me know if you have problems.<br>" & _
              "<A HREF=""/rdb/tips.htm"">Ron's Excel Page</A>" & _
              "<br><br><B>Thank you</B>"

    'Change only Mysig.htm to the name of your signature
    SigString = "Mysig.htm"

    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If

    On Error Resume Next

    With OutMail
        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = strbody & "<br>" & Signature
        .Send    'or use .Display
    End With

    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Public Function GetBoiler(sigName As String) As String
' arnelgp
'
' sigName should include the .htm extension
'
    Dim appDataDir  As String
    Dim sig         As String
    Dim sigPath     As String
    Dim fileName    As String
    appDataDir = Environ$("APPDATA") & "\Microsoft\Signatures"
    sigPath = appDataDir & "\" & sigName
    If Len(Dir$(sigPath)) = 0 Then Exit Function
    With CreateObject("Scripting.FileSystemObject")
        sig = .OpenTextFile(sigPath).ReadAll
    End With
    ' fix relative references to images, etc. in sig
    ' by making them absolute paths, OL will find the image
    fileName = Replace$(sigName, ".htm", "_files/")
    sig = Replace$(sig, fileName, appDataDir & "\" & fileName)
    ReadSignature = sig
End Function

Hi
The code can't load the new outlook app.
For the signature, doesn't work.

Thank you!

 

[arnelgp]

The code can't load the new outlook app.

then setup Outlook that comes with your Office and not the new Outlook.

 

[Minty]

Hi
Doesn't work for me in Excel!

You would need to attach it to button to run it, in its current configuration.

Without wishing to sound harsh, you do need to have a little understanding of how the code works rather than just copying and pasting stuff and hoping it works.

There is nothing in the code that would stop it functioning in Excel vba.
You just need a method to call it.

As Arnelgp has said, I don't think anyone's code will work with New Outlook. It has no automation features.

 

[GPGeorge]

Hi
The code can't load the new outlook app.
For the signature, doesn't work.

Thank you!

As others have tried to explain, "New" Outlook doesn't support VBA. That's one of the reasons there has been so much controversy about the transition imposed on us.

You'll need to learn JavaScript, as I understand it, to automate "New" Outlook.