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

lk710618

经过多处收集VBA ，我做了一个资料，希望实现一键批量将图片分别插入到指定单元格内和批注内，也可以一键删除，以实现单元格看小图，批注看大图，但是现在遇到2个问题：

1、点击插入控件时，跳出的单元格区域选择，只能选择插入单元格内图片的区域，而不能同时选择插入批注的区域，请问如何修改VBA，可以实现一次选择区域，可以同时指定单元格图片插入和批注图片插入的区域？

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

此半成品求老师改进！！！
此表如果改好，将是我们经常要进行图、货比较人员的福音，望路过的老师、高手们出手指导！



感谢zjdh 老师的耐心指导！完美解决方法上线（2个版本）：1、可选插入区域；
2、可选插入图片来源文件夹；
3、1个控件的方便一次插入，2个控件的方便多次插入不同区域。

lk710618

补充一下，我的Excel是2013版本

VBA板块热心的朋友都不在吗？请出手吧！

lk710618

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 ActiveSheet.Range("a2:M" & ActiveSheet.Range("a500").End(3).Row)
    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


其中这一句：
For Each rng In ActiveSheet.Range("a2:M" & ActiveSheet.Range("a500").End(3).Row)
我不会改，如何让这一句变成可选区域，请大师相助！
这一句是影响插入的图片是链接或者真正图片的关键吗：
Set picTemp = ActiveSheet.Pictures.Insert(picPath)

AVEL

lk710618 发表于 2014-8-2 12:47
Private Sub CommandButton1_Click()
On Error Resume Next                                             ...

For Each rng In picTemp

lk710618

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, picPath$, picTemp As Picture              '设定图片名称所在单元格区域
    filepath = ThisWorkbook.Path & "\"
    Set rngTemp = Application.InputBox("图片插入区域：", "选择单元格", Type:=8)
    For Each k In rngTemp                                                                               '循环插入图片
        k.Select                          '选择插入图片的位置（ActiveSheet.Pictures(k & k.Row).Delete '删除单元格中原来的图片）
        Set picTemp = ActiveSheet.Pictures.Insert(filepath & Trim(k) & ".jpg")      '插入图片
        picTemp.Placement = xlMoveAndSize                                           '设置图片可以随单元格的变动而改变大小和位置
        With picTemp.ShapeRange
            .Top = Selection.Top
            .Left = Selection.Left
            .LockAspectRatio = msoFalse                                               '取消图片纵横比锁定
            .Height = Selection.Height                                                '设置所插入图片的高度与单元格的高度相等
            .Width = Selection.Width                                                  '设置所插入图片的宽度与单元格的宽度相等
        End With
        Set picTemp = Nothing                                                       '重置图片对象
        If k.Comment Is Nothing And Dir(filepath & Trim(k) & ".jpg") <> "" Then     '（标注中插入图片）
            k.AddComment
            k.Comment.Shape.Fill.UserPicture filepath & "\" & Trim(k) & ".jpg"
            k.Comment.Shape.Height = 240
            k.Comment.Shape.Width = 320
        End If
    Next
End Sub
Private Sub CommandButton2_Click()
    ActiveSheet.Range("A:M").ClearComments    '删除选区内的批注
    For Each shp In ActiveSheet.Shapes
        If Not shp.Type = msoOLEControlObject Then shp.Delete
    Next
End Sub

lk710618

zjdh 发表于 2014-8-3 09:26
Private Sub CommandButton1_Click()
    On Error Resume Next                                         ...

非常感谢zjdh老师！调整好的这个结果对我帮助太大了，非常实用！

lk710618

zjdh 发表于 2014-8-3 09:26
Private Sub CommandButton1_Click()
    On Error Resume Next                                         ...

老师，第一个问题解决了，第二个问题好像还是存在，表格一旦发给别人，或者自己电脑上图片一旦删除、移动文件夹，单元格内的图片就看不到了（批注栏内可以看到，但单元格内看不到）。如有可能，还望指教！

lk710618

zjdh 发表于 2014-8-3 09:26
Private Sub CommandButton1_Click()
    On Error Resume Next                                         ...

老师，我在论坛搜到一个帖子，应该是和我遇到的情况差不多，他说：
“我之前是使用ActiveSheet.Pictures.Insert(Fullfilepath).Select  插入的，这个是使用录制宏中的代码，在2010中保存不了，现在改成
Application.Dialogs(xlDialogInsertPicture).Show    可以保存了！”

可是我看不懂，我把改前改后的表格测试了一下，确实解决了这个不能保存图片的问题，原VBA是：

Sub insertPic()
    Dim i As Integer
    Dim path As String
    Dim rng As Range
    Dim s As String
    Dim filename As String
      With Sheet1
      path = ThisWorkbook.path
      ChDir (path)
        For i = 2 To .Range("b65536").End(xlUp).Row
        filename = Dir(ThisWorkbook.path & "\*" & Cells(i, 2).Text & "*.jpg")
           
           If filename <> "" Then
             .Pictures.Insert(path & "\" & filename).Select
                Set rng = .Cells(i, 1)
                With Selection
                    .Top = rng.Top + 1
                    .Left = rng.Left + 1
                    .Width = rng.Width - 1
                    .Height = rng.Height - 1
                End With
            Else
                s = s & Chr(10) & .Cells(i, 2).Text
            End If
        Next
        .Cells(2, 1).Select
    End With
    If s <> "" Then
        MsgBox s & Chr(10) & "没有照片!"
    End If
End Sub

改后的VBA是：

Sub insertPic()
    Dim i As Integer
    Dim path As String
    Dim shpPic As Shape
    Dim rng As Range
    Dim s As String
    Dim filename As String
      With Sheet1
      path = ThisWorkbook.path
      ChDir (path)
        For i = 2 To .Range("b65536").End(xlUp).Row
        filename = Dir(ThisWorkbook.path & "\*" & Cells(i, 2).Text & "*.jpg")
        
         If filename <> "" Then
           Set rng = .Cells(i, 1)
        Set shpPic = ActiveSheet.Shapes.AddPicture(path & "\" & filename, msoFalse, msoTrue, rng.Left + 1, rng.Top + 1, -1, -1)
               
         
              
               
            Else
                s = s & Chr(10) & .Cells(i, 2).Text
            End If
        Next
        .Cells(2, 1).Select
    End With
    If s <> "" Then
        MsgBox s & Chr(10) & "没有照片!"
    End If
End Sub

麻烦老师也给我诊断一下！非常感谢！

zjdh

不会啊，我这很正常啊。