如何批量将本工作簿内不同页不同位置不同大小的刘亦菲的照片全部替换为萌娃的图片？

joforn

其实这个很简单的。


直接把文件中的图片换了就行了。

cjc209

Jason_WangSS 发表于 2020-12-4 08:02
长宽比可以试一下

Sub 批量替换图片()
    str1 = ThisWorkbook.Path & "\萌娃.jpg" '替换成的照片'
    Application.ScreenUpdating = False
    For Each sh In Sheets
        sh.Select
        For Each shp In sh.Shapes '对象循环
            If shp.Type = 13 Then
                t = shp.Top '照片位置信息
                l = shp.Left
                W = shp.Width
                H = shp.Height
                If Round(W, 4) = 117.5629 And Round(H, 4) = 144.1665 Then '替换条件
                    shp.Delete
                    ActiveSheet.Pictures.Insert(str1).Select '插入图片
                    With Selection
                        .ShapeRange.LockAspectRatio = msoFalse
                        .Left = l '与原来照片一样的位置及大小
                        .Top = t
                        .Width = W
                        .Height = H
                    End With
                End If
            End If
            [a1].Activate '取消照片选择
        Next shp
    Next sh
    Application.ScreenUpdating = True
End Sub

joforn

longkui1990 发表于 2020-12-4 09:34
实际上是需要将表格中公司的老logo换成新logo
但是内容较多，表格中还有很多其他的图片，也不能一替换就 ...

关键在于你的文件有多少？
如果只是少数一些文件那么就简单了了。
但如果你的文件数量很多，而且不能保证所有图片都是用的同一张的话那就复杂多了。

joforn

给你几种思路：
第一种：每次手动替换单个中的所有图片。就是先用代码把所有图片在窗体中列出来，你自己手动选择要替换的图片，然后由程序把所有被选中的图片替换，这个精确度高，但是要一个一个文件去打开，运行程序才能替换完成；
第二种：一次性把所有文件中的图片全部提取出来到一个文件夹，然后由你自己删除掉其中要被替换的图片文件，最后，由程序检测目录中被删掉的图片文件名，再根据文件名去把所有文件中对应的图片替换掉，这种方式和第一种方式差不多，但是比较适合文件数多的那种情况；
第三种：图片对比识别，就是把所有图片和要被替换掉的旧图片进行相似度对比，如果相似度高，那么把文件中的图片换成新图片，这种适合文件数多，图片来源复杂，但是这个代码难度比较大。

小花鹿

估计这是一次性的工作，如果是这样，手工做吧，写代码不值得，即使写代码也是半自动的，还要靠人来判断是不是刘亦菲

liulang0808

longkui1990 发表于 2020-12-4 09:34
实际上是需要将表格中公司的老logo换成新logo
但是内容较多，表格中还有很多其他的图片，也不能一替换就 ...

如果是每张表内，被替换图片名称固定，可以参考下面的代码，见红色代码部分
另外图片的长宽可以调整h跟w对应的参数
Sub addpicture()
    str1 = ThisWorkbook.Path & "\萌娃.jpg"
    Application.ScreenUpdating = False
    For Each sh In Sheets
        sh.Select
        For Each shp In sh.Shapes
            If shp.Name = "图片 1" Then

                t = shp.Top
                l = shp.Left
                w = shp.Width
                h = shp.Height
                shp.Delete
                ActiveSheet.Pictures.Insert(str1).Select
                With Selection
                    .ShapeRange.LockAspectRatio = msoFalse
                    .Left = l
                    .Top = t
                    .Width = w
                    .Height = h
                End With
            End If
        Next shp
    Next sh

    Application.ScreenUpdating = True
End Sub

longkui1990

liulang0808 发表于 2020-12-4 11:41
如果是每张表内，被替换图片名称固定，可以参考下面的代码，见红色代码部分
另外图片的长宽可以调整h跟w ...

大神好
现在在附件的xlsm中，刘亦菲都是图片 1，祝绪丹都是图片 2
但是为啥点运行还是没反应呢
麻烦帮忙再看看
谢谢啦

批量替换图片 3rd.rar (1.01 MB, 下载次数: 2)

2020-12-4 20:47 上传

点击文件名下载附件

当家的MAX

1. Sub test()
   
2. Dim i, j, k, l, m As Integer
   
3. For i = 1 To Sheets.Count
   
4.     With Sheets(i).Shapes(1)
   
5.         j = .Left
   
6.         k = .Top
   
7.         l = .Width
   
8.         m = .Height
   
9.         .Delete
   
10.     End With
    
11.     Sheets(i).Shapes.AddPicture ThisWorkbook.Path & "\萌娃.jpg", _
    
12.     msoFalse, msoTrue, j, k, l, m
    
13. Next
    
14. End Sub

复制代码

处理你传的附件是够用了，得看你实际情况是不是也这么简单

liulang0808

longkui1990 发表于 2020-12-4 20:47
大神好
现在在附件的xlsm中，刘亦菲都是图片 1，祝绪丹都是图片 2
但是为啥点运行还是没反应呢

Sub addpicture()
    str1 = ThisWorkbook.Path & "\萌娃.jpg"
    Application.ScreenUpdating = False
    For Each sh In Sheets
        sh.Select
        For Each shp In sh.Shapes
            If shp.Name = "Picture 1" Then

                t = shp.Top
                l = shp.Left
                w = shp.Width
                h = shp.Height
                shp.Delete
                ActiveSheet.Pictures.Insert(str1).Select
                With Selection
                    .ShapeRange.LockAspectRatio = msoFalse
                    .Left = l
                    .Top = t
                    .Width = w
                    .Height = h
                End With
            End If
        Next shp
    Next sh

    Application.ScreenUpdating = True
End Sub

liulang0808

附件内容供参考。。。。。。。