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 & "\"
'i = Len(filePath)
'End If
'Application.Calculation = xlCalculationAutomatic
'########################################################################################
filePath = Range("B3").Text & "\"
i = Len(filePath)
'########################################################################################
'
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
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
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
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
End Sub
'#############################################################################################
Sub GetPath()
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
Range("B3").Value = .SelectedItems(1)
End If
End With
End Sub
'#############################################################################################
Sub TraversalFolder()
Dim fs, i, arr(1 To 100000)
Set fs = Application.FileSearch
Dim path As String
path = Range("B3").Text
With fs
.LookIn = path
.Filename = "*.bmp"
.SearchSubFolders = True
If .Execute > 0 Then
MsgBox "There were " & .FoundFiles.Count & _
" .bmp file(s) found."
For i = 1 To .FoundFiles.Count
arr(i) = .FoundFiles(i)
Next i
Else
MsgBox "There were no .bmp files found."
End If
End With
End Sub
补充：移动开发 , 百度开放云移动论坛
