求高手帮助：批量插入同名照片到批注,如何设置批注显示图片为图片默认大小

jakes8989

Sub 批量插入同名照片到批注()
    Dim cell As Range, fd, t
    Selection.ClearComments
    If Selection(1) = "" Then MsgBox "不能选择空白区。", 64, "提示": Exit Sub
    On Error GoTo err
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)    '允许用户选择一个文件夹
    If fd.Show = -1 Then
        t = fd.SelectedItems(1)    '选择之后就记录这个文件夹名称
    Else
        Exit Sub    '否则就退出程序
    End If
    For Each cell In Selection
        With cell.AddComment
            .Visible = True
            .Text Text:=""
            .Shape.Select True
            With Selection.ShapeRange
                .Fill.UserPicture t & "\" & cell.Text & ".jpg"
                Selection.ShapeRange.ScaleWidth 2, msoFalse, msoScaleFromTopLeft
                Selection.ShapeRange.ScaleHeight 2, msoFalse, msoScaleFromTopLeft
            End With
            cell.Offset(1, 0).Select
            .Visible = False
        End With
    Next
    Exit Sub
err:
    ActiveCell.ClearComments
    MsgBox "未找到同名的JPG图片！", 64, "提示"
End Sub

KCFONG

Upload your file

jakes8989

Selection.ShapeRange.ScaleWidth 2, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 2, msoFalse, msoScaleFromTopLeft
就是这两句设置高宽，如何设置照片默认长宽

jakes8989

现将文件附上，请老师指点

jakes8989

请高手帮助，在线等。。。。。。

KCFONG

Sub 批量插入同名照片到批注()
    Dim cell As Range, fd, t
    Selection.ClearComments
    If Selection(1) = "" Then MsgBox "不能选择空白区。", 64, "提示": Exit Sub
    On Error GoTo err
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)    '允许用户选择一个文件夹
    If fd.Show = -1 Then
        t = fd.SelectedItems(1)    '选择之后就记录这个文件夹名称
    Else
        Exit Sub    '否则就退出程序
    End If
    For Each cell In Selection
        With cell.AddComment
            .Visible = True
            .Text Text:=""
            .Shape.Select True
            Selection.ShapeRange.Fill.UserPicture t & "\" & cell.Text & ".jpg"
            
            .Shape.Width = 200   'Add these 2 statement
            .Shape.Height = 144
            
            cell.Offset(1, 0).Select
            .Visible = False
        End With
    Next
    Exit Sub
err:
    ActiveCell.ClearComments
    MsgBox "未找到同名的JPG图片！", 64, "提示"
End Sub

jakes8989

KCFONG 发表于 2011-9-28 10:32
Sub 批量插入同名照片到批注()
    Dim cell As Range, fd, t
    Selection.ClearComments

这样好像是固定了照片的长宽，没有达到显示图片原大小的目的

KCFONG

Sub 批量插入同名照片到批注()
    Dim cell As Range, fd, t
    Selection.ClearComments
    If Selection(1) = "" Then MsgBox "不能选择空白区。", 64, "提示": Exit Sub
    On Error GoTo err
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)    '允许用户选择一个文件夹
    If fd.Show = -1 Then
        t = fd.SelectedItems(1)    '选择之后就记录这个文件夹名称
    Else
        Exit Sub    '否则就退出程序
    End If
   
    For Each cell In Selection
             ActiveSheet.Pictures.Insert(t & "\" & cell.Text & ".jpg").Select
             fswith = Selection.Width
             fsheight = Selection.Height
                Selection.Delete
        With cell.AddComment
            .Visible = True
            .Text Text:=""
            .Shape.Select True
              Selection.ShapeRange.Fill.UserPicture t & "\" & cell.Text & ".jpg"
            .Shape.Width = fswith   'Add these 2 statement
            .Shape.Height = fsheight
            cell.Offset(1, 0).Select
            .Visible = False
        End With
    Next
    Exit Sub
err:
    ActiveCell.ClearComments
    MsgBox "未找到同名的JPG图片！", 64, "提示"
End Sub

jakes8989

KCFONG 发表于 2011-9-28 11:26
Sub 批量插入同名照片到批注()
    Dim cell As Range, fd, t
    Selection.ClearComments

谢谢，达到效果

jakes8989

KCFONG 发表于 2011-9-28 11:26
Sub 批量插入同名照片到批注()
    Dim cell As Range, fd, t
    Selection.ClearComments

追问老师一个问题，就是显示的图片，按屏幕大小自缩放
就是太大的图片可全部在屏幕内显示，这个问题不知能否解决（过小的图片不用管）