求助大神，写一个批量插入图片的VBA，微信红包表心意

liguoyuan180

求助各位大神，能不能帮小弟写一个在excel里批量插入图片的VBA啊，就是我选中一个单元格，然后点击插入选择图片，它自动在选中单元格的那一列插入图片就行了，图片能够自动适应单元格大小就好。谢谢各位了……成了微信发红包。

liguoyuan180

谢过各位了

sdkjdnyy

这个好像不难吧，搜索一下，

七彩屋

在这里论坛里搜索一下，有很多类似的

暮雨倾城

你试一试这个

liguoyuan180

暮雨倾城 发表于 2019-11-11 15:32
你试一试这个

这个怎么不能多选啊，谢谢了

liguoyuan180

七彩屋 发表于 2019-11-11 14:56
在这里论坛里搜索一下，有很多类似的

老板，我从没接触过编程的嘛，除了大学的C语言，已经完全还给老师了

liguoyuan180

sdkjdnyy 发表于 2019-11-11 14:36
这个好像不难吧，搜索一下，

没接触过编程啊，只有当伸手党了

小花鹿

liguoyuan180 发表于 2019-11-11 16:17
没接触过编程啊，只有当伸手党了

你的要求不详细，也没有附件，别人也只能给大体的建议或代码了                                                  

liguoyuan180

小花鹿 发表于 2019-11-11 17:58
你的要求不详细，也没有附件，别人也只能给大体的建议或代码了                                         ...

大神帮我看看这个嘛，这个VBA就能满足需要，唯一不满足的就是插入的是图片链接，我想改成内嵌图片而不是图片链接。自己也有了解过，是Pictures.Insert的问题，要改成shape.addpictuer,但我不会啊

Sub 批量插入图片且自适应单元格()

    Dim fileNames As Variant
    Dim fileName As Variant
    Dim fileFilter As String

    '所有图片文件后面的括号为中文括号
    fileFilter = ("所有图片文件（*.jpg;*.bmp;*.png;*.gif;*.jpeg）,*.jpg;*.bmp;*.png;*.gif;*.jpeg")
    fileNames = Application.GetOpenFilename(fileFilter, , "请选择要插入的图片", , MultiSelect:=True)

    '循环次数
    Dim i As Single
    i = 0
    '忽略错误继续执行VBA代码，避免出现错误消息（数组fileNames为空时，会报错）
    On Error Resume Next
    '循环插入
    For Each fileName In fileNames

        '将图片插入到活动的工作表中&选中该图片
        With ActiveSheet.Pictures.Insert(fileName).Select

            '图片自适应单元格大小
            Dim picW As Single, picH As Single
            Dim cellW As Single, cellH As Single
            Dim rtoW As Single, rtoH As Single
            '鼠标所在单元格的宽度
            cellW = ActiveCell.Width
            '鼠标所在单元格的高度
            cellH = ActiveCell.Height
            '图片宽度
            picW = Selection.ShapeRange.Width
            '图片高度
            picH = Selection.ShapeRange.Height
            '重设图片的宽和高
            rtoW = cellW / picW * 0.95
            rtoH = cellH / picH * 0.95
            If rtoW < rtoH Then
                Selection.ShapeRange.ScaleWidth rtoW, msoFalse, msoScaleFromTopLeft
            Else
                Selection.ShapeRange.ScaleHeight rtoH, msoFalse, msoScaleFromTopLeft
            End If
            picW = Selection.ShapeRange.Width
            picH = Selection.ShapeRange.Height
            '锁定图片锁定纵横比
            Selection.ShapeRange.LockAspectRatio = msoTrue
            '图片的位置与大小随单元格变化而变化
            Selection.Placement = xlMoveAndSize
            '设置该图片的所在位置
            Selection.ShapeRange.IncrementLeft (cellW - picW) / 2
            Selection.ShapeRange.IncrementTop (cellH - picH) / 2 + cellH * i
        End With
        i = i + 1
    '下一个
    Next fileName

End Sub