Extracting email body to Word (Outlook)

Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim olItems As Outlook.Items
Dim olItem As Outlook.MailItem
Dim WordWasNotRunning As Boolean
Set olItems = Application.Session.GetDefaultFolder(olFolderInbox).Items
olItems.Sort "[Received]", True
[B][COLOR=red]Set olItem = olItems(1)[/COLOR][/B]
WordWasNotRunning = False
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
     Set wdApp = CreateObject("Word.Application")
     WordWasNotRunning = True
End If
Set wdDoc = wdApp.Documents.Add
wdDoc.Content.InsertAfter olItem.Body
 
olItem.UnRead = False
Set olItem = Nothing
Set olItems = Nothing
wdApp.WindowState = wdWindowStateMinimize
wdApp.Visible = True
wdApp.WindowState = wdWindowStateNormal
 

 

If WordWasNotRunning = True Then
     wdApp.Quit
End If
 
Set wdDoc = Nothing
Set wdApp = Nothing

Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim myOlExp As Explorer
Dim myOlSel As Selection
Dim myOlMail As MailItem
Dim i As Integer, j As Long
Set myOlExp = ActiveExplorer
Set myOlSel = myOlExp.Selection
For j = 1 To myOlSel.Count
Set myOlMail = myOlSel.Item(j)
Dim WordWasNotRunning As Boolean
 
WordWasNotRunning = False
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
     Set wdApp = CreateObject("Word.Application")
     WordWasNotRunning = True
End If
Set wdDoc = wdApp.Documents.Add
wdDoc.Content = myOlMail.Body
 
 
wdApp.WindowState = wdWindowStateMinimize
wdApp.Visible = True
wdApp.WindowState = wdWindowStateNormal
 

 

If WordWasNotRunning = True Then
     wdApp.Quit
End If
 
Set wdDoc = Nothing
Set wdApp = Nothing
 

Set myOlMail = Nothing
Next j
Set myOlSel = Nothing
Set myOlExp = Nothing

Sub ExpExtract2()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim myOlExp As Explorer
Dim myOlSel As Selection
Dim myOlMail As MailItem
Dim i As Integer, j As Long
Set myOlExp = ActiveExplorer
Set myOlSel = myOlExp.Selection
For j = 1 To myOlSel.Count
Set myOlMail = myOlSel.Item(j)
Dim WordWasNotRunning As Boolean
WordWasNotRunning = False
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
     Set wdApp = CreateObject("Word.Application")
     WordWasNotRunning = True
End If
Set wdDoc = wdApp.Documents.Add
wdDoc.Content = myOlMail.Body
 
[B]wdDoc.SaveAs ("c:\StoreLettersDemo\FromOutLook.doc") Needs to be dynamic with either subject or email address plus date/time[/B]
wdApp.Quit
Set myOlMail = Nothing
Next j
Set myOlSel = Nothing
Set myOlExp = Nothing
End Sub

'get the active explorer
Set out_Exp = out_App.ActiveExplorer

'here they have clicked on nothing but are in "Mailbox"
If out_Exp.CurrentFolder.WebViewOn = False Then
        Set out_Sel = out_Exp.Selection
    Else
        MsgBox "No email selected"
        Set out_Exp = Nothing
        Exit Sub
    End If

'first make sure they have only choosen one item if not exit sub
If out_Sel.Count > 1 Then
    MsgBox "more than one email selected"
    Exit Sub
Else
    If out_Sel.Count = 0 Then
    MsgBox "No email selected"
    Exit Sub
    End If
End If

'check that it is in fact an email that has been choosen
If Not out_Sel.Item(1).Class = olMail Then
    MsgBox "Not an email"
    Exit Sub
End If


'next try to get the email item - if there is an error 13 then it is encrypted
On Error Resume Next

Set out_mail = out_Sel.Item(1)

If Err.Number = 13 Then
    Err.Clear
    MsgBox "email is encrypted"
    Exit Sub
End If