一键批量插入图片的2个疑难问题（已解决，方案上传供分享）

zjdh

在2007和2003中，我的2个宏都可以正常运行！

zjdh

改一下
Private Sub CommandButton3_Click()
    On Error Resume Next
    Dim rngTemp As Range, k As Range, shpPic As Picture
    filepath = ThisWorkbook.Path & "\"
    Set rngTemp = Application.InputBox("图片插入区域：", "选择单元格", Type:=8)
    For Each k In rngTemp
        With k
            Filename = Dir(filepath & .Value & "*.jpg")
            If k <> "" And Filename <> "" Then
                ActiveSheet.Shapes.AddPicture filepath & Filename, False, True, .Left, .Top, .Width, .Height
                .ClearComments
                .AddComment
                .Comment.Shape.Fill.UserPicture filepath & "\" & .Value & ".jpg"
                .Comment.Shape.Height = 240
                .Comment.Shape.Width = 320
            End If
        End With
    Next
End Sub

lk710618

zjdh 发表于 2014-8-3 20:07
这句改一下
If k  "" and Filename  "" Then ActiveSheet.Shapes.AddPicture filepath & Filename, False, ...

老师，改过后，还是一样的结果，图片正确、批注正确，就是会报错，要不停的点击确定

zjdh

多此一举的办法
Private Sub CommandButton1_Click()
    On Error Resume Next
    Dim rngTemp As Range, k As Range, shpPic As Picture
    filepath = ThisWorkbook.Path & "\"
    Set rngTemp = Application.InputBox("图片插入区域：", "选择单元格", Type:=8)
    For Each k In rngTemp
        With k
            Filename = Dir(filepath & .Value & "*.jpg")
            If k <> "" And Filename <> "" Then
                ActiveSheet.Shapes.AddPicture filepath & Filename, False, True, .Left, .Top, .Width, .Height
                .ClearComments
                .AddComment
                .Comment.Shape.Fill.UserPicture filepath & "\" & .Value & ".jpg"
                .Comment.Shape.Height = 240
                .Comment.Shape.Width = 320
                 Filename = ""
           End If
        End With
    Next
End Sub

lk710618

zjdh 发表于 2014-8-3 20:19
多此一举的办法
Private Sub CommandButton1_Click()
    On Error Resume Next

非常感谢zjdh老师的耐心指点！非常感谢！完美解决！
老师，我考虑到经常需要筛选资料看图片，防止筛选后图片重叠，给代码加了几句，您看可适合？

Private Sub CommandButton1_Click()
    On Error Resume Next
    Dim rngTemp As Range, k As Range, shpPic As Picture
    filepath = ThisWorkbook.Path & "\"
    Set rngTemp = Application.InputBox("图片插入区域：", "选择单元格", Type:=8)
    For Each k In rngTemp
        With k
            Filename = Dir(filepath & .Value & "*.jpg")
            If k <> "" And Filename <> "" Then
                ActiveSheet.Shapes.AddPicture filepath & Filename, False, True, .Left, .Top, .Width, .Height
                .ClearComments
                .AddComment
                .Comment.Shape.Fill.UserPicture filepath & "\" & .Value & ".jpg"
                .Comment.Shape.Height = 240
                .Comment.Shape.Width = 320
                 Filename = ""
           End If
        End With
    Next
    filepath = ThisWorkbook.Path '（改变插入图片的属性）
    ActiveSheet.Shapes.SelectAll
    Selection.Placement = xlMoveAndSize
    Range("A1").Select
End Sub




秉承老师的精神，感觉好东西就是要分享的，我把做好的资料附上，供大家参考！

zjdh

filepath = ThisWorkbook.Path   完全无关
Selection.Placement = xlMoveAndSize    是你要的效果吗？

lk710618

zjdh 发表于 2014-8-4 08:23
filepath = ThisWorkbook.Path   完全无关
Selection.Placement = xlMoveAndSize    是你要的效果吗？

老师，我测试了一下，只能去掉这一句：
filepath = ThisWorkbook.Path '（改变插入图片的属性）
其他不能去除，ActiveSheet.Shapes.SelectAll去除的话，不能将图片设为大小和位置随单元格而变，
Range("A1").Select去除的话，VBA运行结束时，会选中所有图片，包括控件本身，看着不爽

老师，再次谢谢你！

zjdh

我不是说要去除其他语句，只是说是否是你需要的效果，若对了就行。

lk710618

zjdh 发表于 2014-8-5 07:43
我不是说要去除其他语句，只是说是否是你需要的效果，若对了就行。

老师，再次想麻烦你一下
FilePath = ThisWorkbook.Path & "\"
这一句的含义应该是指，找到在这个execl同一文件夹下的图片，但如果我的excel文件和图片放置的不在一个文件夹，甚至图片是放置在多个文件夹的，我需要多次选择文件夹来插入图片，那么这一句改怎么改，才能是变成可选文件夹的？

Set fd = Application.FileDialog(msoFileDialogFolderPicker)    '允许用户选择一个文件夹
    If fd.Show = -1 Then
        t = fd.SelectedItems(1)    '选择之后就记录这个文件夹名称
    Else
        Exit Sub    '否则就退出程序
    End If

这个我加进去，好像又有点不对，想再次麻烦老师！要学习的可真多！

zjdh

Private Sub CommandButton1_Click()
    On Error Resume Next
    Dim rngTemp As Range, k As Range, shpPic As Picture
    Set rngTemp = Application.InputBox("图片插入区域：", "选择单元格", Type:=8)
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    If fd.Show = -1 Then
        filepath = fd.SelectedItems(1) & "\"
    Else
        Exit Sub
    End If   
    For Each k In rngTemp
        With k
            Filename = Dir(filepath & .Value & "*.jpg")
            If k <> "" And Filename <> "" Then
                ActiveSheet.Shapes.AddPicture filepath & Filename, False, True, .Left, .Top, .Width, .Height
                .ClearComments
                .AddComment
                .Comment.Shape.Fill.UserPicture filepath & "\" & .Value & ".jpg"
                .Comment.Shape.Height = 240
                .Comment.Shape.Width = 320
                 Filename = ""
           End If
        End With
    Next
    ActiveSheet.Shapes.SelectAll
    Selection.Placement = xlMoveAndSize
    Range("A1").Select
End Sub