Excel vba 添加批注参考图_弹出选择窗口版.vba

Sub 添加标注参考图_弹出选择窗口版()
'单选一个格子，打开选择文件窗口，选择图片确定。
'图片会入去作为批注背景图插入单元格。
'2015-07-06 笨笨
'上次等比缩放写错了，已经修正
'2015-11-10

On Error Resume Next

    Dim j_h, j_w, ww, initialPath
    Dim k '当前单元格
    
    Set k = Selection
    
    initialPath = ThisWorkbook.Path & "\images\"
    
    If Dir(initialPath, vbDirectory) = vbNullString Then
        initialPath = ThisWorkbook.Path
    End If
    
    
    '选择单一文件
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = initialPath
        .AllowMultiSelect = False '单选择，多选开关
        .Filters.Clear '清除文件过滤器
        .Filters.Add "图片", "*.png;*.jpg;*.bmp;*.gif" '设置两个文件过滤器，这是第一个
        .Filters.Add "所有文件", "*.*" '设置两个文件过滤器，这是第二个
    If .Show = -1 Then 'FileDialog 对象的 Show 方法显示对话框，并且返回 -1（如果您按 OK）和 0（如果您按 Cancel）。
        'MsgBox "您选择的文件是：" & .SelectedItems(1), vbOKOnly + vbInformation, "文件"
        filepath = .SelectedItems(1)
        Else
        GoTo gotoEnd
    End If
    
    End With
    
    '加载文件，看在不在。
    Filename = Dir(filepath)
    '加载图片，用于获取长宽。
    Set p = ActiveSheet.Pictures.Insert(filepath)
    
    '如果图片不存在，设置单元格为红色，结束此函数
    If p Is Nothing Then
        k.Interior.Color = RGB(192, 0, 0) '红色
        GoTo gotoEnd
    End If
    
    '这货他妈的不是像素是 点
    j_h = p.ShapeRange.Height
    j_w = p.ShapeRange.Width
    
    '如果图片大于 ww 等比缩放到 ww
    ww = 300
    If j_h > ww Then
    j_w = ww / j_h * j_w
    j_h = ww
    End If
    '取到长宽就删除图片，没有利用价值了
    ActiveSheet.Pictures.Delete
    
    With k
    '非空就可以插插了
    If Not k Is Nothing And Not Filename Is Nothing Then
        .ClearComments
        .AddComment
        .Comment.Shape.Fill.UserPicture PictureFile:=filepath
        .Comment.Shape.Height = j_h
        .Comment.Shape.Width = j_w
        '.Comment.Visible = True
        '.Interior.Color = RGB(155, 187, 89)
    End If
    End With
    
gotoEnd:

End Sub

参考资料

Docs 》Office VBA 参考 》Excel 》Excel Graph Visual Basic 参考 》方法 》UserPicture