自动插入图片问题求助

xinpingex

用Pictures.Insert 插入图片后 由于图片是链接导致其他电脑不能显示。
求大神帮忙该一下。使用Shape.AddPicture 或者其他方式解决  
图片在G:\公司产品图集
目标 实现同样的功能。
1、根据A列名称 在图集找到相应的图片 插入到D列
2、插入之前先删除现有的照片。
3、插入图片不是链接。
附原有代码

Dim i, arr, str, typ, shp

On Error Resume Next                                          '忽略运行中可能出现的错误

Application.ScreenUpdating = False                            '关闭工作表更新，提高运行速度

Set mysheet1 = ThisWorkbook.Worksheets("生产计划单")              '定义Sheet1工作表

arr = Array(".jpg", ".jpeg", ".png", ".bmp", ".gif", ".tif")  '图片格式集合

For Each shp In mysheet1.Shapes

If shp.Left > mysheet1.Columns("C").Left And shp.Left < mysheet1.Columns("F").Left Then

  shp.Delete   '如果是D-E列单元格里边的图片，则删除

End If

Next

For i = 2 To 1000      '从第2行到1000行

If mysheet1.Cells(i, 2) <> "" Then   '如果B列对应的单元格不为空白，则执行

     For Each typ In arr               '执行图片格式组里面的每一个尝试

      str = "G:\公司产品图集\" & mysheet1.Cells(i, 2).Value & typ  '图片路径

        If Dir(str) <> "" Then                             '如果图片存在，则执行

          mysheet1.Pictures.Insert(str).Select        '插入图片并选择

           With Selection.ShapeRange

            .LockAspectRatio = msoFalse               '不锁定图片的比例

            .Height = mysheet1.Cells(i, 4).Height - 4 '图片的高度设为单元格高度-4

            .Width = mysheet1.Cells(i, 4).Width - 4   '图片的宽度设为单元格高度-4

            .Top = mysheet1.Cells(i, 4).Top + 2       '图片的位置为D列对应单元格到顶部的距离+2

            .Left = mysheet1.Cells(i, 4).Left + 2     '图片的位置为D列对应单元格到左侧的距离+2

           End With

            mysheet1.Cells(i, 4) = ""                 '清空D列对应单元格的内容

          Exit For                                    '导入图片后，退出For循环

        Else

       End If

      Next

End If

Next

mysheet1.Cells(i + 1, 4).Select

Application.ScreenUpdating = True    '恢复更新显示

End Sub

xinpingex

自顶  小白鼠求大神们帮忙
谢谢

xinpingex

自顶 求帮忙

蓝桥玄霜

上述代码在执行中有什么问题？没有附件不能测试代码。

xinpingex

蓝桥玄霜 发表于 2019-2-21 10:53
上述代码在执行中有什么问题？没有附件不能测试代码。

之前摸索用 Pictures.Insert 来批量插入图片，运行没有问题。结果发现这些图片是链接形式，其他人接收到无法正常显示图片。所以想直接插入图片方式保存在excel里。上网查了有Shapes.AddPicture的方式，但是试过几次都没有成功。求帮忙给我改一下。改成图片是插入形式的。谢谢

xinpingex

附近已经回复。感谢帮忙。

xinpingex

                                         
将文中    mysheet1.Pictures.Insert(str).Select  
换成   Set st = ActiveSheet.Shapes.AddPicture(str, True, True, 10, 10, 10, 10).Select  

问题解决  不知道我这样改合不合理