Jeg kan godt dele mit script. Jeg har fået det til at virke for længe siden (tak morten).
Der er dog tilføjet en hel del, bla en log. En mere erfaren scripter vil nok kunne optimere min kode en hel del, men sådan er det jo altid. Der er så også en hulens masse referencer der skal ændres for at du kan benytte dig af det. God fornøjelse:
'==================================================================
'========================== Declarations ==========================
'==================================================================
Const sRM_NormalDot = "\\HERA\Documents\Marketing\02 Corporate Identity\04 Templates\01 Word\00 Released\Normal.dotm"
Const sNormalDotmFolder = "\Microsoft\Templates\"
Const sCompany = "Resultmaker A/S"
Const sAddress = "Vester Farimagsgade 3"
Const sZipCode = "1606 Copenhagen"
Const sCountry = "Denmark"
Const sCompTlf = "+45 70 20 10 21"
Const sCompFax = "+45 70 20 08 21"
Const sCompWeb = "
www.resultmaker.com"Const iFC_CompanyNameRed = 169
Const iFC_CompanyNameGreen = 188
Const iFC_CompanyNameBlue = 192
Const iFC_TextRed = 0
Const iFC_TextGreen = 0
Const iFC_TextBlue = 0
Const sLogFile = "AutoSignature.log"
Const sLogFolder = "c:\Logon_Script_logs"
Const wdLineSpaceSingle = 0
Const ForAppending = 8
Dim sAppPath, sResult, sPCRole, sWordVersion, sUserName, sName, sTitle, sDepartment, sMobile, sEmail, sLog, sFile
Dim oFSO, oShell, oWord, oSelection, oLogFile, oSysInfo, oUser, oEmailOptions, oEmailSignature, oEmailSignatureEntries
Dim bWarnings
Dim i
'******************
'** SCRIPT START **
'******************
bWarnings = False
'logfolder creation and logfile deletion
Set oFSO = CreateObject("Scripting.FileSystemObject")
sLog = sLogFolder & "\" & sLogFile
If oFSO.FolderExists(sLogFolder) = False Then
oFSO.CreateFolder sLogFolder
End If
If oFSO.FileExists(sLog) Then
oFSO.DeleteFile sLog
End If
ReportProgress "======================================"
ReportProgress "= Script started " & Date() & " " & time() & " ="
ReportProgress "======================================" & vbCrLf
CheckForRequirements
CollectUserInfo
WriteSignatures
Cleanup
'****************
'** SCRIPT END **
'****************
'===============================================================
'========================== Functions ==========================
'===============================================================
Function CheckForRequirements
ReportProgress "*******************************"
ReportProgress "** Checking for requirements **"
ReportProgress "*******************************"
sPCRole = CheckComputerRole
'PCROLE
If sPCRole <> "Member Workstation" Then
ReportProgress "FAILURE - The computer is not a Workstation, but a " & sPCRole & " - Quiting script"
'there's no reason for a message box when the script exits because the user logs on to a server
WScript.Quit
Else
ReportProgress "SUCCESS - The computer is a Workstation"
End If
sWordVersion = CheckWordVersion
'WORD VERSION
If sWordVersion = "" Then
ReportProgress "FAILURE - Word is not installed. Quiting Autosignatur script"
EarlyQuit
Else
ReportProgress "SUCCESS - Word is installed ( " & sWordVersion & " )"
End If
'RM_NORMALDOTM
If oFSO.FileExists(sRM_NormalDot) = 0 Then
ReportProgress "FAILURE - The Resultmaker version of 'Normal.dotm' is _NOT_ found on the lokationen " & sRM_NormalDot & " - Quiting Autosignatur script"
EarlyQuit
Else
ReportProgress "SUCCESS - The Resultmaker version of 'Normal.dotm' is found on the lokation " & sRM_NormalDot
End If
'DELETE LOCAL NORMALDOTM
Set oShell = CreateObject("Wscript.Shell")
sAppPath = oShell.ExpandEnvironmentStrings("%appdata%")
If oFSO.FileExists(sAppPath & sNormalDotmFolder & "Normal.dotm") Then
wscript.sleep 1000
On Error Resume Next
Err.Clear
i = 0
Do
oFSO.DeleteFile sAppPath & sNormalDotmFolder & "Normal.dotm"
If Err.Number = 0 Or i = 10 Then
Exit Do
Else
i = i + 1
WScript.Sleep 1000
End If
Loop
If Err.Number <> 0 Or i = 10 Then
ReportProgress "FAILURE - Error happend while trying to delete " & sAppPath& sNormalDotmFolder & "Normal.dotm * " & Err.Description & "* - Quiting Autosignatur script"
EarlyQuit
Else
ReportProgress "SUCCESS - " & sAppPath & sNormalDotmFolder & "Normal.dotm deleted after waiting for " & i & " seconds. Word will now start with a default normal.dotm"
End If
Else
ReportProgress "WARNING - The file " & sAppPath & sNormalDotmFolder & "Normal.dotm not found. The script continues..."
bWarnings = True
End If
End Function 'CheckForRequirements
Function CheckComputerRole
Dim sComputer
Dim oWMIService, oComputer
Dim colComputers
sComputer = "."
Set oWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & sComputer & "\root\cimv2")
Set colComputers = oWMIService.ExecQuery("Select DomainRole from Win32_ComputerSystem")
For Each oComputer in colComputers
Select Case oComputer.DomainRole
Case 0
CheckComputerRole = "Standalone Workstation"
Case 1
CheckComputerRole = "Member Workstation"
Case 2
CheckComputerRole = "Standalone Server"
Case 3
CheckComputerRole = "Member Server"
Case 4
CheckComputerRole = "Backup Domain Controller"
Case 5
CheckComputerRole = "Primary Domain Controller"
End Select
Next
Set oWMIService = Nothing
End Function 'CheckComputerRole
Function CheckWordVersion
On Error Resume Next
Err.Clear
Set oWord = CreateObject("Word.Application")
On Error Goto 0
If Err.Number = 0 Then
Select Case oWord.Version
Case "9.0" CheckWordVersion = "Word 2000"
Case "10.0" CheckWordVersion = "Word XP"
Case "11.0" CheckWordVersion = "Word 2003"
Case "12.0" CheckWordVersion = "Word 2007"
Case Else CheckWordVersion = "Unknown version (" & oWord.Version & ")"
End Select
Else
CheckWordVersion = ""
'Word could not be found
End If
oWord.Quit
Set oWord = Nothing
End Function 'CheckWordVersion
Sub CollectUserInfo
ReportProgress "*********************************"
ReportProgress "** Collecting User Information **"
ReportProgress "*********************************"
Set oSysInfo = CreateObject("ADSystemInfo")
On Error Resume Next
Err.Clear
sUserName = oSysInfo.UserName
Set oUser = GetObject("
LDAP://" & sUserName)
If Err.Number = 0 Then
ReportProgress "SUCCESS - User found in AD"
Err.Clear
Else
ReportProgress "FAILURE - Error finding user in AD! * " & Err.Description & " *"
EarlyQuit
End If
sName = oUser.FullName
sTitle = oUser.Title
sDepartment = oUser.Department
sMobile = oUser.Mobile
sEmail = oUser.mail
ReportProgress "SUCCESS - Userinformation collected"
End Sub 'CollectUserInfo
Sub WriteSignatures
ReportProgress "************************"
ReportProgress "** Writing signatures **"
ReportProgress "************************"
On Error Resume Next
Err.Clear
'Setting up Word
Set oWord = CreateObject("Word.Application")
oWord.Visible = False
oWord.Documents.Add
Set oSelection = oWord.Selection
If Err.Number = 0 Then
ReportProgress "SUCCESS - Starting Word"
Else
ReportProgress "FAILURE - Problem occured when trying to start Word * " & Err.Description & " *"
EarlyQuit
End If
'Setting Email options
Set oEmailOptions = oWord.EmailOptions
Set oEmailSignature = oEmailOptions.EmailSignature
Set oEmailSignatureEntries = oEmailSignature.EmailSignatureEntries
If Err.Number = 0 Then
ReportProgress "SUCCESS - Connecting to Outlook signature part"
Else
ReportProgress "FAILURE - Connecting to Outlook signature part * " & Err.Description & " *"
EarlyQuit
End If
'Writing the "NEW MAIL" signature in Word
oSelection.Font.Name = "Verdana"
oSelection.Font.Size = "10"
oSelection.Font.Color = RGB(iFC_TextRed, iFC_TextGreen, iFC_TextBlue )
oSelection.TypeText Chr(11) & Chr(11) & Chr(11)
oSelection.Font.Size = "8"
oSelection.TypeText sName & Chr(11)
oSelection.TypeText sTitle
If sDepartment <> "" Then
oSelection.TypeText ", " & sDepartment
End If
oSelection.TypeText Chr(11) & Chr(11)
oSelection.Font.Color = RGB(iFC_CompanyNameRed, iFC_CompanyNameGreen, iFC_CompanyNameBlue)
oSelection.Font.Bold = True
oSelection.TypeText sCompany
oSelection.Font.Color = RGB(iFC_TextRed, iFC_TextGreen, iFC_TextBlue )
oSelection.Font.Bold = False
oSelection.TypeText Chr(11)
oSelection.TypeText sAddress & Chr(11)
oSelection.TypeText sZipCode & Chr(11)
oSelection.TypeText sCountry & Chr(11)
oSelection.TypeText "T: " & sCompTlf& Chr(11)
oSelection.TypeText "F: " & sCompFax & Chr(11)
If sMobile <> "" Then
oSelection.TypeText "M: " & sMobile & Chr(11)
End If
oSelection.Hyperlinks.Add oSelection.Range, "mailto:" & sEmail,,sEmail, sEmail & Chr(11)
oSelection.Hyperlinks.Add oSelection.Range, "
http://" & sCompWeb,, sCompWeb, sCompWeb
oSelection.EndKey
oSelection.MoveLeft 2, 2, 2
oSelection.Font.Name= "Verdana"
oSelection.Font.Size = "8"
oSelection.Font.Color = RGB(iFC_TextRed, iFC_TextGreen, iFC_TextBlue)
Set oSelection = oWord.ActiveDocument.Range
oSelection.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
If Err.Number = 0 Then
ReportProgress "SUCCESS - Writing the signature for a NEW MAIL in Word"
Else
ReportProgress "FAILURE - Writing the signature for a NEW MAIL in Word * " & Err.Description & " *"
EarlyQuit
End If
'Adding the NEW MAIL signature to available signatures in Outlook
oEmailSignatureEntries.Add "RM_Signature_new", oSelection
If Err.Number = 0 Then
ReportProgress "SUCCESS - Adding the NEW MAIL signature"
Else
ReportProgress "FAILURE - Adding the NEW MAIL signature * " & Err.Description & " *"
EarlyQuit
End If
'Writing the "REPLY MAIL" signature in Word
Set oSelection = oWord.Selection
oSelection.WholeStory
oSelection.Delete
oSelection.Font.Name = "Verdana"
oSelection.Font.Size = "8"
oSelection.TypeText Chr(11)
oSelection.TypeText "/" & sName
Set oSelection = oWord.ActiveDocument.Range
If Err.Number = 0 Then
ReportProgress "SUCCESS - Writing the signature for a REPLY MAIL in Word"
Else
ReportProgress "FAILURE - Writing the signature for a REPLY MAIL in Word * " & Err.Description & " *"
EarlyQuit
End If
'Adding the REPLY MAIL signature to available signatures in Outlook
oEmailSignatureEntries.Add "RM_Signature_reply", oSelection
If Err.Number = 0 Then
ReportProgress "SUCCESS - Adding the REPLY MAIL signature"
Else
ReportProgress "FAILURE - Adding the REPLY MAIL signature * " & Err.Description & " *"
EarlyQuit
End If
'Setting "New mail" and "Reply mail" signatures in Outlook
oEmailSignature.NewMessageSignature = "RM_Signature_new"
oEmailSignature.ReplyMessageSignature = "RM_Signature_reply"
If Err.Number = 0 Then
ReportProgress "SUCCESS - Setting the signatures in Outlook"
Else
ReportProgress "FAILURE - Setting the signatures in Outlook * " & Err.Description & " *"
EarlyQuit
End If
On Error Goto 0
oWord.ActiveDocument.Saved = True
oWord.Quit
Set oWord = Nothing
End Sub 'WriteSignatures
Sub ReportProgress(sMessage)
Set oFile = oFSO.OpenTextFile(sLog, ForAppending, True)
If sMessage = "" Then
oFile.WriteLine
Else
oFile.WriteLine Time() & " - " & sMessage
End If
oFile.Close
End Sub ' ReportProgress
Sub Cleanup
ReportProgress "*****************"
ReportProgress "** Cleaning up **"
ReportProgress "*****************"
On Error Resume Next
i = 0
Do
Err.Clear
oFSO.CopyFile sRM_NormalDot, sAppPath & "\Microsoft\Templates\"
If Err.Number <> 0 Then
WScript.Sleep 1000
i = i + 1
End If
Loop Until Err.Number = 0 Or i = 10
If Err.Number = 0 Then
ReportProgress "SUCCESS - The Resultmaker version of NORMAL.DOTM restored after sleeping for " & i & " seconds"
End If
If i = 10 Then
ReportProgress "FAILURE - The Resultmaker version of NORMAL.DOTM could not be restored. * " & Err.Description & "*"
EarlyQuit
End If
On Error Goto 0
If bWarnings = True Then
ReportProgress ""
ReportProgress "=============================="
ReportProgress "= Script ended with Warnings ="
ReportProgress "=============================="
Else
ReportProgress ""
ReportProgress "=============================="
ReportProgress "= Script ended with Success ="
ReportProgress "=============================="
End If
WScript.Quit
End Sub 'Cleanup
Sub EarlyQuit
MsgBox "See " & sLog & " for more info",vbcritical, "The script 'AutoSignature' ended with an error!"
On Error Resume Next
oWord.quit
Set oWord = Nothing
On Error Goto 0
ReportProgress ""
ReportProgress "================="
ReportProgress "= Script FAILED ="
ReportProgress "================="
WScript.Quit
End Sub 'EarlyQuit
