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

 

 

-----经过测试 以上代码 保存的都是文件路径 不符合要求，然后在网上查找相关资料

代码如下：

Dim s$, fNm$

Sub pic()
Application.ScreenUpdating = False

Dim MyPcName As String, picTemp As Picture, pohtopath As String, path As String


Dim s As Shape, rng As Range

For i = 2 To ThisWorkbook.ActiveSheet.UsedRange.Rows.Count

pohtopath = "信息化与计量中心"
MyPcName = ActiveSheet.Cells(i, 1).Value & ActiveSheet.Cells(i, 3).Value & ".jpg"
path = ThisWorkbook.path & "\" & pohtopath & "\" & MyPcName
ActiveSheet.Cells(i, 6).Delete
ActiveSheet.Cells(i, 6).Select
' MsgBox pohtopath
' rng = ActiveSheet.Cells(6, 1)
ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveSheet.Cells(i, 6).Left, ActiveSheet.Cells(i, 6).Top, ActiveSheet.Cells(i, 6).Width, ActiveSheet.Cells(i, 6).Height).Select

Set MyFile = CreateObject("Scripting.FileSystemObject")
If MyFile.FileExists(path) = True Then
Selection.ShapeRange.Fill.UserPicture path

Else


pth = ThisWorkbook.path & "\" & pohtopath & "\" '输入指定文件夹
Call FindFileName(pth, CStr(CLng(ActiveSheet.Cells(i, 1)))) '递归搜寻子文件夹

' MsgBox fNm '打开搜寻到的文件
If MyFile.FileExists(fNm) = True Then
Selection.ShapeRange.Fill.UserPicture fNm

End If


fNm = ""


End If

Set picTemp = Nothing

Next i
Application.ScreenUpdating = True

 

End Sub

Sub FindFileName(pth, ByVal keys As String) '递归搜寻代码
If fNm <> "" Then Exit Sub '找到后退出递归
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(pth)
For Each f In fld.Files '遍历每个子文件夹中的所有文件
If InStr(f.Name, keys) Then '用instr方法比对文件名称是否包含指定字符
fNm = f.path
Exit Sub '找到后退出递归
End If

' Call FindFileName(fd.Path) '本文件夹检查完毕后，继续深层搜素其子文件夹
Next
End Sub

 

在运行之前，注意修改路径

由于单反拍的照片比较大，所以在保存之前需要进行照片压缩 ，