Question

我已尽可能简化脚本。问题是在Outlook 2013的表中插入图像。此脚本适用于旧版本。

1个表，1行，2列并在单元格中使用AddPicture会杀死脚本！

objTable.Cell(1, 1).Range.Text = objSelection.InlineShapes.AddPicture(strLogo)

下面的完整脚本。任何工作都会受到赞赏。

'-------------
On Error Resume Next
Set objSysInfo = CreateObject("ADSystemInfo")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)

strName = objUser.FullName
strMail = objuser.mail
strLogo = "c:\1.jpg"

Set objWord = CreateObject("Word.Application")
objWord.Visible = False

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

objDoc.Tables.Add objRange, 1, 2
Set objTable = objDoc.Tables(1)
objTable.Cell(1, 1).Range.Text = objSelection.InlineShapes.AddPicture(strLogo) 
objTable.Cell(1, 2).select
objSelection.TypeParagraph()
objSelection.TypeText strName
objSelection.Font.Bold = false
objSelection.TypeParagraph()
objSelection.TypeText strMail

objSignatureEntries.Add "Signature", objRange
objSignatureObject.NewMessageSignature = "Signature"
objSignatureObject.ReplyMessageSignature = "Signature"

objDoc.Saved = True
objWord.Quit
'----------------

Answer 1

您的错误很明显：

objTable.Cell(1, 1).Range.Text = objSelection.InlineShapes.AddPicture(strLogo)

这不起作用，因为您尝试将.Text分配给不是字符串的内容。而且：这从来没有奏效，你从来没有注意到。

.AddPicture()已经完成了所有操作，只需在文档中选择正确的位置：

objTable.Cell(1, 1).Select
objSelection.InlineShapes.AddPicture(strLogo)

除此之外，您的脚本违反了一些基本规则。

始终使用Option Explicit。没有例外，没有＆＃34;但是＆＃34;，没有参数＆＃34;快速＆＃34;或＆＃34;仅＆＃34;。
切勿将On Error Resume Next用作全局设置。
编写函数/ subs来包装可能失败的步骤。 On Error Resume Next具有函数作用域，您可以在函数中将其打开以保护可以引发错误的行，并在函数结束时重置它。
如果您无法创建额外的功能，请使用On Error Goto 0尽快结束On Error Resume Next 的效果 ，但在您检查Err变量以自行处理错误之前，不是这样。
编写函数/ subs来构建代码。
是一个偏好问题，但我喜欢使用With块。
另一个偏好的问题，但匈牙利的符号是没有意义的。按照惯例，我使用PascalCase表示对象，camelCase表示原始值（字符串，数字，日期），以及说出变量名称。

这是一个改进版本：

Option Explicit

Dim User, logo

Set User = GetCurrentUser
logo = "C:\1.jpg"

If Not User Is Nothing Then
  CreateEmailSignature User, logo
Else
  WScript.Echo "Could not retrieve user from AD."
End If
'------------------------------------------------------------------------------

Function GetCurrentUser()
  Set GetCurrentUser = Nothing

  On Error Resume Next
  Set GetCurrentUser = GetObject("LDAP://" & CreateObject("ADSystemInfo").UserName)
End Function
'------------------------------------------------------------------------------

Sub CreateEmailSignature(ADUser, logoPath)
  Dim Doc, Table

  With CreateObject("Word.Application")
    Set Doc = .Documents.Add
    Set Table = Doc.Tables.Add(Doc.Range, 1, 2)

    Table.Cell(1, 1).Select
    InsertPictureFromFile .Selection, logoPath

    Table.Cell(1, 2).Select
    .Selection.TypeParagraph
    .Selection.TypeText ADUser.FullName
    .Selection.Font.Bold = False
    .Selection.TypeParagraph
    .Selection.TypeText ADUser.Mail

    With .EmailOptions.EmailSignature
      .EmailSignatureEntries.Add "Signature", Doc.Range
      .NewMessageSignature = "Signature"
      .ReplyMessageSignature = "Signature"
    End With

    Doc.Close False
    .Quit False
  End With
End Sub
'------------------------------------------------------------------------------

Sub InsertPictureFromFile(Selection, picturePath)
  On Error Resume Next
  Selection.InlineShapes.AddPicture picturePath
End Sub
'------------------------------------------------------------------------------

Answer 2

我发现它是64位Office问题。我使用32位Office 2013安装在多台PC上，一切正常。

升级到outlook 2013杀死了一个VBScript - 表格中的图像

2 个答案: