On Error Resume Next
'Active Directory baglantisi yapiliyor
Set objSysInfo = CreateObject("ADSystemInfo")

strUser = objSysInfo.UserName

Set objUser = GetObject("LDAP://" & strUser)
'Active Directoryde Kullanicinin bilgileri degiskene aktariliyor
strAD = objUser.givenName
strName = objUser.FullName
strTitle = objUser.Title
strDepartment = objUser.Department
strCompany = objUser.Company
strAddress = objuser.streetAddress
strPhone = objUser.telephoneNumber
strFax = objUser.faxNumber
strMail = objuser.mail
strMobil = objuser.mobile
strLocation = objuser.physicalDeliveryOfficeName



 

'1. Bolum yeni mail olustururken kullanacagimiz imzayi olusturuyoruz
'Wordte dosyayi olusturuyoruz
Set objWord = CreateObject("Word.Application")
 With objWord
         .DisplayAlerts = False
         .Visible = False
         .ScreenUpdating = False
 End With
 

Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection

 

Set objRange = objDoc.Range
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries

 

'Degiskenlerin formatlarini belirleyerek worde yaziyoruz
objSelection.Font.Size = "9"
objSelection.Font.Name = "Verdana"
objSelection.Font.Color = RGB(26,93,138)
objSelection.TypeText "Saygılarımla / Best Regards"
objSelection.TypeText  Chr(11)
objSelection.TypeText  Chr(11)

objSelection.Font.Bold = true
 objSelection.TypeText "" & strName & Chr(11)
objSelection.Font.Bold = false
objSelection.TypeText strTitle & Chr(11)
objSelection.TypeText CHR(11)
Set objShape1 = objSelection.InlineShapes.AddPicture("C:\Windows\imza.jpg", False)


objCell.Select
objSelection.TypeText CHR(11)
objSelection.Font.Size = "9"
objSelection.Font.Name = "Verdana"
objSelection.Font.Color = RGB(128,128,128)
objSelection.TypeText "firma" & Chr(11)
objSelection.TypeText "Tel: " & strPhone & ")" & Chr(11)
if (strMobil) Then objSelection.TypeText "Gsm:  +9" & strMobil & Chr(11)
objSelection.TypeText "Fax:" & Chr(11)
objSelection.TypeText "E-Mail: "
Set objLink = objSelection.Hyperlinks.Add(objSelection.Range, "mailto: " & strMail, , , strMail) 
objSelection.TypeText  Chr(11)
objSelection.TypeText "Vergi Dairesi " & Chr(11)
objSelection.TypeText "Vergi Numarasi" & Chr(11)
objSelection.TypeText "Ticaret Sicil Numarasi " & Chr(11)
objSelection.TypeText "MERSIS Numarasi" & Chr(11)
objSelection.TypeText "Adres / Address:" & Chr(11)

objSelection.TypeText "Web: " 
Set objLink = objSelection.Hyperlinks.Add(objSelection.Range, "", , , "")
objSelection.InlineShapes.AddHorizontalLineStandard
'Bu bolum mailin enaltina regal yazimiz
objSelection.Font.Size = "10"
objSelection.Font.Name = "Bahnschrift SemiLight"
objSelection.Font.Color = RGB(26,93,138)
objSelection.Font.Italic = False
objSelection.TypeText "- ."
objSelection.TypeText  Chr(11)
objSelection.TypeText "- "

 

'Word dosyasini kaydedip kapatiyoruz
objSignatureEntries.Add strAD&"-imza", objRange
objSignatureObject.NewMessageSignature = strAD&"-imza"

objDoc.Saved = True
objWord.Quit