VBA 遍历读取文件夹图片

柏澄君 2013-12-05 05:02:12

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

...全文