AW: Email auslesen
19.04.2012 18:22:16
JoWE
Hallo Burghard,
versuch's mal so
(den gesamten Code in ein Modul,
Verweise auf Microsoft Outlook xx.0 Library und
Microsoft Forms 2.0 Object Library setzen):
Option Explicit
Private Declare Function CreateToolhelpSnapshot Lib _
"Kernel32" Alias "CreateToolhelp32Snapshot" ( _
ByVal lFlgas As Long, ByVal lProcessID As Long) As Long
Private Declare Function ProcessFirst Lib "Kernel32" _
Alias "Process32First" (ByVal hSnapshot As Long, _
uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "Kernel32" _
Alias "Process32Next" (ByVal hSnapshot As Long, _
uProcess As PROCESSENTRY32) As Long
Private Declare Sub CloseHandle Lib "Kernel32" (ByVal hPass As Long)
Private Const TH32CS_SNAPPROCESS As Long = 2&
Private Const MAX_PATH As Long = 260
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwflags As Long
szexeFile As String * MAX_PATH
End Type
Public AppRun As Boolean
Private Function IsEXERunning(ByVal sFilename As String) As Long
Dim lSnapshot As Long
Dim uProcess As PROCESSENTRY32
Dim nResult As Long
lSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
If lSnapshot <> 0 Then
uProcess.dwSize = Len(uProcess)
nResult = ProcessFirst(lSnapshot, uProcess)
Do Until nResult = 0
If InStr(LCase$(uProcess.szexeFile), LCase$(sFilename)) > 0 Then
IsEXERunning = True
Exit Do
End If
nResult = ProcessNext(lSnapshot, uProcess)
Loop
CloseHandle lSnapshot
End If
End Function
Sub testOLStart(theApp)
If IsEXERunning(theApp) Then AppRun = True
End Sub
Sub Outlook_Status_Check()
Dim oData As New DataObject
Dim OLF As Outlook.MAPIFolder
Dim myFolder As Outlook.MAPIFolder
Dim AnzEintraege, i As Long
Call testOLStart("outlook.exe")
If AppRun = True Then
Set OLF = GetObject("", "Outlook.Application") _
.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Else
Set OLF = CreateObject("Outlook.Application") _
.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
End If
'hier anpassen, der Ordner 'badMails' ist ein Unterordner des Posteinganges
Set myFolder = OLF.Folders("badMails")
AnzEintraege = myFolder.Items.Count
While i < AnzEintraege
i = i + 1
With myFolder.Items(i)
Sheets("Tabelle1").Cells(i + 1, 2) = .Body
.UnRead = False
End With
Wend
Set OLF = Nothing
Application.StatusBar = False
End Sub
Code eingefügt mit http://vbahtml.origo.ethz.ch]VBA
in HTML 1.2
Der Code schreibt den Body aller Maileingänge des genannten Ordners 'badMails' in die
Tabelle 1 beginnend in Zeile 1.
Gruß
Jochen