Assinatura Outlook

On Error Resume Next
Set objSysInfo = CreateObject("ADSystemInfo")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)
With objUser
  strName = .GivenName
  strUnderName = .SN
  strTitle = .title
  End With



Set objword = CreateObject("Word.Application")
With objword

  Set objDoc = .Documents.Add()
  Set objSelection = .Selection
  Set objEmailOptions = .EmailOptions
End With

Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries
With objSelection

  .ParagraphFormat.Alignment = wdAlignParagraphRight
  .TypeParagraph

  With .Font
    .Name = "Arial"
    .Size = 12
    .Bold = True
    .Italic = True
    .Color = 100
  End With
    .TypeText strName & " " & strUnderName & Chr(11)
    .TypeText strTitle & Chr(11)
    .TypeText "TEXTO BLABLA" & Chr(11)

    .TypeText Chr(11)
   objSelection.Font.Size = "12"
    objSelection.Font.italic = true
    objSelection.Font.Color = 100
    objSelection.Font.Bold = true
    objSelection.TypeText "TEXTO BLABLABLA"
End With

Set objSelection = objDoc.Range()
objSignatureEntries.Add "AD Signature", objSelection
objSignatureObject.NewMessageSignature = "AD Signature"
objSignatureObject.ReplyMessageSignature = "AD Signature"
objDoc.Saved = True
objword.Quit