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

AVEL

AVEL 发表于 2014-8-2 16:15
For Each rng In picTemp

你不会改的那句  改成这样就好了。

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")
            Set shpPic = ActiveSheet.Shapes.AddPicture(filepath & Filename, False, True, .Left + 1, .Top + 1, .Width, .Height)
            If Dir(filepath & .Value & ".jpg") <> "" Then
                .ClearComments
                .AddComment
                .Comment.Shape.Fill.UserPicture filepath & "\" & Trim(k) & ".jpg"
                .Comment.Shape.Height = 240
                .Comment.Shape.Width = 320
            End If
        End With
    Next
End Sub

lk710618

zjdh 发表于 2014-8-3 13:43
不会啊，我这很正常啊。

老师，我是2013版Office，跟版本有关系的

lk710618

zjdh 发表于 2014-8-3 15:30
那就这样吧
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 <> "" Then ActiveSheet.Shapes.AddPicture filepath & Filename, False, True, .Left, .Top, .Width, .Height
            If Dir(filepath & .Value & ".jpg") <> "" Then
                .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

AVEL 发表于 2014-8-3 14:30
你不会改的那句  改成这样就好了。

老师，改成后是这样的：

Private Sub CommandButton1_Click()
On Error Resume Next                                                        '设置错误处理
Application.ScreenUpdating = False                                          '关闭屏幕刷新
Dim rngTemp As Range, k As Range, picPath$, picTemp As Picture              '设定图片名称所在单元格区域
Set rngTemp = Application.InputBox("图片插入区域：", "选择单元格", Type:=8)
For Each k In rngTemp                                                       '循环插入图片
k.Offset(0, 0).Select                                                       '选择插入图片的位置（ActiveSheet.Pictures(k & k.Row).Delete '删除单元格中原来的图片）
picPath = ThisWorkbook.Path & "\" & Trim(k) & ".jpg"                        '定义插入图片的地址
Set picTemp = ActiveSheet.Pictures.Insert(picPath)                          '插入图片
picTemp.Name = k & k.Row                                                    '设定所插入图片的名称
picTemp.Placement = xlMoveAndSize                                           '设置图片可以随单元格的变动而改变大小和位置
With picTemp.ShapeRange
  .LockAspectRatio = msoFalse                                               '取消图片纵横比锁定
  .Height = Selection.Height                                                '设置所插入图片的高度与单元格的高度相等
  .Width = Selection.Width                                                  '设置所插入图片的宽度与单元格的宽度相等
End With
Set picTemp = Nothing                                                       '重置图片对象
Next
Application.ScreenUpdating = True                                           '打开屏幕刷新
filepath = ThisWorkbook.Path                                                '（标注中插入图片）
For Each rng In picTemp
    If rng.Comment Is Nothing And Dir(filepath & "\" & rng.Value & ".jpg") <> "" Then
        rng.AddComment
        rng.Comment.Shape.Fill.UserPicture filepath & "\" & rng.Value & ".jpg"
        rng.Comment.Shape.Height = 240
        rng.Comment.Shape.Width = 320
    End If
    Next
End Sub

可是，这样既不能解决图片的链接问题，也不能解决插入批注选择区域的问题，根本就不插入批注了

闻启学

lk710618 发表于 2014-8-3 19:10
老师，改成后是这样的：

Private Sub CommandButton1_Click()

插入单元格的图片，不是真正的图片，好像只是一个链接，一旦表格发给别人，就看不到图片了(图片很多，不适合发给别人)，请问，如何修改VBA可以实现直接将图片插入单元格内，而不是链接？

这个还未 解决 ， 我研究过 在2010里 用ActiveSheet.Pictures.Insert 这个模式 是以链接形式产生的  

换一下  ActiveSheet.shapes.addpicture(图片名称 ，true，true，图片左边的位置，图片的顶点，图片的高度，图片的宽度)

lk710618

zjdh 发表于 2014-8-3 19:08
你再试试
Private Sub CommandButton1_Click()
    On Error Resume Next

非常感谢您，老师！不会出现错插图片的情况了，但是，每有一个非空单元格，一旦找不到图片，就会出现一次报错（如上图2），如何取消这样的报错呢？

lk710618

闻启学 发表于 2014-8-3 19:22
插入单元格的图片，不是真正的图片，好像只是一个链接，一旦表格发给别人，就看不到图片了(图片很多，不适 ...

zjdh老师的VBA已经实现保存图片了，现在就是还有查不到图片的会报错待解决了

zjdh

难道2010版容错语句不生效？
On Error Resume Next