时间戳

首页 > 解决方案 > 双击一个单元格以使用 VBA 显示来自 Excel 中链接的图片

excel - 双击一个单元格以使用 VBA 显示来自 Excel 中链接的图片

问题描述

我有以下功能，如果您将鼠标移到它上面，它会显示一张图片。它非常整洁，效果很好。但是，我想将其从在其上运行鼠标更改为双击功能。

以下是当您在单元格上运行鼠标时将显示图片的代码：

Dim DoOnce As Boolean
Public Function OnMouseOver(URL As String, TheCell As Range)

DoOnce = True
    With ActiveSheet.Pictures.Insert(URL)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = 570
            .Height = 380
        End With
        .Left = Cells(TheCell.Row, TheCell.Column + 1).Left
        .Top = Cells(TheCell.Row, TheCell.Column + 1).Top
        .Placement = 1
        .PrintObject = True
    End With
End Function

而且我知道我需要下面的代码，如果你双击它会发生一些事情：

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Address = "$A$1" Then
        'do something
    End If
    Cancel = True
End Sub

我似乎无法将两者合并-以便获得原始代码的功能，但需要双击而不是将鼠标移到单元格上。

初始代码按顺序为我的计算机上的图片引用一个串联的图片查找地址以进行处理。随着更多图片的生成，我用公式复制新的链接，这快速、简单、容易，这就是为什么我要保留初始代码的“OnMouseOver”功能，这样我就可以轻松地将其复制到新的单元格中。我只想将图片显示为双击，而不是像当前工作那样在单元格上运行鼠标。

如果我能帮上忙，那将是一个很大的帮助。

谢谢，

史蒂夫

标签： excelvba

解决方案

当“双击”进入 Excel 单元格的编辑时，可能会导致对现有值/公式的不希望的编辑。所以，我会推荐Worksheet_SelectionChange活动。您也可以将它与导航/箭头键一起使用。

将以下代码粘贴到 VBA - 相关的“工作表”对象

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim url As String

On Error Resume Next 'to avoid error if the target cell does not have url
'Even if we can use URLExists function to avoid such error,
'there will still be errors when there is value but not recognised by the function.
'For example an error caused by function =100/0

ActiveSheet.Pictures.Delete

'If URLExists(Target.Value) Then
'As we are using "on error resume next statement we don't need this.
'here is a link to this function
'https://stackoverflow.com/a/25428811/9808063

url = Target.Value

With Me.Pictures.Insert(url)
    With .ShapeRange
        .LockAspectRatio = msoTrue
        .Width = 300
        .Height = 200
    End With
    .Left = Cells(Target.Row + 2, Target.Column + 1).Left
    .Top = Cells(Target.Row + 2, Target.Column + 1).Top
    .Placement = 1
    .PrintObject = True
End With
'End If
End Sub

推荐阅读