VBA 插入批注

Sub pictopz()
    Dim cell As Range, fd, t, w As Byte, h As Byte
    Selection.ClearComments
    If Selection(1) = "" Then MsgBox "不能选择空白区。", 64, "提示": Exit Sub
On Error Resume Next '错误继续

    On Error GoTo err
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)    '允许用户选择一个文件夹
    If fd.Show = -1 Then
        t = fd.SelectedItems(1)    '选择之后就记录这个文件夹名称
    Else
        Exit Sub    '否则就退出程序
    End If
    w = Application.InputBox("您希望插入的图片显示多宽?" & Chr(10) & "Excel默认宽度为3.39,你可以输入1-15之间的数据。" & Chr(10) & "小于1时当做1计算。", "确认宽度", 3.39, , , , , 2)
    h = Application.InputBox("您希望插入的图片显示多高?" & Chr(10) & "Excel默认高度为2.09,你可以输入1-15之间的数据。" & Chr(10) & "小于1时当做1计算。", "确认高度", 2.09, , , , , 2)
    If w < 1 Or h < 1 Then w = 3.39: h = 2.09
    If w > 15 Or h > 15 Then MsgBox "原则上你的图片可以显示这么大," & Chr(10) & "不过有必要吗?请重新输入1-15之间的数", 64, "提示": Exit Sub
    For Each cell In Selection
        With cell.AddComment
            .Visible = True
            .Text Text:=""
            .Shape.Select True
            With Selection.ShapeRange
                .Fill.UserPicture t & "\" & cell.Text & ".jpg"
                .ScaleWidth w / 3.39, msoFalse, msoScaleFromTopLeft
                .ScaleHeight h / 2.09, msoFalse, msoScaleFromTopLeft
            End With
            cell.Offset(1, 0).Select
            .Visible = False
        End With
    Next
    Exit Sub
err:
    ActiveCell.ClearComments
    MsgBox "未找到同名的JPG图片!", 64, "提示"
End Sub

评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值