0
Wordテンプレートとプレースホルダを使用してOutlook署名を生成し、Outlookで生成された署名を設定するこのスクリプトが見つかりました。 - 評判が10を超えないためにリンクが削除されました -vbs Outlook Signature、2010/2016と比較した2013年の別の結果 - Selection.GoTo？
私のニーズに合わせていくつか修正しましたが、Outlook 2010と2016でテストするとうまくいきました。 Outlook 2013。プレースホルダは関連情報に置き換えられていません。
On Error Resume Next
Const wdWord = 2
Const wdParagraph = 4
Const wdExtend = 1
Const wdCollapseEnd = 0
strTemplatePath = "\\server\dir\"
strTemplateName = "SignatureTemplate.docx"
strReplyTemplateName = "SignatureTemplateReply.docx"
'----- Connect to AD and get user info -----'
Set objSysInfo = CreateObject("ADSystemInfo")
Set WshShell = CreateObject("WScript.Shell")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)
strFirstname = objUser.FirstName
strLastName = objUser.givenName
strDepartment = objUser.Department
strInitials = objUser.initials
strName = objUser.FullName
strTitle = objUser.Title
strDescription = objUser.Description
strOffice = objUser.physicalDeliveryOfficeName
strCred = objUser.info
strStreet = objUser.StreetAddress
strLocation = objUser.l
strPostCode = objUser.PostalCode
strPhone = objUser.TelephoneNumber
strMobile = objUser.Mobile
strFax = objUser.FacsimileTelephoneNumber
strEmail = objUser.mail
strWeb = ""
'New Signature
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open(strTemplatePath & strTemplateName,,True)
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries
SearchAndRep "[Name]", strName, objWord
If strTitle = "" Then
SearchAndRep "[Title]", (objDoc.Bookmarks("title").Range.Paragraphs(1).Range.Delete), objDoc
Else SearchAndRep "[Title]", strTitle, objWord
End If
If strDepartment = "" Then
SearchAndRep "[Department]", (objDoc.Bookmarks("department").Range.Paragraphs(1).Range.Delete), objDoc
Else SearchAndRep "[Department]", strDepartment, objWord
End If
SearchAndRep "[Phone]", strPhone, objWord
If strMobile = "" Then
SearchAndRep "[Mobile]", (objDoc.Bookmarks("mobile").Range.Paragraphs(1).Range.Delete), objDoc
Else SearchAndRep "[Mobile]", strMobile, objWord
End If
SearchAndRep "[Fax]", strFax, objWord
SearchAndRep "[OfficePhone]", strOfficePhone, objWord
SearchAndRep "[email]", strEmail, objWord
SearchAndRep "[web]", strWeb, objWord
If strOffice = "" Then
SearchAndRep "[Office]", (objDoc.Bookmarks("office").Range.Paragraphs(1).Range.Delete), objDoc
Else SearchAndRep "[Office]", strOffice, objWord
End If
SearchAndRepHyperlink "[email]", strWeb, objDoc
SearchAndRepHyperlink "[web]", strWeb, objDoc
Set objSelection = objDoc.Range()
objSignatureEntries.Add "Full Signature", objSelection
objSignatureObject.NewMessageSignature = "Full Signature"
'see note below if a different reply signature is desired
'objSignatureObject.ReplyMessageSignature = "Reply Signature"
objDoc.Saved = TRUE
objDoc.Close
objWord.Quit
'______________________
'Reply Signature
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open(strTemplatePath & strReplyTemplateName,,True)
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries
SearchAndRep "[Name]", strName, objWord
If strTitle = "" Then
SearchAndRep "[Title]", (objDoc.Bookmarks("title").Range.Paragraphs(1).Range.Delete), objDoc
Else SearchAndRep "[Title]", strTitle, objWord
End If
If strDepartment = "" Then
SearchAndRep "[Department]", (objDoc.Bookmarks("department").Range.Paragraphs(1).Range.Delete), objDoc
Else SearchAndRep "[Department]", strDepartment, objWord
End If
SearchAndRep "[Phone]", strPhone, objWord
If strMobile = "" Then
SearchAndRep "[Mobile]", (objDoc.Bookmarks("mobile").Range.Paragraphs(1).Range.Delete), objDoc
Else SearchAndRep "[Mobile]", strMobile, objWord
End If
SearchAndRep "[Fax]", strFax, objWord
SearchAndRep "[OfficePhone]", strOfficePhone, objWord
SearchAndRep "[email]", strEmail, objWord
SearchAndRep "[web]", strWeb, objWord
If strOffice = "" Then
SearchAndRep "[Office]", (objDoc.Bookmarks("office").Range.Paragraphs(1).Range.Delete), objDoc
Else SearchAndRep "[Office]", strOffice, objWord
End If
SearchAndRepHyperlink "[email]", strWeb, objDoc
SearchAndRepHyperlink "[web]", strWeb, objDoc
Set objSelection = objDoc.Range()
objSignatureEntries.Add "Reply Signature", objSelection
objSignatureObject.ReplyMessageSignature = "Reply Signature"
objDoc.Saved = TRUE
objDoc.Close
objWord.Quit
'----- Subrouting to search and replace template text placeholders -----
Sub SearchAndRep(searchTerm, replaceTerm, WordApp)
WordApp.Selection.GoTo 1
With WordApp.Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = True
.Text = searchTerm
.Execute ,,,,,,,,,replaceTerm
End With
End Sub
'----- Subrouting to search and replace template hyperlink placeholders -----
' Note this can be picky...if it does not work re-create hyperlink in the template
Sub SearchAndRepHyperlink(searchLink, replaceLink, WordDoc)
Set colHyperlinks = WordDoc.Hyperlinks
For Each objHyperlink in colHyperlinks
If objHyperlink.Address = searchLink Then
objHyperlink.Address = replaceLink
End If
Next
End Sub
'WScript.Echo "Signature set"
私はこの記事を見つけた - 答えはSelection.GoToが正しく設定されていないことが示唆されたhttps://social.msdn.microsoft.com/Forums/office/en-US/67184929-d7da-4fba-875b-0e1371f46f2f/vbscript-for-outlook-signature-not-work-with-office-2013?forum=worddev。私は彼の提案に従ったが、これは問題を解決しないだろう。
残りのコードは2013年に動作するようですが、Wordテンプレートが使用され、Outlookにコピーされて署名として設定されますが、プレースホルダはアクティブなディレクトリ情報に置き換えられません。 [名前]
タイトルのために非常に多くの
[OfficePhone]
[モバイル]
おかげ
：だから（展望2013年）の署名は、のように設定されてしまいますあなたの時間。