Script Yardımı ile Active Directory Kullanarak Outlook a İmza Ekleme

On Error Resume Next

Set objSysInfo = CreateObject("ADSystemInfo")

strUser = objSysInfo.UserName 

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

strName = objUser.FullName 

strTitle = objUser.Title 

strDepartment = objUser.Department 

strCompany = objUser.Company 

strPhone = objUser.telephoneNumber 

strStreet = objUser.streetAddress 

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 

Dim name,firstLetter,otherLetters,fname,sname 

name = strName 

arr = Split(name, " ") 

firstLetter=UCase(Left(arr(0),1)) 

otherLetters=LCase(Right(arr(0),Len(arr(0))-1)) 

fname=firstLetter & otherLetters 

firstLetter=UCase(Left(arr(1),1)) 

otherLetters=LCase(Right(arr(1),Len(arr(1))-1)) 

sname=firstLetter & otherLetters 

name =fname & " " & sname 

With objSelection.ParagraphFormat 

.LeftIndent = CentimetersToPoints(0) 

.RightIndent = CentimetersToPoints(0) 

.SpaceBefore = 0 

.SpaceBeforeAuto = False 

.SpaceAfter = 0 

.SpaceAfterAuto = False 

.LineSpacingRule = wdLineSpaceMultiple 

.LineSpacing = LinesToPoints(1.15) 

.Alignment = wdAlignParagraphLeft 

.WidowControl = True 

.KeepWithNext = False 

.KeepTogether = False 

.PageBreakBefore = False 

.NoLineNumber = False 

.Hyphenation = True 

.FirstLineIndent = CentimetersToPoints(0) 

.OutlineLevel = wdOutlineLevelBodyText 

.CharacterUnitLeftIndent = 0 

.CharacterUnitRightIndent = 0 

.CharacterUnitFirstLineIndent = 0 

.LineUnitBefore = 0 

.LineUnitAfter = 0 

.MirrorIndents = False 

.TextboxTightWrap = wdTightNone

 End With With objSelection 

.Font.Bold = True 

.TypeText name 

.TypeText vbCRLF 

.TypeText strTitle 

.TypeText vbCRLF 

.TypeText strDepartment & " Department" 

.TypeText vbCRLF 

.TypeText vbCRLF 

.Font.Color = vbRed 

.TypeText strCompany 

.TypeText vbCRLF 

.Font.Bold = True 

.Font.Color = vbBlack 

.TypeText "Phone : " 

.Font.Bold = False 

.TypeText strPhone 

.TypeText vbCRLF 

.Font.Bold = True 

.TypeText "Address : " 

.Font.Bold = False 

.TypeText vbCRLF 

.TypeText strStreet 

End With 

Set objSelection = objDoc.Range()

IF(objSignatureEntries("AD Signature")) THEN

objSignatureEntries.Remove "AD Signature" END IF

objSignatureEntries.Add "AD Signature", objSelection 

objSignatureObject.NewMessageSignature = "AD Signature" 

objSignatureObject.ReplyMessageSignature = "AD Signature" 

objDoc.Saved = True 

objWord.Quit