用VBA代码，显示单元格批注图片

木胛

老师您好，学生向您求助。
当光标点击C列(图片名称)某一单元格，或同一行D列的单元格时，则显示所在文件夹B列与"图片名称"相符的图片。只有当光标点击才有批注，而不是单元格已事先插入了批注。是否可以考虑批注高宽尺寸应随图片高宽尺寸变化而自动变化，如图片高宽为6:9，则批注尺寸也为6:9，如图片为9:6，则批注也随之变为9:6。
谢谢您。

^星^

批注图片.zip (998.72 KB, 下载次数: 30)

2024-3-20 23:43 上传

点击文件名下载附件

木胛

^星^ 发表于 2024-3-20 23:44

老师您好，正是学生所需要的。只是点击C1、C2、D1、D2时代码出现运行错误。
另，要是批注尺寸可以设置放大比例就好了，如设置A1单元格为放大比例，当A1=1时，放大比例不变，A1=2时，批注尺寸放大2倍，依次类推，不知可否实现？
谢谢老师。

^星^

批注图片.zip (1008.56 KB, 下载次数: 19)

2024-3-21 17:17 上传

点击文件名下载附件

gwjkkkkk

Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim strPath$, strFileName$, ar&()
   
    If Target.Count > 1 Then Exit Sub
    If Target.Column <> 4 Then Exit Sub
    If Target.Row < 3 Then Exit Sub
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & Target.Offset(, -2).Value & "\" & Target.Offset(, -1).Value & ".jpg"
    If Dir(strFileName) <> "" Then
        Cells.ClearComments
        With Target
            ar = GetPic(strFileName)
            .AddComment
            With .Comment
                .Visible = True
                .Shape.Fill.UserPicture strFileName
                .Text Text:=" "
                .Shape.Height = ar(0): .Shape.Width = ar(1)
            End With
        End With
    End If
End Sub
Function GetPic(ByVal strFileName$) As Long()
    Dim ar&(1)
    Dim Img As Object
    With CreateObject("WIA.ImageFile")
        .LoadFile strFileName
        ar(0) = .Height: ar(1) = .Width
    End With
    GetPic = ar
End Function

gwjkkkkk

木胛 发表于 2024-3-21 00:41
老师您好，正是学生所需要的。只是点击C1、C2、D1、D2时代码出现运行错误。
另，要是批注尺寸可以设置放 ...

按图片实际大小显示，请参考。。。

木胛

gwjkkkkk 发表于 2024-3-21 19:33
按图片实际大小显示，请参考。。。

老师您好，您的批注尺寸正是学生所需，可否能再次帮助学生。在原有代码基础上添加完善批注尺寸。谢谢您了。

gwjkkkkk

木胛 发表于 2024-3-22 09:21
老师您好，您的批注尺寸正是学生所需，可否能再次帮助学生。在原有代码基础上添加完善批注尺寸。谢谢您了 ...

不知道是不是这样，按自己的代码改的。。。

木胛

gwjkkkkk 发表于 2024-3-22 21:42
不知道是不是这样，按自己的代码改的。。。

老师，真的挺好的，谢谢您了。