VBA-Track 添加图片

Dim s$, fNm$ '定义公共变量：关键词s和文件名结果fNm

Sub FindFile()
Dim Arr, i&, pth$, ML, MT, MW, MH, shp
Arr = [a1].CurrentRegion
With Cells(2, 2)
    MW = .Width
    MH = .Height
End With
For i = 2 To UBound(Arr)
    s = Arr(i, 1)
    If s = "" Then Exit Sub
    pth = ThisWorkbook.Path & "公司图片"
    
    fNm = ""
    Call FindFileName(pth)
    If fNm = "" Then GoTo 100
    With Cells(i, 2)
        ML = .Left
        MT = .Top
        For Each shp In ActiveSheet.Shapes
            If shp.Type = 13 Then
                If shp.TopLeftCell.Address = .Address Then
                    shp.Delete: Exit For
                End If
            End If
        Next
        ActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).Select
        Selection.ShapeRange.Fill.UserPicture fNm
    End With
100:
Next
End Sub
Sub FindFileName(pth)
    If fNm <> "" Then Exit Sub '找到以后就结束递归过程（如果要找到全部则这一句注释掉）
    Set fso = CreateObject("Scripting.FileSystemObject") '设置fso对象
    Set fld = fso.GetFolder(pth) '设置fso对象的父文件夹fld
    Set fsb = fld.SubFolders '设置fso对象文件夹下的子文件夹fsb
    For Each fd In fsb '遍历所有子文件夹
        For Each f In fd.Files '遍历每个子文件夹中的所有文件
            If InStr(f.Name, s) Then fNm = fd.Path & "" & f.Name: Exit Sub
            '找到符合关键词的文件后退出（或者可以存入数组内然后继续查找所有符合的文件）
        Next
        Call FindFileName(fd.Path) '该子文件夹遍历结束时，继续递归进入该文件夹的子文件夹搜寻……
    Next
End Sub

Public Sub Q()
'开始插入图片

Application.ScreenUpdating = False
Dim PicName$, pand&, k&, PicPath, i, p, n, PicArr, TitleRow
Dim PicNameCol, PicPath2, PicPath3, TPnameCol, TPCol

    Set PicNameCol = Application.InputBox("请选择图片名称所在列，只能选择单列单元格！", Title:="图片名称所在列", Type:=8)

        '选择的图片名称所在列

    PicCol = PicNameCol.Column '取图片名称所在列列列标

    Set TPnameCol = Application.InputBox("请选择图片需要放置的列，只能选择单列单元格！", Title:="图片所在列", Type:=8)

        '选择的图片所在列

    TPCol = TPnameCol.Column '取图片所在列列列标

    

    TitleRow = Val(Application.InputBox("请输入标题行的行数")) '用户设置总表的标题行数

    If TitleRow < 0 Then MsgBox "标题行必须大于等于零，请重新确认? ": Exit Sub

    

    With Application.FileDialog(msoFileDialogFolderPicker)

        .AllowMultiSelect = False '禁止多选文件夹

       If .Show Then PicPath = .SelectedItems(1) Else: Exit Sub

    End With

    If Right(PicPath, 1) <> "" Then PicPath = PicPath & ""

    PicArr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif") '假定图片格式有5种

    For i = TitleRow + 1 To Cells(Rows.Count, PicCol).End(3).Row

        PicPath2 = PicPath

        PicName = Cells(i, PicCol).Value

        If Len(PicName) <> 0 Then '如果PicName不为空

            PicPath3 = PicPath2 & PicName

            pand = 0
            For p = 0 To UBound(PicArr)
                If Len(Dir(PicPath3 & PicArr(p))) Then '如果picpath路径下存在PicName图片
                    ActiveSheet.Shapes.AddPicture PicPath3 & PicArr(p), True, True, _
                    Cells(i, TPCol).Left, Cells(i, TPCol).Top, _
                    Cells(i, TPCol).Width, Cells(i, TPCol).Height

                    pand = 1

                    n = n + 1
                End If

            Next

            If pand = 0 Then k = k + 1
            End If
    Next
    Application.ScreenUpdating = True

    If k <> 0 Then
        MsgBox "图片插入完成！共有" & k & "张图片未找到，请重新确认源文件! "
    Else
        MsgBox "所有图片插入完成！"
    End If
End Sub