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