Option Explicit
Option Base 1

Sub SearchFiles()

Dim scrFSO As Scripting.FileSystemObject
Dim scrFolder As Scripting.Folder
Dim scrFile As Scripting.File

Dim wb As Workbook
Dim varResults() As Variant
Dim intFilesFound As Integer
Dim i As Integer

Dim booDispAlerts As Boolean
Dim booScrUpdate As Boolean
Dim booEnEvents As Boolean
Dim xltCalc  As XlCalculation

Const strFolderPath As String = "C:\My Search Folder"

    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' Set up
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    ' Keep the user updated
    Application.StatusBar = "Setting up..."

    ' Record the state of & then turn off Excel functionality to make sub run faster
    booDispAlerts = Application.DisplayAlerts
    booScrUpdate = Application.ScreenUpdating
    booEnEvents = Application.EnableEvents
    xltCalc = Application.Calculation

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    ' Initiate a FileSystemObject
    Set scrFSO = New Scripting.FileSystemObject

    ' Reset files found counter
    intFilesFound = 0

    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' Main Program
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    ' Set the Folder object
    Set scrFolder = scrFSO.GetFolder(FolderPath:=strFolderPath)

    ' Loop through every file in the folder
    For Each scrFile In scrFolder.Files

        ' Only look at Excel files by inspecting the file extension
        If Right(scrFile.Name, 4) = ".xls" Then

            ' Keep the user updated
            Application.StatusBar = "Processing " & scrFile.Name & "..."

            ' Increment files found counter
            intFilesFound = intFilesFound + 1

            ' Redimension output array
            ReDim Preserve varResults(3, intFilesFound)

            ' Open the file
            Set wb = Workbooks.Open(Filename:=scrFile.Path, UpdateLinks:=False, ReadOnly:=True)

            ' Extract info - need to code to reach correct cells
            varResults(1, intFilesFound) = scrFile.Name
            varResults(2, intFilesFound) = wb.Sheets("Sheet1").Range("C3").Value
            varResults(3, intFilesFound) = wb.Sheets("Sheet2").Range("A1").Value

            ' Close the file
            wb.Close SaveChanges:=False

        End If

    Next scrFile

    ' Keep the user updated
    Application.StatusBar = "Results..."

    ' Show answers
    For i = 1 To intFilesFound
        MsgBox varResults(1, i) & " - " & varResults(2, i) & ", " & varResults(3, i)
    Next i

    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    ' Tidy up
    ' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    ' Dereference variables
    Set scrFSO = Nothing
    Set scrFolder = Nothing
    Set scrFile = Nothing

    Application.DisplayAlerts = booDispAlerts
    Application.ScreenUpdating = booScrUpdate
    Application.EnableEvents = booEnEvents
    Application.Calculation = xltCalc
    Application.StatusBar = False

End Sub

Option Explicit

' *********************************************************************
' Internal Class variables
' *********************************************************************

Private mobjSession As MAPI.Session
Private mbooLoggedOn As Boolean

' *********************************************************************
' Win API constants
' *********************************************************************

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type

Const REG_SZ As Long = 1
Const REG_DWORD As Long = 4
Const HKEY_CURRENT_USER = &H80000001
Const ERROR_NONE = 0
Const ERROR_BADDB = 1
Const ERROR_BADKEY = 2
Const ERROR_CANTOPEN = 3
Const ERROR_CANTREAD = 4
Const ERROR_CANTWRITE = 5
Const ERROR_OUTOFMEMORY = 6
Const ERROR_INVALID_PARAMETER = 7
Const ERROR_ACCESS_DENIED = 8
Const ERROR_INVALID_PARAMETERS = 87
Const ERROR_NO_MORE_ITEMS = 259

Const KEY_ALL_ACCESS = &H3F

Const REG_OPTION_NON_VOLATILE = 0

' *********************************************************************
' Win API Calls
' *********************************************************************

Private Declare Function GetVersionEx Lib "kernel32" _
    Alias "GetVersionExA" _
    (ByRef lpVersionInformation As OSVERSIONINFO) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" _
    (ByVal hKey As Long) As Long

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
    Alias "RegOpenKeyExA" _
    (ByVal hKey As Long, _
    ByVal lpSubKey As String, _
    ByVal ulOptions As Long, _
    ByVal samDesired As Long, _
    phkResult As Long) As Long

Private Declare Function RegQueryValueExString Lib "advapi32.dll" _
    Alias "RegQueryValueExA" _
    (ByVal hKey As Long, _
    ByVal lpValueName As String, _
    ByVal lpReserved As Long, _
    lpType As Long, _
    ByVal lpData As String, _
    lpcbData As Long) As Long

Private Declare Function RegQueryValueExLong Lib "advapi32.dll" _
    Alias "RegQueryValueExA" _
    (ByVal hKey As Long, _
    ByVal lpValueName As String, _
    ByVal lpReserved As Long, _
    lpType As Long, lpData As Long, _
    lpcbData As Long) As Long

Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" _
    Alias "RegQueryValueExA" _
    (ByVal hKey As Long, _
    ByVal lpValueName As String, _
    ByVal lpReserved As Long, _
    lpType As Long, _
    ByVal lpData As Long, _
    lpcbData As Long) As Long

' *********************************************************************
' Wrapper functions to read the registry
' *********************************************************************

Private Function QueryValue(sKeyName As String, sValueName As String)

Dim lRetVal As Long     'result of the API functions
Dim hKey As Long        'handle of opened key
Dim vValue As Variant   'setting of queried value

    lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, sKeyName, 0, KEY_ALL_ACCESS, hKey)

    lRetVal = QueryValueEx(hKey, sValueName, vValue)
    QueryValue = vValue
    RegCloseKey (hKey)

End Function

Private Function QueryValueEx(ByVal lhKey As Long, ByVal szValueName As String, vValue As Variant) As Long

Dim cch As Long
Dim lrc As Long
Dim lType As Long
Dim lValue As Long
Dim sValue As String

    On Error GoTo QueryValueExError

    ' Determine the size and type of data to be read
    lrc = RegQueryValueExNULL(lhKey, szValueName, 0&, lType, 0&, cch)
    If lrc <> ERROR_NONE Then Error 5

    Select Case lType
        ' For strings
        Case REG_SZ:
            sValue = String(cch, 0)
            lrc = RegQueryValueExString(lhKey, szValueName, 0&, lType, sValue, cch)
            If lrc = ERROR_NONE Then
                vValue = Left$(sValue, cch)
            Else
                vValue = Empty
            End If

        ' For DWORDS
        Case REG_DWORD:
            lrc = RegQueryValueExLong(lhKey, szValueName, 0&, lType, lValue, cch)
            If lrc = ERROR_NONE Then vValue = lValue

        Case Else
            'all other data types not supported
            lrc = -1

    End Select

QueryValueExExit:
    QueryValueEx = lrc
    Exit Function

QueryValueExError:
    Resume QueryValueExExit

End Function

' *********************************************************************
' Class Initialisation & Termination routines
' *********************************************************************

Private Sub Class_Initialize()

    ' Logon at start
    Call LogonToSession

End Sub


Private Sub Class_Terminate()

    ' Log off if logged on
    If mbooLoggedOn Then mobjSession.Logoff

End Sub

' *********************************************************************
' Logon routine
' *********************************************************************

Private Sub LogonToSession()

Dim sKeyName As String
Dim sValueName As String
Dim sDefaultUserProfile As String
Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer

    On Error GoTo ErrorHandler
    Set mobjSession = CreateObject("MAPI.Session")

    'Try to logon.  If it fails, the most likely reason is that you do
    'not have an open session.  Error -2147221231  MAPI_E_LOGON_FAILED
    'will return.  Trap the error in the ErrorHandler
    mobjSession.Logon ShowDialog:=False, NewSession:=False
    mbooLoggedOn = True
    Exit Sub

ErrorHandler:

    Select Case Err.Number
        Case -2147221231  'MAPI_E_LOGON_FAILED
            'Need to find out what OS is in use, the keys are different for WinNT and Win95.
            osinfo.dwOSVersionInfoSize = 148
            osinfo.szCSDVersion = Space$(128)
            retvalue = GetVersionEx(osinfo)

            Select Case osinfo.dwPlatformId
                Case 0   'Unidentified
                    MsgBox "Unidentified Operating System.  " & _
                    "Can't log onto messaging."
                    Exit Sub

                Case 1   ' 95, 98, ME
                    sKeyName = "Software\Microsoft\" & _
                    "Windows Messaging Subsystem\Profiles"

                Case 2   ' NT, 2000, XP, Sever 2003, Server Longhorn, Vista
                    sKeyName = "Software\Microsoft\Windows NT\" & _
                    "CurrentVersion\" & _
                    "Windows Messaging Subsystem\Profiles"

            End Select

            sValueName = "DefaultProfile"
            sDefaultUserProfile = QueryValue(sKeyName, sValueName)
            mobjSession.Logon ProfileName:=sDefaultUserProfile, ShowDialog:=False
            mbooLoggedOn = True
            Exit Sub

        Case Else
            MsgBox "An error has occured while attempting" & Chr(10) & _
            "To create and logon to a new CDO (1.x) session." & _
            Chr(10) & "Please report the following error to your " & _
            "System Administrator." & Chr(10) & Chr(10) & _
            "Error Location: frmMain.StartMessagingAndLogon" & _
            Chr(10) & "Error Number: " & Err.Number & Chr(10) & _
            "Description: " & Err.Description

    End Select

End Sub

' *********************************************************************
' Send e-mail routine
' *********************************************************************

Public Function SendMail(strTo As String, strTitle As String, strBody As String) As Boolean

Dim objNewMessage As MAPI.Message
Dim objRecipient As MAPI.Recipient

    ' Logon if not logged on
    If Not mbooLoggedOn Then Call LogonToSession

    ' Create a new message
    Set objNewMessage = mobjSession.Outbox.Messages.Add

    ' Add a subject
    objNewMessage.Subject = strTitle

    ' Add text to the message body
    ' Note that CDO 1.x cannot add text formatted with RTF or HTML
    ' Only Plain Text is supported in the current version
    objNewMessage.Text = strBody

    ' Add recipient and resolve against the directory
    Set objRecipient = objNewMessage.Recipients.Add
    objRecipient.Name = strTo
    objRecipient.Resolve

    ' Send message
    objNewMessage.Update
    objNewMessage.Send

End Function

Option Explicit

Sub Test()

Dim clsMAPI As New clsMAPIWrapper
Dim booRtn As Boolean

    ' Send an e-mail
    booRtn = clsMAPI.SendMail(Application.UserName, "MAPI Test", "Hello")

    ' De-reference variable
    Set clsMAPI = Nothing

End Sub