我是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
未经测试,但应该非常接近:
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