求助电子表提取图片

春天的打火机 · 发表于 2020-1-7 09:22

提取对应名称的图片到E列（多层文件夹），图片大小自动适应E列单元格大小，电子表支持放入其他图库位置提取，提取后的图片保存在表内
请各位大神帮忙

蓝桥玄霜 · 发表于 2020-1-7 11:35

Yalishanda30 · 发表于 2020-1-7 13:37

附件供参考

春天的打火机 · 发表于 2020-1-7 14:29

蓝桥玄霜发表于 2020-1-7 11:35
http://club.excelhome.net/thread-1031430-1-1.html

这个程序报错的

春天的打火机 · 发表于 2020-1-7 14:33

Yalishanda30 发表于 2020-1-7 13:37
附件供参考

您好，这个导入程序放入图片库会卡死，有什么办法解决吗

Yalishanda30 · 发表于 2020-1-7 20:29

春天的打火机发表于 2020-1-7 14:33
您好，这个导入程序放入图片库会卡死，有什么办法解决吗

多路径搜索本来就不会很快。。。如果文件夹很乱，层次很多，肯定快不了

aman1516 · 发表于 2020-1-7 21:02

之前不是有老师解答了吗，无需重复发贴
试试：

Sub Fr_Pic()
Dim fr, myPath$, rng As Range
Dim i&, j&, k&, n&, r&
'On Error Resume Next
Call Delshp
myPath = ThisWorkbook.Path & ""
With CreateObject("Wscript.Shell") 'VBA调用Dos命令
fr = Split(.exec("cmd /c dir /a-d /b /s " & Chr(34) & myPath & Chr(34)).StdOut.ReadAll, vbCrLf) '所有文档含子文件夹
End With
With ActiveSheet
For i = 2 To .[B65536].End(xlUp).Row + 1
Set rng = .Range("B" & i)
If rng <> "" Then
For j = 0 To UBound(fr)
If InStr(fr(j), ".JPG") > 0 Then
If Split(Split(fr(j), "")(UBound(Split(fr(j), ""))), ".")(0) = "" & rng.Value Then
With ActiveSheet.Pictures.Insert(fr(j))
.Top = rng.Offset(0, 3).Top + 2
.Left = rng.Offset(0, 3).Left + 2
.Height = rng.Offset(0, 3).Height
'.Width = rng.Offset(0, 3).Width
End With
End If
End If
Next
End If
Next
End With
End Sub
Sub Delshp()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If shp.Left < Range("F1").Left Then shp.Delete
Next
End Sub

复制代码

aman1516 · 发表于 2020-1-7 21:03

详见附件：

图片导入.rar (48.26 KB, 下载次数: 118)

春天的打火机 · 发表于 2020-1-8 08:52

aman1516 发表于 2020-1-7 21:02
之前不是有老师解答了吗，无需重复发贴
试试：

您好，程序只能查询以大写字母结尾的图片后缀，这里想也同时查找小写字母结尾的后缀（JPG 和 jpg），请问这句该如何修改呢

aman1516 · 发表于 2020-1-8 16:14

春天的打火机发表于 2020-1-8 08:52
您好，程序只能查询以大写字母结尾的图片后缀，这里想也同时查找小写字母结尾的后缀（JPG 和 jpg）， ...

代码最前面加上:
Option Compare Text

		自动登录	找回密码
密码			免费注册

[求助] 求助电子表提取图片