vba file handling

Public strFolder As String


'' BIF_Options
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000
Public Const BIF_BROWSEINCLUDEFILES = &H4000
Public Const BIF_BROWSEINCLUDEURLS = &H80
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_EDITBOX = &H10
Public Const BIF_NEWDIALOGSTYLE = &H40
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_SHAREABLE = &H8000
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_USENEWUI = &H40
Public Const BIF_VALIDATE = &H20
Public Const BIF_NONEWFOLDERBUTTON = &H200


'// Minimum DLL version shell32.dll version 4.71 or later
'// Minimum operating systems   Windows 2000, Windows NT 4.0 with Internet Explorer 4.0,
'// Windows 98, Windows 95 with Internet Explorer 4.0
'// objFolder = objShell.BrowseForFolder(Hwnd, sTitle, BIF_Options [, vRootFolder])


Public Function BrowseForFolderShell( _
    Optional Hwnd As Long = 0, _
    Optional sTitle As String = "", _
    Optional BIF_Options As Integer = BIF_VALIDATE, _
    Optional vRootFolder As Variant) As String


Dim objShell As Object
Dim objFolder As Variant
Dim strFolderFullPath As String


Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(Hwnd, sTitle, BIF_Options, vRootFolder)


If (Not objFolder Is Nothing) Then
    '// NB: If SpecFolder= 0 = Desktop then ....
    On Error Resume Next
    If IsError(objFolder.Items.Item.Path) Then strFolderFullPath = CStr(objFolder): GoTo GotIt
    On Error GoTo 0
    '// Is it the Root Dir?...if so change
    If Len(objFolder.Items.Item.Path) > 3 Then
        strFolderFullPath = objFolder.Items.Item.Path & Application.PathSeparator
    Else
        strFolderFullPath = objFolder.Items.Item.Path
    End If
Else
    '// User cancelled
    GoTo XitProperly
End If


GotIt:
BrowseForFolderShell = strFolderFullPath


XitProperly:
Set objFolder = Nothing
Set objShell = Nothing


End Function


Sub BrowseFavorites()


'// Using String
'// This will not only limit the User to a specific Folder
Dim strFolder As String
Dim objShell As Object
Dim objFolder As Variant
Dim strFolderFullPath As String


On Error Resume Next
Set objShell = CreateObject("Shell.Application")
'Set objFolder = objShell.Namespace(&H6)


Set objFolder = objShell.BrowseForFolder(0, "", BIF_BROWSEINCLUDEFILES, &H6)
On Error GoTo 0


If (Not objFolder Is Nothing) Then
    '// NB: If SpecFolder= 0 = Desktop then ....
    On Error Resume Next
    If IsError(objFolder.Items.Item.Path) Then strFolderFullPath = CStr(objFolder): GoTo GotIt
    On Error GoTo 0
    '// Is it the Root Dir?...if so change
    If Len(objFolder.Items.Item.Path) > 3 Then
        strFolderFullPath = objFolder.Items.Item.Path & Application.PathSeparator
    Else
        strFolderFullPath = objFolder.Items.Item.Path
    End If
Else
    '// User cancelled
    GoTo XitProperly
End If


GotIt:
'strFolderFullPath


XitProperly:
Set objFolder = Nothing
Set objShell = Nothing




If strFolderFullPath = vbNullString Then
    MsgBox "You cancelled"
Else
    MsgBox strFolder
End If


End Sub


Private Sub btnGetDetailsOf_Click()
    
Dim objShell  As Shell
Dim objFolder As Folder


Set objShell = New Shell
Set objFolder = objShell.Namespace("C:\WINDOWS")
    
If (Not objFolder Is Nothing) Then
    Dim objFolderItem As FolderItem
    Set objFolderItem = objFolder.ParseName("clock.avi")
   
    If (Not objFolderItem Is Nothing) Then
        Dim szItem As String
        szItem = objFolder.GetDetailsOf(objFolderItem, 2)
    End If
        
    Set objFolderItem = Nothing
End If
    
Set objFolder = Nothing
Set objShell = Nothing


End Sub


Function CreateFileList(FileFilter As String, _
    IncludeSubFolder As Boolean) As Variant
     
     ' returns the full filename for files matching
     ' the filter criteria in the current folder
    
Dim FileList() As String, FileCount As Long
CreateFileList = ""
Erase FileList
If FileFilter = "" Then FileFilter = "*.*" ' all files
Debug.Print CurDir
strFolder = BrowseForFolderShell(, , , 0)
If strFolder = "" Then
    MsgBox "You Cancelled"
    Exit Function
End If
With Application.FileSearch
    .NewSearch
    .LookIn = strFolder
    .fileName = FileFilter
    .SearchSubFolders = IncludeSubFolder
    .FileType = msoFileTypeAllFiles
    If .Execute(SortBy:=msoSortByFileName, _
        SortOrder:=msoSortOrderAscending) = 0 Then Exit Function
        
    ReDim FileList(.FoundFiles.count)
    For FileCount = 1 To .FoundFiles.count
        FileList(FileCount) = .FoundFiles(FileCount)
    Next FileCount
    .FileType = msoFileTypeExcelWorkbooks ' reset filetypes
End With
    
CreateFileList = FileList
Erase FileList


End Function

Sub RunCodeOnAllXLSFiles()
Dim i As Integer
Dim wbResults As Workbook
Dim wbCodeBook As Workbook


Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False


On Error Resume Next


Set wbCodeBook = ThisWorkbook


    With Application.FileSearch
        .NewSearch
         'Change path to suit
        .LookIn = "C:\MyDocuments\TestResults"
        .FileType = msoFileTypeExcelWorkbooks
        .Filename = "Book*.xls"
        
            If .Execute > 0 Then 'Workbooks in folder
                For i = 1 To .FoundFiles.Count 'Loop through all.
                 'Open Workbook x and Set a Workbook variable to it
                 Set wbResults = Workbooks.Open(.FoundFiles(i))
                 
                 'Do Your Code Here
             
                 Next i
            End If
    End With
    
    On Error GoTo 0
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
End Sub