我正在创建一个从AD获取数据的自动Outlook签名。一切顺利,但我不断在表格单元格上获得空格(看起来像填充或其他东西)。
On Error Resume Next
Set objSysInfo = CreateObject("ADSystemInfo")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" + strUser)
strName = objUser.givenName
strSurName = objUser.Sn
strFullName = objUser.Fullname
strTitle = objUser.Title
strAdres = objUser.address
strPhone = objUser.TelephoneNumber
strMob = objUser.Mobile
strEmail = objUser.mail
strMarBoo = objUser.StreetAddress
strMarLinkTxt = objUser.postOfficeBox
strMarLink = objUser.l
strDescription = objUser.Description
strIT = ""
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
objSelection.ParagraphFormat.LineSpacing = 14
objSelection.TypeText "Met vriendelijke groet, "
objSelection.TypeText Chr(11)
objSelection.TypeText Chr(11)
'objSelection.Font.Color = RGB(240,73,6)
objSelection.Font.Bold = True
objSelection.TypeText strFullName
objSelection.Font.Bold = False
objSelection.TypeText Chr(11)
objSelection.Font.Color = RGB(47,84,150)
objSelection.Font.Size = 11
objSelection.TypeText strTitle + Chr(11)
objSelection.Font.Size = 11
objSelection.Font.Color = RGB(47,84,150)
Set objRange = objSelection.Range
objDoc.Tables.Add objRange, 3, 5
Set objTable1 = objDoc.Tables(1)
objTable1.TopPadding = PixelsToPoints(10, True)
objTable1.BottomPadding = PixelsToPoints(10, True)
'Merge cells in col 1
objTable1.Columns(1).Cells.Merge
objTable1.Columns(1).PreferredWidth = 90
objTable1.Columns(2).PreferredWidth = 100
objTable1.Columns(3).PreferredWidth = 150
objTable1.Columns(4).PreferredWidth = 100
objTable1.Columns(5).PreferredWidth = 200
'----------------KOLOM 1------------------------------
objTable1.Cell(1,1).Range.InlineShapes.AddPicture "\\int-vm- pdc\NETLOGON\logo_rondje_oranje_small.png"
'----------------KOLOM 2------------------------------
objTable1.Cell(1,2).Range.Font.Bold = True
objTable1.Cell(1,2).Range.Font.Color = RGB(240,73,6)
objTable1.Cell(2,2).Range.Font.Bold = True
objTable1.Cell(2,2).Range.Font.Color = RGB(240,73,6)
objTable1.Cell(3,2).Range.Font.Bold = True
objTable1.Cell(3,2).Range.Font.Color = RGB(240,73,6)
objTable1.Cell(1,2).Range.Text = "Bezoekadres"
objTable1.Cell(2,2).Range.Text = "Hoofdnummer"
objTable1.Cell(3,2).Range.Text = "Rechtstreeks"
'----------------KOLOM 3------------------------------
objTable1.Cell(1,3).Range.Text = strAdres
objTable1.Cell(2,3).Range.Text = strPhone
objTable1.Cell(3,3).Range.Text = strMob
'----------------KOLOM 4------------------------------
objTable1.Cell(1,4).Range.Font.Bold = True
objTable1.Cell(1,4).Range.Font.Color = RGB(240,73,6)
objTable1.Cell(2,4).Range.Font.Bold = True
objTable1.Cell(2,4).Range.Font.Color = RGB(240,73,6)
objTable1.Cell(3,4).Range.Font.Bold = True
objTable1.Cell(3,4).Range.Font.Color = RGB(240,73,6)
objTable1.Cell(1,4).Range.Text = "Emailadres"
objTable1.Cell(2,4).Range.Text = "Website"
'----------------KOLOM 5------------------------------
Set objCell = objTable1.Cell(1,5).Range
Set objLink = objSelection.Hyperlinks.Add(objCell, "mailto:"&strEmail, , ,strEmail)
Set objCell = objTable1.Cell(2,5).Range
Set objLink = objSelection.Hyperlinks.Add(objCell, "https://www.company.com", , ,"https://www.company.com")
objTable1.Cell(3,5).Range.Text = strDescription
objSelection.EndKey 6
With Selection.ParagraphFormat
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 0
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
End With
Set objSelection = objDoc.Range()
objSignatureEntries.Add "Handtekening_2018_extended", objSelection
objSignatureObject.NewMessageSignature = "Handtekening_2018_extended"
objSignatureObject.ReplyMessageSignature = "Handtekening_2018_extended"
objDoc.Saved = True
objWord.Quit
有关结果的屏幕截图,请参阅图片:
已经尝试设置Font.LineHeight
,objTable1.Rows(1).Height
,但似乎没有任何效果。
任何人都知道如何解决这个问题?
也许有一些我找不到关于样式的更详细的文档?