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

ww0000

学习一下，很有用处

lk710618

zjdh 发表于 2014-8-5 18:56
Private Sub CommandButton1_Click()
    On Error Resume Next
    Dim rngTemp As Range, k As Range,  ...

老师我不太懂VBA，这次学习到很多内容，感触也很深，谢谢你！很迷茫的一点是，虽然照搬来老师们的很多好的代码，可是很多实在是看不懂，真不知如何入手学习
老师，我又参考别人的资料，把控件合二为一了，测试了一下，很好用

Private Sub CommandButton1_Click()
With CommandButton1
   If .Caption = "删除" Then
    ActiveSheet.Range("A:ZZ").ClearComments    '删除选区内的批注
    For Each shp In ActiveSheet.Shapes
        If Not shp.Type = msoOLEControlObject Then shp.Delete
    Next
         .Caption = "插入"
         .BackColor = &HFFFF&            '按钮黄色
      Exit Sub
   End If
   If .Caption = "插入" Then
    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
          .Caption = "删除"
          .BackColor = &HFF&              '按钮红色
      Exit Sub
   End If
End With
End Sub
好东西，继续分享！

zjdh

lk710618 发表于 2014-8-6 00:19
老师我不太懂VBA，这次学习到很多内容，感触也很深，谢谢你！很迷茫的一点是，虽然照搬来老师们的很多好的 ...

不过不适合于多区域分别插入图片

lk710618

zjdh 发表于 2014-8-6 14:15
不过不适合于多区域分别插入图片

是的，所以我两个版本都留着

lxfeng118

老师您好，看了您和lk710618的帖子，自己研究专研了一下，可惜鄙人愚笨，没能领会老师的精华，但是工作需要的确需要老师帮助，楼主的代码我试了很好用，不过我工作用的时候不能有那个按钮啊，：我从网上下的代码


Sub 插入图片()

    On Error Resume Next    '设置错误处理
    'Application.ScreenUpdating = False    '关闭屏幕刷新
    Dim rngTemp As Range, k As Range, picPath$, picTemp As Picture
    '设定图片名称所在单元格区域
    Worksheets("站点勘测表").Activate
    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.Shapes.AddPicture(picPath).Select    '插入图片
        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    '打开屏幕刷新
End Sub
这个代码运行后 非常适用我得工作需要，但是图片是链接模式的，发给别人以后，别人就看不了了，和楼主的情况一样，但是楼主的共享代码是按钮的，我不会弄，不适用我的工作需要，还望老师，能帮忙改写以上代码，让图片不是链接模式的，谢谢

lk710618

lxfeng118 发表于 2014-8-24 17:14
老师您好，看了您和lk710618的帖子，自己研究专研了一下，可惜鄙人愚笨，没能领会老师的精华，但是工作需要 ...

把附件发上来看看

lxfeng118

楼主 请看 附件，图片 我没都上传，图要灌满 相应的 合并单元格

谢谢了

zjdh

lxfeng118 发表于 2014-8-24 23:57
楼主 请看 附件，图片 我没都上传，图要灌满 相应的 合并单元格

谢谢了

插入图片.rar (233.18 KB, 下载次数: 302)

2014-8-25 15:53 上传

点击文件名下载附件

lxfeng118

zjdh 发表于 2014-8-25 15:51

谢谢，非常好用~  非常感谢老师，给做好了 插件~ 哈哈~~ 我 私信你了，，加个QQ好友吧~

zjdh

我很少上QQ，有事还是论坛见吧。