如何将Excel单元格粘贴为带超链接的图片 粘贴至Outlook后可点击跳转

你原有的代码仅实现了将指定区域复制为图片存入剪贴板的功能，要实现粘贴到Outlook的图片自带超链接，需要新增Outlook对象调用、图片插入、超链接绑定的逻辑，修改后的完整代码如下：

Sub copiar_texto()
    ' 定义对象变量
    Dim outlookApp As Object
    Dim outlookMail As Object
    Dim mailDoc As Object
    Dim picShape As Object
    ' 此处替换为你需要绑定的实际超链接地址
    Const TARGET_URL As String = "https://你的目标网站地址"
    
    ' 复制指定区域为图片
    Sheets("Planilha2").Range("C4:I26").CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    
    ' 初始化Outlook对象创建新邮件
    Set outlookApp = CreateObject("Outlook.Application")
    Set outlookMail = outlookApp.CreateItem(0) ' 参数0代表创建邮件类型对象
    Set mailDoc = outlookMail.GetInspector.WordEditor ' 调用Word编辑器操作邮件正文
    
    ' 必须先显示邮件窗口，粘贴操作才能正常生效
    outlookMail.Display
    
    ' 粘贴图片到邮件正文起始位置，可根据需求调整粘贴位置
    mailDoc.Range(0, 0).Paste
    ' 选中刚粘贴的图片
    Set picShape = mailDoc.InlineShapes(1)
    
    ' 为图片绑定超链接
    mailDoc.Hyperlinks.Add Anchor:=picShape, Address:=TARGET_URL
    
    ' 清理缓存对象
    Set picShape = Nothing
    Set mailDoc = Nothing
    Set outlookMail = Nothing
    Set outlookApp = Nothing
    Application.CutCopyMode = False
    
    ' 保留原有按钮绑定逻辑
    Sheets("Planilha1").Shapes("Rounded Rectangle 4").OnAction = "copiar_texto"
End Sub

注意事项 #

• 代码默认新建空白Outlook邮件插入带超链接的图片，你可以自行补充收件人、主题、正文文本后发送
• 如果需要将图片插入到已打开的现有草稿邮件中，调整Outlook邮件对象的获取逻辑即可

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