Software

We are builidng a control sheet utility in Excel 2003 and as a part of which we are trying to obtain a list of mails in the Outlook 2003 Inbox to Excel 2003.

However, if a macro (Inbox extraction macro) is run from Excel to access Outlook for extracting the Inbox listing then Outlook does not allow the "From" field with the comment "A program is trying to access e-mail ids........".

Hence we have no option but to place the the Inbox extraction macro in Outlook 2003 ThisOutlookSession,but run the same through Excel so that we can have the "From" field as well.

However the problem is that there are 200 users in our department and the code has to be manually embedded in each user's Outlook - ThisOutlookSession.

Here is the code:

Sub move2folder()
On Error Resume Next

Set objOutlook = CreateObject("Outlook.Application")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolderSrc = objNamespace.GetDefaultFolder(olFolderInbox)
Set objFolderDst = objFolderSrc.Folders("TRIAL FOR CONTROLSHEET")

Set colitems = objFolderSrc.Items
'Set colFilteredItems = colItems.Restrict("[UnRead] = True")
'Set colFilteredItems = colitems.Unrestrict("[Unread] = True")
'For Each objMessage In colFilteredItems
For Each objMessage In objFolderSrc.Items
objMessage.Move objFolderDst
Next

End Sub

Sub SaveMessagesToExcel()
'Demonstrates pushing mail message data to rows in an Excel worksheet

On Error GoTo errorHandler

Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim i As Integer
Dim j As Integer
Dim lngCount As Long
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
'Must declare as Object because folders may contain different
'types of items
Dim itm As Object
Dim strTitle As String
Dim strPrompt As String



strTemplatesPath = GetTemplatesPath
strSheet = "Messages.xls"
strSheet = strTemplatesPath & strSheet
Debug.Print "Excel workbook: " & strSheet

'Test for file in the Templates folder
If TestFileExists(strSheet) = False Then
strTitle = "Worksheet file not found"
strPrompt = strSheet & _
" not found; please copy Messages.xls to this folder and try again"
MsgBox strPrompt, vbCritical + vbOKOnly, strTitle
GoTo ErrorHandlerExit
End If

Set appExcel = GetObject(, "Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True

'Let user select a folder to export
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.GetDefaultFolder(olFolderInbox)
If fld Is Nothing Then
GoTo ErrorHandlerExit
End If

'Test whether selected folder contains mail messages
If fld.DefaultItemType <> olMailItem Then
MsgBox "Folder does not contain mail messages"
GoTo ErrorHandlerExit
End If

lngCount = fld.Items.Count

If lngCount = 0 Then
MsgBox "No messages to export"
GoTo ErrorHandlerExit
Else
Debug.Print lngCount & " messages to export"
End If

'Adjust i (row number) to be 1 less than the number of the first body row
i = 3

'Iterate through contact items in Contacts folder, and export a few fields
'from each item to a row in the Contacts worksheet
For Each itm In fld.Items
If itm.Class = olMail Then
'Process item only if it is a mail item
Set msg = itm
i = i + 1

'j is the column number
j = 1

Set rng = wks.Cells(i, j)
If msg.To <> "" Then rng.Value = msg.To
j = j + 1

Set rng = wks.Cells(i, j)
If msg.CC <> "" Then rng.Value = msg.CC
j = j + 1

Set rng = wks.Cells(i, j)
If msg.SenderEmailAddress <> "" Then rng.Value = msg.SenderName
j = j + 1

Set rng = wks.Cells(i, j)
If msg.Subject <> "" Then rng.Value = msg.Subject
j = j + 1

Set rng = wks.Cells(i, j)
If msg.Body <> "" Then rng.Value = msg.Body
j = j + 1

Set rng = wks.Cells(i, j)
rng.Value = msg.SentOn
j = j + 1

Set rng = wks.Cells(i, j)
rng.Value = msg.ReceivedTime

j = j + 1

'Set rng = wks.Cells(i, j)
'If Msg.Categories <> "" Then rng.Value = Msg.Categories
'j = j + 1

Set rng = wks.Cells(i, j)
On Error Resume Next
'The next line illustrates the syntax for referencing
'a custom Outlook field
If msg.UserProperties("CustomField") <> "" Then
rng.Value = msg.UserProperties("CustomField")
End If
j = j + 1
End If
Next itm

ErrorHandlerExit:
Exit Sub

errorHandler:
If Err.Number = 429 Then
'Application object is not set by GetObject; use CreateObject instead
If appExcel Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
Resume Next
End If
Else
MsgBox "Error No: " & Err.Number & "; Description: "
Resume ErrorHandlerExit
End If

End Sub

Public Function TestFileExists(strFile As String) As Boolean
'Tests for existing of a file, using the FileSystemObject

Dim fso As New Scripting.FileSystemObject
Dim fil As Scripting.File

On Error Resume Next

Set fil = fso.GetFile(strFile)
If fil Is Nothing Then
TestFileExists = False
Else
TestFileExists = True
End If

End Function

Public Function GetTemplatesPath() As String

Dim appWord As Word.Application
Set appWord = GetObject(, "Word.Application")

strTemplatesPath = _
appWord.Options.DefaultFilePath(wdUserTemplatesPath) & "\"
Debug.Print "Templates folder: " & strTemplatesPath
GetTemplatesPath = strTemplatesPath

ErrorHandlerExit:
Set appWord = Nothing
Exit Function

errorHandler:
If Err = 429 Then
'Word is not running; open Word with CreateObject
Set appWord = CreateObject("Word.Application")
Resume Next
Else
MsgBox "Error No: " & Err.Number & "; Description: " _
& Err.Description
Resume ErrorHandlerExit
End If


Is there a way to create a "Check Macro" in excel which checks in Outlook whether the above specified Inbox extraction macro is present in Outlook and if not present then pastes the Inbox extraction code into ThisOutlookSession in Outlook.

This has to happen every time when the user opens the Excel utility we have build - probably we can have a button "Validate Outlook" and run the above "Check Macro"