Question
Thread display: Collapse - |
All Answers
Share your knowledge
Start or search
Create a new discussion
If you're asking for technical help, please be sure to include all your system info, including operating system, model number, and any other specifics related to the problem. Also please exercise your best judgment when posting in the forums--revealing personal information such as your e-mail address, telephone number, and address is not recommended.
Embed a Macro in Outlook 2003 from 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"