I'm creating an automated Outlook signature that gets data from AD. All's going well, but I keep getting whitespace (looks like padding or something) on table cells.
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
See image for a screenshot of the result:
Already tried setting Font.LineHeight, objTable1.Rows(1).Height, but nothing seems to work.
Anyone knows how to solve this?
Maybe there is some more detailed documentation that I cannot find about styling?
Related
I am learning through the internet and based on my knowledge and data available on the internet, I have created the following macro which works. The purpose of the macro is to filter the data, arrange it in the desired format and print it.
The problem is, once I run the macro, all the filters are printed in one pass. I am looking for a change where after running the macro, I get a display to select the filter I want to print or if I want to print all the filters.
I hope I was able to explain my problem. Let me know if anyone can help me. Thanks
Sub itemno()
ThisWorkbook.Worksheets("Sheet1").Activate
Dim LR As Long
Dim Sh As Worksheet
Set Sh = Worksheets("Sheet1")
LR = Sh.Range("H" & Rows.Count).End(xlUp).Row
Sh.Range("P2:P" & LR).Formula = "=IF(LEFT(RC[-13],3)=""300"",RIGHT(RC[-7],4)&""-""&RIGHT(RC[-14],3),RC[-13])"
Sh.Range("P1:P" & LR).Copy
Sh.Columns("B:B").Select
Selection.PasteSpecial Paste:=xlPasteValues
Sh.Columns("C:C").Delete
Sh.Columns("F:F").Delete
Sh.Columns("I:P").Delete
Sh.Range("A1").FormulaR1C1 = "Colli Nr."
Sh.Range("B1").FormulaR1C1 = "Item Nr."
Sh.Range("D1").FormulaR1C1 = "Unit"
Sh.Cells.Select
Sh.Cells.EntireColumn.Autofit
Sh.Columns("A:A").ColumnWidth = 20
Sh.Columns("C:C").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
End With
Selection.NumberFormat = "0.0"
Sh.Cells.Select
Selection.RowHeight = 25
With Selection
.VerticalAlignment = xlCenter
End With
Sh.Rows("1:1").Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Sh.Columns("F:F").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Sh.Range("F1").Select
ActiveCell.FormulaR1C1 = "Bemerkung"
Sh.Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Selection.Font.Bold = True
With Selection.Font
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Sh.Columns("E:E").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Sh.Range("E1").FormulaR1C1 = "CheckBox"
Sh.Range("M2:M" & LR).Formula = "=RC[-10]&"" ""&RC[-9]"
Sh.Range("M1:M" & LR).Copy
Sh.Columns("C:C").Select
Selection.PasteSpecial Paste:=xlPasteValues
Sh.Range("C1").FormulaR1C1 = "Menge"
Sh.Columns("M:M").Delete
Sh.Columns("D:D").Delete
Dim cb As CheckBox
Dim myRange As Range, cel As Range
Dim wks As Worksheet
Set wks = Sheets("Sheet1")
Set myRange = wks.Range("D2:D" & LR)
For Each cel In myRange
Set cb = wks.CheckBoxes.Add(cel.Left, cel.Top, 30, 15)
With cb
.Caption = ""
.OnAction = "ProcessCheckBox"
End With
Next
Dim Rang As Range
Set Rang = Sh.Range("A1:I" & LR)
With Rang.Borders
.LineStyle = xlContinuous
.Color = vbBlack
.Weight = xlThin
End With
wks.Rows("1:7").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.RowHeight = 15
Sh.Range("A1:F1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Sh.Range("A1:F1").Select
ActiveCell.FormulaR1C1 = "Packliste nur für die Werkstatt"
Sh.Range("A3").Select
ActiveCell.FormulaR1C1 = "Projekt:"
Sh.Range("B3:D3").Select
With Selection
.HorizontalAlignment = xlLeft
End With
Selection.Merge
Sh.Range("E3").Select
ActiveCell.FormulaR1C1 = "Column Nr."
Sh.Range("A4").Select
ActiveCell.FormulaR1C1 = "Zeichnung Nr. "
Sh.Range("B4:C4").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
Sh.Range("E4").Select
ActiveCell.FormulaR1C1 = "Dokument Nr."
Sh.Range("A6").Select
ActiveCell.FormulaR1C1 = "Verpackt von:"
Sh.Range("E6").Select
ActiveCell.FormulaR1C1 = "Geprüft von:"
Sh.Rows("1:1").Select
Selection.RowHeight = 20
Selection.Font.Bold = True
Selection.Font.Size = 16
Selection.Font.Underline = xlUnderlineStyleSingle
Sh.Columns("B:B").ColumnWidth = 20
Sh.Columns("D:D").ColumnWidth = 15
Sh.Columns("C:C").ColumnWidth = 12
Sh.Columns("F:F").ColumnWidth = 40
Sh.Columns("G:G").Cut
Sh.Columns("J:J").Insert Shift:=xlToRight
Sh.Activate
Dim Rng As Range
Dim c As Range
Dim List As New Collection
Dim Item As Variant
Application.ScreenUpdating = False
Set Rng = Sh.Range("G9:G" & Sh.Range("G65536").End(xlUp).Row)
On Error Resume Next
For Each c In Rng
List.Add c.Value, CStr(c.Value)
Next c
On Error GoTo 0
Set Rng = Sh.Range("G8:G" & Sh.Range("G65536").End(xlUp).Row)
For Each Item In List
Rng.AutoFilter Field:=1, Criteria1:=Item
Sh.Range("F4") = Item
Sh.Range("F3:F4").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
Sh.Range("F3").FormulaR1C1 = "=VLOOKUP(TEXT(R[1]C,0),C[1]:C[3],3,FALSE)"
Sh.Range("B4:C4").FormulaR1C1 = "=VLOOKUP(TEXT(RC[4],0),C[5]:C[7],2,FALSE)"
Sh.Range("B3:D3").FormulaR1C1 = "=LEFT(R[6]C,9)"
Application.PrintCommunication = False
Sh.Activate
ActiveSheet.PageSetup.PrintArea = "$A:$F"
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$8"
.LeftMargin = Application.InchesToPoints(0.236220472440945)
.RightMargin = Application.InchesToPoints(0.236220472440945)
.TopMargin = Application.InchesToPoints(0.2)
.BottomMargin = Application.InchesToPoints(0.35)
.HeaderMargin = Application.InchesToPoints(0.2)
.FooterMargin = Application.InchesToPoints(0.35)
.Orientation = xlLandscape
.PaperSize = xlPaperA4
.LeftFooter = "Colli-Informationen eingeben (Abmessungen, Bruttogewicht & Tara)"
.RightFooter = "&P/&N"
End With
Application.PrintCommunication = True
Sh.PrintOut
Rng.AutoFilter
Next Item
Application.ScreenUpdating = True
End Sub
I keep getting an error 1004 for the line that has an asterisk. I am a complete beginner. How can I debug this?
There is more code before & after this, but everything else seems to be working properly.
Dim i As Long
i = 1
Do Until i = Range("Q1").Value - 1
ActiveCell.Offset(rowOffset:=2, columnOffset:=0).Activate
Range(ActiveCell, ActiveCell.Offset(0, 7)).Select
With Selection
.HorizontalAlignment = xlCenterAcrossSelection
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection.Font
.Name = "Inherit"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
Selection.Font.Bold = True
End With
ActiveCell.Offset(rowOffset:=2, columnOffset:=0).Activate
Selection.End(xlToRight).Select
**ActiveCell.Offset(rowOffset:=0, columnOffset:=1).Activate
ActiveCell.FormulaR1C1 = "Hours Optimized"
ActiveCell.Offset(rowOffset:=0, columnOffset:=1).Activate
ActiveCell.FormulaR1C1 = "FTE's Optimized"
ActiveCell.Offset(rowOffset:=0, columnOffset:=1).Activate
ActiveCell.FormulaR1C1 = "ROI"
ActiveCell.Offset(rowOffset:=0, columnOffset:=1).Activate
ActiveCell.FormulaR1C1 = "Months Payback"
Range(Selection, Selection.End(xlToLeft)).Select
Thanks for the web site and thanks for taking you time to read this.
I created a signature based on a VBS Script i pulled for numerous web sites online and got the signature almost like i would like it to be, just got a few more tweaks before i stop messing with it. i can´t seem to get the vertical alignment to work. Can you help me out please.
The code is below and the image showing refering to what i need is attached.
i need to move the right side image to the a bottom aligned position
i need to remove the space i have between the blue bar and the table above.
Appriciate the help, i am not a programmer just trying to do my best to automate signatures in outlook.
On Error Resume Next
'Option Explicit
Dim objSysInfo,strUser,objUser,strName,strMail,strWebAddr,strCompany,strDepartment,strStreetAddr,strHomePhone,strIpPhone,strMobile
Dim objWord,objDoc,objSelection,objEmailOptions,objSignatureObject,objSignatureEntries,objLink,strlogoATL,strlogoMA,strlogoBAR
Dim objRange,objTable
Set objSysInfo = CreateObject("ADSystemInfo")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)
strName = objUser.FirstName &" "& objUser.LastName
strMail = objuser.mail
strWebAddr = objuser.wWWHomePage
strCompany = objuser.Company
strDepartment = objUser.Department
strStreetAddr = objuser.streetaddress
strHomePhone = objuser.HomePhone
strIpPhone = objuser.ipPhone
strMobile = objuser.Mobile
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
objSelection.Style = "No Spacing"
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries
'Name of Staff
objSelection.Font.Name = "Verdana"
objSelection.Font.Size = "10"
objSelection.Font.Color = RGB(91,91,91)
objSelection.TypeText strName
objSelection.TypeText(Chr(11))
objSelection.TypeParagraph()
'Mail
objSelection.Font.Name = "Verdana"
objSelection.Font.Size = "8"
objSelection.Font.Color = RGB(91,91,91)
Set objLink = objSelection.Hyperlinks.Add(objSelection.Range, "mailto: " & strMail, , , strMail)
objSelection.TypeText(Chr(11))
'Tel
objSelection.Font.Name = "Verdana"
objSelection.Font.Size = "8"
objSelection.Font.Color = RGB(91,91,91)
objSelection.TypeText "Ext : "& strIpPhone & " " & " "& chr(124) & " Telem" & Chr(243) & "vel : " & strMobile
objSelection.TypeText(Chr(11))
objSelection.TypeParagraph()
'Department
objSelection.Font.Name = "Verdana"
objSelection.Font.Size = "8"
objSelection.Font.Color = RGB(0,153,181)
objSelection.TypeText strDepartment
objSelection.TypeText(Chr(11))
'Address
objSelection.Font.Name = "Verdana"
objSelection.Font.Size = "8"
objSelection.Font.Color = RGB(0,153,181)
objSelection.TypeText strStreetAddr
objSelection.TypeText(Chr(11))
objSelection.TypeParagraph()
'Company Contact details
objSelection.Font.Name = "Verdana"
objSelection.Font.Color = RGB(0,153,181)
objSelection.TypeText "Tel : "& strHomePhone & " " & chr(124) & " "
'Web
objSelection.Font.Name = "Verdana"
objSelection.Font.Color = RGB(0,153,181)
set objLink = objSelection.Hyperlinks.Add(objSelection.Range,strWebAddr)
strlogoATL="c:\Utils\Assinatura\ins_atl.jpg"
strlogoMA="c:\Utils\Assinatura\ins_ma.jpg"
strlogoBAR="c:\Utils\Assinatura\ins_bar.jpg"
Set objRange = objSelection.Range
objDoc.Tables.Add objRange, 1, 2
Set objTable = objDoc.Tables(1)
objTable.leftpadding = 0
objTable.rightpadding = 0
objTable.Columns(1).Width = objWord.CentimetersToPoints(12.00)
objTable.Cell(1, 1).Range.InlineShapes.AddPicture(strlogoATL)
objTable.Columns(2).Width = objWord.CentimetersToPoints(12.00)
objTable.Cell(1, 2).Range.ParagraphFormat.Alignment = 2
objTable.Cell(1, 2).Range.VerticalAlignment = wdAlignVerticalCenter
objTable.Cell(1, 2).Range.InlineShapes.AddPicture(strlogoMA)
objSelection.EndKey 6
objSelection.TypeParagraph()
Set objRange = objSelection.Range
objDoc.Tables.Add objRange, 1, 1
Set objTable = objDoc.Tables(2)
objTable.leftpadding = 0
objTable.rightpadding = 0
objTable.Columns(1).Width = objWord.CentimetersToPoints(24.00)
objTable.Cell(1, 1).Range.InlineShapes.AddPicture(strlogoBAR)
objSelection.EndKey 6
objSelection.TypeParagraph()
Set objSelection = objDoc.Range()
objSignatureEntries.Add "ATLANTICO", objSelection
objSignatureObject.NewMessageSignature = "ATLANTICO"
objSignatureObject.ReplyMessageSignature = "ATLANTICO"
objDoc.Saved = True
objWord.Quit
wscript.echo "Uma nova assinatura foi aplicada ao seu Outlook!"
Picture of problem shown below
I have a Word vbscript that sets a company signature. I'm trying to figure out how to add lines before the table and remove the extra lines that are showing up after the table.
Here's the code:
Set objSysInfo = CreateObject("ADSystemInfo")
Set WshShell = CreateObject("WScript.Shell")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)
strName = objUser.FullName
strFirst = objUser.FirstName
strLast = objUser.LastName
strInitials = objUser.Initials
strOffice = objUser.physicalDeliveryOfficeName
strPOBox = objUser.postOfficeBox
strTitle = objUser.Description
strCred = objUser.info
strStreet = objUser.StreetAddress
strLocation = objUser.l
strPostCode = objUser.PostalCode
strPhone = objUser.TelephoneNumber
strMobile = objUser.Mobile
strFax = objUser.FacsimileTelephoneNumber
strEmail = objUser.mail
strCompany = objUser.Company
Set objWord = CreateObject("Word.Application")
Const END_OF_STORY = 6
Const NUMBER_OF_ROWS = 1
Const NUMBER_OF_COLUMNS = 2
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries
Set objRange = objDoc.Range()
objDoc.Tables.Add objRange, NUMBER_OF_ROWS, NUMBER_OF_COLUMNS
Set objTable = objDoc.Tables(1)
Dim rngCell
Set rngCell = objTable.Cell(1, 2).Range
objTable.Columns(1).Width = 50
objTable.Columns(2).Width = 360
rngCell.ParagraphFormat.SpaceAfter = 0
rngCell.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
rngCell.ParagraphFormat.LineSpacing = 12
rngCell.Text = strFirst & " " & strInitials & " " & strLast & " | " & _
strOffice & " | " & strCompany & vbCr
rngCell.Font.Bold = True
rngCell.Font.Name = "Calibri"
rngCell.Font.Size = 10
rngCell.Collapse 0 'wdCollapseEnd
rngCell.MoveEnd 1, -1 'wdCharacter, 1
rngCell.Text = strStreet & " | " & strPOBox & " | " & strLocation & vbCr
rngCell.Font.Bold = False
rngCell.Font.Name = "Calibri"
rngCell.Font.Size = 10
rngCell.Collapse 0 'wdCollapseEnd
rngCell.MoveEnd 1, -1 'wdCharacter, 1
rngCell.Text = vbCr & "Phone: " & strPhone & " | " & "Fax: " & strFax & " | " & "Email: " & vbCr
rngCell.Font.Bold = False
rngCell.Font.Name = "Calibri"
rngCell.Font.Size = 10
rngCell.Collapse 0 'wdCollapseEnd
rngCell.MoveEnd 1, -1 'wdCharacter, 1
Set objLink = objTable.Cell(1, 2).Range
objLink.Hyperlinks.Add rngCell, "mailto:" & strEmail,,,strEmail
objLink.Font.Size = 10
objLink.Font.Name = "Calibri"
objSelection.EndKey END_OF_STORY
objSelection.ParagraphFormat.SpaceAfter = 0
Set objSelection = objDoc.Range()
objSignatureEntries.Add "Reply Signature", objSelection
objSignatureObject.ReplyMessageSignature = "Reply Signature"
objDoc.Saved = True
objWord.Quit
(I removed the logo/image in the first column for security reasons), but for some reason, there are extra lines below the text & logo (when it's there) within the table, and there are extra lines below the table. I need those to disappear if possible? Any help would be greatly appreciated! :)
Thanks!
For adding lines before the table, best to add the lines (paragraphs, I assume) before you insert the table. So something like:
objRange.Text = Chr(13) & Chr(13)
objRange.Collapse 0 'end
Set objTable = objDoc.Tables.Add(objRange, NUMBER_OF_ROWS, NUMBER_OF_COLUMNS)
I am seeking advise / assistance with my script I have put together from tips online and am phased with one last issue that I am having no success with.
All information from row 4 - 8 to be moved up underneath row 3 next to my logo. Now because of the logo row height, it is causing row 4 - 8 to drop below the logo's row. I have been trying to split / merge columns to no success. Please see picture below.
Here is the code i have been mashing at:
On Error goto 0
Const END_OF_STORY = 6
Set objSysInfo = CreateObject("ADSystemInfo")
' ########### This section connects to Active Directory as the currently logged on user
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)
sLogoLocation = "\\servername\pic\Sig\logo.jpg"
sStripeLocation = "\\servername\pic\Sig\candystripe.gif"
sLinkAddress = "http://www.yourwebsite.com"
sDisplayLinkText = "www.yourwebsite.com"
sBoldSloganText = "BOLD TEXT USED FOR SLOGAN"
sNormalSloganText = "NORMAL TEXT USED FOR SLOGAN"
' ########### This section sets up the variables we want to call in the script (items on the left; whereas the items on the right are the active directory database field names) - ie strVariablename = objuser.ad.databasename
strGiven = objuser.givenName
strSurname = objuser.sn
strAddress1 = objUser.streetaddress
strAddress1EXT = objUser.postofficebox
strAddress2 = objuser.l
strAddress3 = objuser.st
strPostcode = objuser.postalcode
strCountry = objuser.c
strFax = objuser.facsimileTelephoneNumber
strMobile = objuser.mobile
strTitle = objUser.Title
strDepartment = objUser.Department
strCompany = objUser.Company
strPhone = objUser.telephoneNumber
strEmail = objuser.mail
strWeb = objuser.wWWHomePage
strNotes = objuser.info
strExt = objuser.ipPhone
strDDI = objuser.homephone
strEmailTEXT = "Email: "
strOffice = objuser.physicalDeliveryOfficeName
strPOBOx = objuser.PostOfficeBox
' ########### Sets up word template
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
objSelection.Style = "No Spacing"
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries
' ########### Separate main logo from other tables in the script in its own singular column.
' ########### Calls the variables from above section and inserts into word template, also sets initial font typeface, colour etc.
on error resume next
Const wdAlignParagraphRight = 2
Const NUMBER_OF_ROWS = 8
Const NUMBER_OF_COLUMNS = 3
Set objRange = objDoc.Range()
objDoc.Tables.Add objRange, NUMBER_OF_ROWS, NUMBER_OF_COLUMNS
Set objTable = objDoc.Tables(1)
objTable.Cell(1, 1).Width = "3"
objTable.Cell(2, 1).Width = "3"
objTable.Cell(1, 2).Width = "15"
objTable.Cell(2, 2).Width = "15"
objTable.Rows(1).Range.Font.Bold = true
'objTable.Cell(1, 1).Range.Text = ""
objTable.Cell(1, 2).Range.Text = objuser.givenName & " " & objuser.sn & " | " & objuser.Title & " | " & objuser.Department
objTable.Cell(2, 2).Range.InlineShapes.AddPicture(sStripeLocation)
objTable.Cell(3, 1).Width = "3"
objTable.Cell(3, 2).Width = "15"
objTable.Cell(4, 1).Width = "3"
objTable.Cell(4, 2).Width = "10"
objTable.Cell(4, 3).Width = "10"
objTable.Cell(5, 1).Width = "3"
objTable.Cell(5, 2).Width = "15"
objTable.Cell(6, 1).Width = "3"
objTable.Cell(7, 1).Width = "3"
objTable.Cell(8, 1).Width = "3"
objTable.Rows(3).Range.Font.Bold = false
objTable.Rows(4).Range.Font.Bold = false
objTable.Rows(5).Range.Font.Bold = false
objTable.Rows(6).Range.Font.Bold = false
'objTable.Rows(3).Cells(1).Split 1, 5
'objTable.Rows(3).Cells(3).Split 1, 2
objTable.Cell(5, 2).Merge objTable.Cell(5, 8)
objTable.Cell(3, 2).Merge objTable.Cell(3, 6)
objTable.Cell(4, 2).Merge objTable.Cell(4, 6)
objTable.Cell(6, 2).Merge objTable.Cell(6, 6)
objTable.Cell(3, 1).Range.InlineShapes.AddPicture(sLogoLocation)
objTable.Cell(3, 2).Range.Text = "SwitchBoard: " & objuser.TelephoneNumber & " | " & "Extension: " & objuser.physicalDeliveryOfficeName
objTable.Cell(4, 2).Range.Text = "Fax Number: " & objuser.facsimileTelephoneNumber & " | " & "Mobile: " & objuser.Mobile
objTable.Cell(5, 2).Range.Text = "Address: " & objUser.streetaddress & ", " & objuser.l & ", " & objuser.postalcode & ", " & objuser.st & ", " & objuser.c
objTable.Cell(6, 2).Range.Text = "P.O Box: " & objuser.PostOfficeBox
Set objCell = objTable.Cell(7, 2)
Set objCellRange = objCell.Range
objCell.Select
objSelection.TypeText "Website: "
Set objLink = objSelection.Hyperlinks.Add(objSelection.Range, "http://www.mycompany.com", , , "www.mycompany.com")
Set objCell = objTable.Cell(8, 2)
Set objCellRange = objCell.Range
objCell.Select
objSelection.TypeText "E-mail: "
Set objLink = objSelection.Hyperlinks.Add(objSelection.Range, "mailto: " & strEmail, , , strEmail)
objLink.Range.Font.Name = "Verdana"
objLink.Range.Font.Size = 8
objLink.Range.Font.Bold = false
objSelection.Font.Color = RGB (000,045,154)
objSelection.EndKey END_OF_STORY
objSelection.TypeParagraph()
' ####### Used Exchange 2007 for the disclaimer text to ensure all email is covered (this script forces the user to use this as the default signature, it does not however prevent them from selecting another one when writing an email. Would recommend taking a similar approach to cover yourselves.
' ########### Tells outlook to use this signature for new messages and replys. Signature is called Email Signature.
Set objSelection = objDoc.Range()
objSignatureEntries.Add "Email Signature", objSelection
objSignatureObject.NewMessageSignature = "Email Signature"
'objSignatureObject.ReplyMessageSignature = "Email Signature"
objDoc.Saved = True
objWord.Quit