execl 自动加载目录下图片

在项目实施的过程中 ，给员工拍照了。但时候不好插在谁拍了，命名有没有错误等原因，需要直观的查看，并给员工自行验证

综合需求，在网上找个相关资料查看。然后根据实际情况汇总。得带的解决办法如下：

1、把人员信息相关导入

2、打开 execl 表的宏功能 ，新增宏

3、变形宏代码

代码如下：

Sub AutoAddPic()
    Application.ScreenUpdating = False
   
   
For Each Shp In ActiveSheet.Shapes
   If Shp.Type = msoPicture Then Shp.Delete
    Next
    Dim MyPcName As String, picTemp As Picture
    For i = 2 To ThisWorkbook.ActiveSheet.UsedRange.Rows.Count
    ‘If (ActiveSheet.Cells(i, 1).Value = "姓名") Then
       
        ‘ActiveSheet.Pictures().Delete ‘删除单元格中原来的图片
       
        MyPcName = ActiveSheet.Cells(i, 1).Value & ActiveSheet.Cells(i, 3).Value & ".jpg"
        ActiveSheet.Cells(i, 6).Delete
        ActiveSheet.Cells(i, 6).Select
        Dim MyFile As Object
        Set MyFile = CreateObject("Scripting.FileSystemObject")
        ‘插入图片
         If MyFile.FileExists(ThisWorkbook.Path & "\" & "人员信息" & "\" & MyPcName) = True Then
            Set picTemp = ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & "人员信息" & "\" & MyPcName)
            ‘picTemp.Name = k & k.Row ‘设定所插入图片的名称
            picTemp.Placement = xlMoveAndSize ‘设置图片可以随单元格的变动而改变大小和位置
            With picTemp.ShapeRange
                .LockAspectRatio = msoFalse ‘取消图片纵横比锁定
                 .Height = Cells(i, 6).Height - 1 ‘设置所插入图片的高度与单元格的高度相等
                 .Width = Cells(i, 6).Width - 1 ‘设置所插入图片的宽度与单元格的宽度相等
            End With
           
          ‘  picTemp.Select
           
            Set picTemp = Nothing ‘重置图片对象
  
         End If
         ‘If MyFile.FileExists(ThisWorkbook.Path & "\" & "人员信息" & "\" & MyPcName) = False Then
        ‘MsgBox ThisWorkbook.Path & "\" & "111" & "\" & MyPcName & "暂无图片"
        ‘Else
        ‘ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & "人员信息" & "\" & MyPcName).Select
        ‘End If
   ‘ End If
   
    Next i
    Application.ScreenUpdating = True
   
End Sub