How do I Export single email to an Excel sheet 1

[RonQA]

I have this code that will Export an entire group of email to an Excel sheet. What I need it to do is Export a single email that has be highlighted. I can't seem to make the changes.

Can anyone help.

Thanks,

The Code ============================

Private strTemplatesPath As String


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.PickFolder
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.SenderEmailAddress
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)
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

End Function

 

[SkipVought]

Hi,

It would seem to me that there need to be an additional IF...THEN here...

  '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[b]
         If [i]this itm  is SELECTED ITEM[/i] Then
            'Process itm only if it is SELECTED ITEM


         End if[/b]
      End if
   Next

I have absolutely NO experience in Outlook, but this seemed to work in a test...

    Dim itm As MailItem, myNamespace As NameSpace, myFolder As MAPIFolder
    Set myNamespace = GetNamespace("MAPI")
    Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)
    
    For Each itm In myFolder.Items
        If [b]itm.EntryID = ActiveExplorer.Selection.Item(1).EntryID[/v] Then
            MsgBox "Found The SELECTION"
        End If
    Next

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[RonQA]

Could you post the code you tested that worked. I'm getting an syntax error. Maybe I introduced something.

Thanks,

 

[SkipVought]

You have it.

I tested again. It finds the selected eMail, as I am looking in my InBox.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[RonQA]

Thanks a million...Got it working.
Now I can start see about getting it to add each entry to the next empty line on the sheet.

Thanks again

 

[SkipVought]

    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
            If itm.EntryID = ActiveExplorer.Selection.Item(1).EntryID Then
                For j = 1 To 8
                    With wks.Cells(i, j)
                        Select Case j
                            Case 1
                                If msg.To <> "" Then rng.Value = msg.To
                            Case 2
                                If msg.CC <> "" Then rng.Value = msg.CC
                            Case 3
                                If msg.SenderEmailAddress <> "" Then rng.Value = msg.SenderEmailAddress
                            Case 4
                                If msg.Subject <> "" Then rng.Value = msg.Subject
                            Case 5
                                rng.Value = msg.SentOn
                            Case 6
                                rng.Value = msg.ReceivedTime
                            Case 7
                                If msg.Categories <> "" Then rng.Value = msg.Categories
                            Case 8
                                If msg.UserProperties("CustomField") <> "" Then _
                                    rng.Value = msg.UserProperties("CustomField")
                        End Select
                    End With
                Next
            End If
        End If
    Next itm

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[SkipVought]

oops I forgot to remove an important item...

    Dim i As Integer, j As Integer
    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
            If itm.EntryID = ActiveExplorer.Selection.Item(1).EntryID Then
                For j = 1 To 8
                    With wks.Cells(i, j)
                        Select Case j
                            Case 1
                                If msg.To <> "" Then .Value = msg.To
                            Case 2
                                If msg.CC <> "" Then .Value = msg.CC
                            Case 3
                                If msg.SenderEmailAddress <> "" Then .Value = msg.SenderEmailAddress
                            Case 4
                                If msg.Subject <> "" Then .Value = msg.Subject
                            Case 5
                                .Value = msg.SentOn
                            Case 6
                                .Value = msg.ReceivedTime
                            Case 7
                                If msg.Categories <> "" Then .Value = msg.Categories
                            Case 8
                                If msg.UserProperties("CustomField") <> "" Then _
                                    .Value = msg.UserProperties("CustomField")
                        End Select
                    End With
                Next
            End If
        End If
    Next itm

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}