excel - 根据单元格值将图像从子目录插入 Excel
问题描述
我是 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
推荐阅读
- sql - Redshift - 从单元格中提取最右边的值
- c++ - 是否需要使用共享库的不同 lua_State?
- c# - 如何在 Azure Function 中访问本地应用设置
- javascript - JavaScript 如何确保使用 Unicode 字符集编写程序?
- flutter-layout - 如何将小部件带到 Flutter 中其他小部件的右侧
- ios - 在 OC 项目中引入 Swift 导致归档错误与 xcodebuild,使用 xcode 将可以
- arrays - 如何在swift 4中将多个数据存储在一个数组中?
- mongodb - 在数组中查找包含特定值或存在于数组中的文档
- jwt - GenTux\Jwt\Drivers\JwtDriverInterface 不可实例化
- elasticsearch - @IndexedEmbedded 和 @ContainedIn 关系不起作用