0

我已将脚本简化为尽可能简单。问题是在 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
'----------------
4

2 回答 2

2

你的错误很明显：

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

这不起作用，因为您尝试分配给.Text不是字符串的东西。此外：这从未奏效，您只是从未注意到。

.AddPicture()已经做了所有你想要的，只需在文档中选择正确的位置之前：

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

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

  • 始终使用Option Explicit. 没有例外，没有“但是”，没有“快速”或“仅”的参数。
  • 永远不要On Error Resume Next用作全局设置。
  • 编写函数/子程序来总结可能失败的步骤。On Error Resume Next具有函数作用域，您可以在函数中将其打开以保护可能引发错误的行，并在函数结束时将其重置。
  • 如果您不能/不想创建额外的函数，请使用尽快On Error Goto 0结束效果，但不要在您检查变量以自己处理错误之前。On Error Resume Next Err
  • 编写函数/子程序来构建您的代码。
  • 一个偏好问题，但我喜欢使用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
'------------------------------------------------------------------------------
于 2014-07-21T12:04:40.733 回答
0

我发现这是一个 64 位的 Office 问题。我已经使用 32 位 Office 2013 在多台电脑上重新安装，一切正常。

于 2014-08-26T04:51:25.510 回答