Rem version 1 - skrevet i V/2007
Rem Reference sat til: Microsoft Outlook 12.0 Object Library - skal evt. justeres til 2003-versionsNr (11.0)
Rem Evt. til at forhindre "Et program forsøger..."
Rem
www.contextmagic.com/express-clickyes/Free-version.htmRem ============================================================
Const mappenavn = "??" 'JUSTERES -hvis indbakken - sættes mappenavn = ""
Const startRæk = 2
Dim ræk As Integer, antalMails As Integer, mappen
Public Sub HentMails()
sletPtIndhold
antalMails = åbnOutlookMappe(mappenavn)
ræk = startRæk
traverserMappen antalMails
Columns.AutoFit
End Sub
Private Sub sletPtIndhold()
Range("A" & CStr(startRæk) & ":D65000").Select
Selection.ClearContents
Range("A" & CStr(startRæk)).Select
End Sub
Private Function åbnOutlookMappe(mappenavn)
Dim mailApp, nameSpace, aFold As MAPIFolder
Set mailApp = CreateObject("Outlook.Application")
Set nameSpace = mailApp.GetNamespace("MAPI")
Set aFold = nameSpace.GetDefaultFolder(olFolderInbox)
If mappenavn <> "" Then
Set mappen = aFold.Folders(mappenavn)
Else
Set mappen = aFold
End If
åbnOutlookMappe = mappen.Items.Count
End Function
Private Sub traverserMappen(antalMails)
Dim afsender As String, modtaget As Date, besvaret As Date, besvarType As String
Dim mx As MailItem, handlinger As Outlook.Actions
If antalMails > 0 Then
Application.ScreenUpdating = False
For m = 1 To antalMails
Set mx = mappen.Items(m)
afsender = mx.SenderEmailAddress
modtaget = mx.ReceivedTime
ActiveSheet.Range("A" & CStr(ræk)) = afsender
ActiveSheet.Range("B" & CStr(ræk)) = modtaget
' besvaret mangler p.t.
' type besvarelse mangler p.t.
ræk = ræk + 1
Next m
Application.ScreenUpdating = True
End If
End Sub
ps: bemærk mangler - prøve at finde info herom - men endnu er det ikke lykkedes.