为何VBA宏在不同工作簿运行异常：邮件正文重复粘贴图片

我写的VBA代码用于遍历工作表所有图片并逐一粘贴到Outlook邮件正文，在自己的工作簿运行正常，但其他用户使用时出现异常：他的工作簿里有2张图片，运行后1张正常粘贴，另一张被重复粘贴3次。把他的图片复制到我的工作簿里运行没问题，但把我的正常工作簿发给他，他那边运行还是会出现图片重复粘贴的问题，我本地运行依旧正常。请问为什么不同工作簿在不同用户端运行结果有差异？

原代码 #

Sub SendEmailWithPicture()
    Dim doc As Object, x, signature, xMailBody2, xMailBody1
    Dim shp As Shape

    With CreateObject("outlook.application").CreateItem(0)
        .Display
        signature = .HTMLBody
        Set doc = .GetInspector.WordEditor
        
        xMailBody1 = "<BODY>Hi Joe, <br><br>This is the first paragraph<br><br></BODY>"
        
        .HTMLBody = ""
        
        For Each shp In ActiveSheet.Shapes
            If Left(shp.Name, 3) = "Pic" Then shp.Copy
        
            x = doc.Range.End - 1
            doc.Range(x).Paste
            
            x = doc.Range.End - 1
            doc.Range(x) = vbNewLine & vbNewLine
        Next shp
        
        xMailBody2 = "<BODY><br>Thank you for your assistance. <br> <br>" & _
                     "Best regards,</BODY>"
        
        .HTMLBody = xMailBody1 & .HTMLBody & xMailBody2 & signature
        
        .To = "someone@somewhere.com"
        .Subject = "My subject"
        
        Application.CutCopyMode = 0
    End With
    
End Sub

可能的原因及解决思路 #

• Shape对象遍历范围有误
  原代码遍历所有形状，但用户的工作表可能存在分组形状（Group）里的子形状、隐藏形状或名称以"Pic"开头的非图片形状（比如占位符），导致循环时重复处理了同一个图片的关联实例。你的工作簿形状结构干净，所以无异常。
  解决：限定只处理真正的图片类型，修改判断条件为：If shp.Type = msoPicture And Left(shp.Name, 3) = "Pic" Then，跳过分组、文本框等其他形状。

• 剪贴板同步延迟
  不同用户的系统性能、Office版本（32位/64位）差异，可能导致shp.Copy后剪贴板未及时更新就执行Paste，重复粘贴上一次的内容。你的机器性能较好，剪贴板同步快，因此无问题。
  解决：在shp.Copy后添加DoEvents让系统完成剪贴板操作，或者短延迟：Application.Wait Now + TimeValue("00:00:01")。

• WordEditor的Range定位偏差
  不同Office版本中，doc.Range.End - 1的计算逻辑可能存在差异，导致粘贴位置错误，视觉上呈现为重复粘贴。
  解决：改用更可靠的定位方式，比如每次粘贴后将光标移至文档末尾：Set doc.Range = doc.Range(doc.Range.End, doc.Range.End)，再插入换行。

• 工作表形状属性差异
  用户的图片可能通过不同方式插入（如截图粘贴、跨文档导入），导致形状名称存在隐藏空格/特殊字符，或生成了关联的冗余形状，使得Left(shp.Name,3)="Pic"误匹配多个对象。
  解决：让用户在VBA编辑器中添加Debug.Print shp.Name，输出所有形状名称，排查是否有不符合预期的对象被纳入循环。

修正后的代码示例 #

Sub SendEmailWithPicture()
    Dim doc As Object, x, signature, xMailBody2, xMailBody1
    Dim shp As Shape

    With CreateObject("outlook.application").CreateItem(0)
        .Display
        signature = .HTMLBody
        Set doc = .GetInspector.WordEditor
        
        xMailBody1 = "<BODY>Hi Joe, <br><br>This is the first paragraph<br><br></BODY>"
        
        .HTMLBody = ""
        
        For Each shp In ActiveSheet.Shapes
            ' 仅处理类型为图片且名称以Pic开头的形状
            If shp.Type = msoPicture And Left(shp.Name, 3) = "Pic" Then
                shp.Copy
                DoEvents ' 等待剪贴板同步完成
                x = doc.Range.End - 1
                doc.Range(x).Paste
                
                x = doc.Range.End - 1
                doc.Range(x) = vbNewLine & vbNewLine
            End If
        Next shp
        
        xMailBody2 = "<BODY><br>Thank you for your assistance. <br> <br>" & _
                     "Best regards,</BODY>"
        
        .HTMLBody = xMailBody1 & .HTMLBody & xMailBody2 & signature
        
        .To = "someone@somewhere.com"
        .Subject = "My subject"
        
        Application.CutCopyMode = 0
    End With
    
End Sub

内容的提问来源于stack exchange，提问作者k1dr0ck