VBA 遍历读取文件夹图片
Sub ImagesTool()Dim theSh As Object
Dim theFolder As Object
Dim filePath As String
Dim fileTmp As String
Dim sheetName As String
Dim mysheet As Worksheet
Dim sName As String
Dim lName As String
Dim i As Integer
Dim j As Integer
Dim m As Integer
Dim n As Integer
Dim fs
Set fs = Application.FileSearch ' 置一个搜索 象
'########################################################################
'Get folder address
Application.Calculation = xlCalculationManual
Set theSh = CreateObject("shell.application")
Set theFolder = theSh.BrowseForFolder(0, "", 0, "")
If Not theFolder Is Nothing Then
'filePath = theFolder.Items.Item.Path & "\"
filePath = theFolder.Items.Item.path & "\"
i = Len(filePath)
End If
Application.Calculation = xlCalculationAutomatic
'########################################################################
Set folderlist = CreateObject("scripting.dictionary")
Set filelist = CreateObject("scripting.dictionary")
n = 1
folderlist.Add filePath, ""
Do While folderlist.Count > 0
For Each FolderName In folderlist.keys
fname = Dir(FolderName, vbDirectory)
Do While fname <> ""
If fname <> ".." And fname <> "." Then
If GetAttr(FolderName & fname) And vbDirectory Then
folderlist.Add FolderName & fname & "\", ""
Else
filelist.Add FolderName & fname, "" '列出的文件的路径＋文件名
End If
End If
fname = Dir
Loop
'#####################################
If InStr(FolderName & fname, "result") > 0 Then
'Range("A1").Value = FolderName & fname
'Sheets.Add After:=Sheets(Sheets.Count)
j = Len(FolderName & fname)
m = j - i
sName = Mid(FolderName & fname, i + 1, m - 1)
If sName <> "" Then
lName = Replace(sName, "\", "-")
'#####################################
With fs
.LookIn = FolderName & fname
.Filename = "*.bmp"
.SearchSubFolders = True
If .Execute > 0 Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = lName
LoadImages (FolderName & fname)
End If
End With
End If
End If
folderlist.Remove (FolderName)
Next
Loop
'For Each arr In filelist.keys '将文件路径 ＋ 文件名放在当前工作表的A列
' Range("A" & n).Value = arr
' n = n + 1
'Next
End Sub
'###########################################################################################
Sub LoadImages(MyPath As String)
Dim MyFile As String
Dim i As Integer, j As Integer
Dim arr() As String
Dim sFile As String
Dim pFile As String
'Dim MyPath As String
'MyPath = "C:\Documents and Settings\cuiyinshan\デスクトップ\tsuite_001\snl1\0001\t0002_case05\result\"
i = 0 '从第几行插入
MyFile = Dir(MyPath & "*.bmp")
Do While Len(MyFile) > 0
i = i + 1
ReDim Preserve arr(i)
arr(i) = MyFile
MyFile = Dir
pFile = Left(arr(i), Len(arr(i)) - 4)
If Len(pFile) = 9 Then
j = j + 1
ActiveSheet.Pictures.Insert(MyPath & arr(i)).Select
ActiveSheet.Cells(((j - 1) * 60 + 1), 1).Value = pFile
Selection.ShapeRange.Top = Cells(((j - 1) * 60 + 2), 1).Top
Selection.ShapeRange.Left = Cells(j, 1).Left
End If
Loop
'MsgBox "There are(is) " & j & " right .bmp image file(s) import to excel!"
End Sub
楼主想要干嘛？
不知所谓…………
要是楼主准备“放源码”，不得不说这样的源码太垃圾了……
就枚举一下一个文件夹内的 *.bmp，用得了这么多代码吗…………
歌就是找个地方放代码！
唔
补充：VB , VBA
