Вставка изображений в Excel из подкаталогов на основе значения ячейки - PullRequest
Новая
       14

Вставка изображений в Excel из подкаталогов на основе значения ячейки

0 голосов
/ 09 ноября 2019

Я новичок в VBA, но смог изменить приведенный ниже код для вставки изображений в мою электронную таблицу на основе значений ячеек, если изображения находятся в определенной папке. Как мне изменить код, чтобы он просматривал все вложенные папки в каталоге? Любая помощь будет принята с благодарностью. 

Public Sub Add_Pics_Example()
Dim oCell As Range
Dim oRange As Range
Dim oActive As Worksheet
Dim sPath As String
Dim sFile As String
Dim oShape As Shape

Worksheets("Range").Activate
sPath = "Z:\Pictures\Product Images\"
ActiveSheet.DrawingObjects.Select
Selection.Delete
Set oActive = ActiveSheet
Set oRange = oActive.Range("B4:bz4")

On Error Resume Next
For Each oCell In oRange
  sFile = oCell.Value & ".jpg"
  Set oShape = oActive.Shapes.AddPicture(sPath & sFile, False, True, _
  oCell.Offset(-3, 0).Left + 30, oCell.Offset(-3, 0).Top + 3, 60, 60)
Next oCell

On Error GoTo 0
Application.ScreenUpdating = True

End Sub

1 Ответ

0 голосов
/ 09 ноября 2019

Не проверено, но должно быть довольно близко: 

Public Sub Add_Pics_Example()
    Dim oCell As Range
    Dim oRange As Range
    Dim wsActive As Worksheet
    Dim sFile As String
    Dim dictFiles As Object

    Set wsActive = Worksheets("Range")
    wsActive.DrawingObjects.Delete

    'get all the image files first
    Set dictFiles = AllFilesbyName("Z:\Pictures\Product Images\", "*.jpg")

    For Each oCell In wsActive.Range("B4:BZ4")
        sFile = oCell.Value & ".jpg"
        'do we have this file ?
        If dictFiles.exists(sFile) Then
            wsActive.Shapes.AddPicture dictFiles(sFile), False, True, _
                                 oCell.Offset(-3, 0).Left + 30, _
                                 oCell.Offset(-3, 0).Top + 3, 60, 60
        End If
    Next oCell

End Sub



'starting at startFolder, return a dictionary mapping file names to
'  full paths (note doesn't handle >1 file of the same name)
'  from startfolder and all subfolders
Function AllFilesbyName(startFolder As String, filePattern As String, _
                    Optional subFolders As Boolean = True) As Object
    Dim fso, fldr, f, subFldr
    Dim dictFiles As Object, colSub As New Collection

    Set fso = CreateObject("scripting.filesystemobject")
    Set dictFiles = CreateObject("scripting.dictionary")
    dictFiles.comparemode = 1  'TextCompare: case-insensitive
    colSub.Add startFolder

    Do While colSub.Count > 0
        Set fldr = fso.getfolder(colSub(1))
        colSub.Remove 1
        For Each f In fldr.Files
            If UCase(f.Name) Like UCase(filePattern) Then
                'EDIT: fixed the line below
                dictFiles(f.Name) = fso.buildpath(fldr.Path, f.Name)
            End If
        Next f
        If subFolders Then
            For Each subFldr In fldr.subFolders
                colSub.Add subFldr.Path
            Next subFldr
        End If
    Loop
    Set AllFilesbyName = dictFiles
End Function
...