vbscriptoutlookemail

VBScript: Outlook signature creation - How to hyperlink telephone numbers?


I've got a vbscript that i've been working on that will generate a signature file from AD information. Pretty common script and I've tweaked it to work perfectly except for one thing.

I can't for the life of me work out how to make the signature file recognise telephone numbers as links. We use Mitel phone system software and simply clicking a link in the signature rather than copy pasting into the dialer would be a bit of a quality of life update.

EDIT: I essentially want the vbs equivalent of this

<a href="tel:+12345678910"><span class=ContactDetail>+12 345 678 910</span></a>

But I'm not well versed in VBscript

On Error Resume Next

'References
'All objuser.XXXX and there counterparts in AD 
'https://ss64.com/vb/syntax-userinfo.html

Set objSysInfo = CreateObject("ADSystemInfo")
Set WshShell = CreateObject("WScript.Shell")

strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)

strName = objUser.FullName
strTitle = objUser.Title
strCred = objUser.info
strStreet = objUser.StreetAddress
strState = objUser.st
strLocation = objUser.l
strPostCode = objUser.PostalCode
strPhone = objUser.TelephoneNumber
strDirect = objUser.ipPhone
strMobile = objUser.Mobile
strEmail = objUser.mail
strWebsite = objUser.wWWHomePage
strOffice = objUser.physicalDeliveryOfficeName

'Creates word application for formatting
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries

'Signature Font 
objSelection.Font.Name = "Verdana"
objSelection.Font.Size = 10 'Carries over unless specified again elsewhere

'Salutation
objSelection.font.color = rgb(0,0,0)
objSelection.TypeText "Regards,"

'Line break
'objSelection.TypeText Chr(11)
objSelection.TypeParagraph()

'Username line
objSelection.Font.Size = 12
objSelection.Font.Bold = true
if (strCred) Then objSelection.TypeText strName & ", " & strCred Else objSelection.TypeText strName
objSelection.Font.Bold = false

'Job title line
objSelection.Font.Size = 10
objSelection.TypeParagraph()
objSelection.ParagraphFormat.LineSpacing = 16
objSelection.TypeText strTitle
objSelection.TypeText Chr(11)

'Location line
objSelection.Font.Bold = true
objSelection.font.color = rgb(210,73,42)
objSelection.TypeText strOffice & " Office " & "| CompanyName"
objSelection.Font.Bold = False
objSelection.TypeText Chr(11)

'Address line
objSelection.Font.Size = 9
objSelection.font.color = rgb(0,0,0)
objSelection.TypeText strStreet & ", " & strLocation & ", " & strState & ", " & strPostCode
objSelection.TypeText Chr(11)

'Contact line
objSelection.Font.Size = 8
objSelection.font.color = rgb(0,0,0)
'Formatted to print results horizontally - to print vertically add objSelection.TypeText Chr(11) in between each object
'If the data is not present in the AD it will not print anything and move on to the next field.
If Not IsEmpty(strPhone) Then
    objselection.typetext "P: " & strPhone
End If

If Not IsEmpty(strDirect) Then
    objselection.typetext " | D: " & strDirect
End If

If Not IsEmpty(strmobile) Then
    objselection.typetext " | M: " & strMobile
End If

If Not IsEmpty(strEmail) Then
    objselection.typetext " | E: " & strEmail
End If

If Not IsEmpty(strWebsite) Then
    objselection.typetext " | W: " & strWebsite
End If

objSelection.TypeText Chr(11)

' If statement to hyperlink website 
' Don't really need this as most email clients auto format the email and website to hyperlinks
' if strWebsite then
' Set objLink = objSelection.Hyperlinks.Add(objselection.Range,strWebsite)
    ' objLink.Range.Font.Name = "Verdana"
    ' objLink.Range.Font.Size = 8
    ' objLink.Range.Font.Bold = false
' end if
' objSelection.TypeText Chr(11)

'Image description or disclaimer
objSelection.Font.Size = 9
objSelection.Font.Bold = true
objSelection.font.color = rgb(0,187,0)
objSelection.TypeText "Disclaimer"
objSelection.Font.Bold = false
objSelection.TypeText Chr(11)

'New signature image adding - Place script and file in NETLOGON and adjust image file path
Set shp = objSelection.InlineShapes.AddPicture("NETLOGON\PIC.jpg")
shp.LockAspectRatio = msoFalse
shp.Width = 456
shp.Height = 86

'Can make an if statement for if there is a badge signature instead of a banner.


'Code for multuple departments with different signature images
' If (objUser.Department = "COMPANY NAME.") Then 
             ' objSelection.InlineShapes.AddPicture("\PIC") 


' ElseIf (objUser.Department = "COMPANY NAME") Then 
        ' objSelection.InlineShapes.AddPicture("\PIC") 

' Else 
        ' objSelection.InlineShapes.AddPicture("\PIC") 

' End If 

Set objSelection = objDoc.Range()

objSignatureEntries.Add "EmailSignature", objSelection 
objSignatureObject.NewMessageSignature = "EmailSignature" 
objSignatureObject.ReplyMessageSignature = "EmailSignature" 

objDoc.Saved = True
objWord.Quit

I'm working on the code so I have a lot of comments to follow along.

If anyone has any ideas that would be extremely helpful.


Solution

  • You need a hyperlink in the format tel:1234567890, much like an http://xyz.demo link.