[AccessD] Outlook MSG files

Jack,

Try this out ... set a reference to Microsoft Outlook in your Access VBA
project.



Sub GetContentsOfMessages()
Dim ObjOL As Outlook.Application
Dim aFLD As MAPIFolder
Dim Col As Collection
Dim Itm As Object
Dim MySender As String
Dim MyDate As Date
Dim MySubject As String
Dim MyContents As String
Dim ReturnVal
Dim strOutput As String
'Object, returnval As Long
Dim i As Long
Dim fnum As Long
Dim FSO As Object, Mysub As String
Dim objSelection


strOutput = Environ("temp") & "\TempSubject1.txt"
Close #1
fnum = FreeFile


On Error Resume Next
Set ObjOL = GetObject(, "Outlook.Application")
If ObjOL Is Nothing Then
  MsgBox "Outlook has to be running - else don't know what folder you want
to look in..."
  Exit Sub
End If
Set aFLD = ObjOL.ActiveExplorer.CurrentFolder
Set objSelection = ObjOL.ActiveExplorer.Selection

For Each Itm In objSelection
  If TypeName(Itm) = "MailItem" Then
      MySender = Itm.SenderEmailAddress
      MySubject = Itm.Subject
      MyDate = Itm.ReceivedTime
      MyContents = _
        MyContents & vbCrLf & vbCrLf & _
        "Sender: " & MySender & vbCrLf & _
        "Received: " & MyDate & vbCrLf & _
        "Subject: " & MySubject & vbCrLf & _
        "Message: " & vbCrLf & _
        Itm.Body
  End If
Next

Set FSO = CreateObject("Scripting.FilesystemObject")
Kill strOutput
Err.Clear
Open strOutput For Output Access Write As #fnum
If Err.Number = 0 Then
    Print #fnum, MyContents
  Close #fnum
  
  On Error GoTo 0
'  ReturnVal = Shell("C:\Program Files\Windows NT\Accessories\wordpad.exe "
& """" & strOutput & """", 3)
  ReturnVal = Shell("Notepad.exe " & """" & strOutput & """", 2)
  Debug.Print ReturnVal
Else
  MsgBox "Could not create an output file '" & strOutput & "'" & Chr(13) &
Err.Description
End If

End Sub