Wöchentlichen Inflow Messen

[Mikas]

Guten Morgen,

Ich bin ganz neu hier und habe direkt mal ein Anliegen bei dem ich dringend eure Hilfe bräuchte.

Mein Problem/Aufgabe Sieht wie folgt aus.

Ist-Zustand:
Ich erhalte Wöchentlich mehrere Fehlermeldungen in ein Postfach, welches nicht  "mein" Postfach ist sondern ein Allgemeines Postfach für das ich die Zulassung bekommen habe.(Firmen Postfach)
Dieses Postfach hat mehrere Unterordner in welche verschiedene Fehlermeldungen eingeordnet werden.

Was ich brauche:

Ich muss den wöchentlichen Inflow erfassen und aufzeigen.
Sprich wenn ich für die KW 42 den inflow messe möchte. Sollte die Antwort eventuell so aussehen, wenn ich 12 Mails in der kw 42 bekommen habe.



Posteingang   :       12
Unterordner 1:       5
Unterordner 2:       6
Unterordner 3:       1


Ich hoffe ihr könnt mir helfen denn ich verzweifle an dieser Aufgabe :( :22: :22:

Gruß Mika

[schauan]

Hallo Mika,

da müsste ich Dich mal an die Konkurrenz verweisen. Schaue Dir mal diesen Thread an (hat zwei Seiten), eventuell ist das eine Lösung. Die Abfrage geschieht dort von Seitens Excel aus, man kann das aber auch auf Outlook umstricken.

http://www.ms-office-forum.net/forum/sho...p?t=277031&page=2

[Mikas]

Code:

Option Explicit

Dim strFolderName As String
Dim strg As String
Dim WrdArray() As String
Private Const XLS_START_OUTPUT_ROW  As Integer = 5
Dim intHeaderStart As Integer
Dim intOutputLastRow As Integer
Dim blnOlNewInstance As Boolean
Dim myOlApp As Outlook.Application

Public Function OpenOutlookInstance() As Boolean
   
   'Reset old Instance
   Set myOlApp = Nothing
   blnOlNewInstance = False
   
   On Error Resume Next
   'Check if Outlook is running
   Set myOlApp = GetObject(, "Outlook.Application")
   If myOlApp Is Nothing Then
       'Outlook is not running. Create new Instance
      Set myOlApp = Outlook.Application
      blnOlNewInstance = True
   End If

   'Check if myOlApp is Nothing
   If myOlApp Is Nothing Then
       OpenOutlookInstance = False
       blnOlNewInstance = False
       MsgBox "Cannot open Outlook!", vbCritical, "Open Outlook"
   Else
       OpenOutlookInstance = True
   End If
   
   
End Function
Private Function olauslesen()
   
   intOutputLastRow = XLS_START_OUTPUT_ROW
   intHeaderStart = 0
   If OpenOutlookInstance Then
 
     
       Dim olFld As Folder
       Dim resInput As String
       Dim intKW As Integer
       Dim myItem As MailItem
       Dim mySelectedFolder As Folder
       Dim intMailsCount As Integer
       
       Set mySelectedFolder = GetOpenMAPI_Folder(myOlApp)
       
       If Not mySelectedFolder Is Nothing Then

resInput:

           resInput = InputBox("Please Enter The Calndar Week!", "Calendar Week", Format(Date, "ww"))
           
           If resInput <> "" Then
               If IsNumeric(resInput) And Len(resInput) = 1 Or Len(resInput) = 2 Then
                   
                   Application.ScreenUpdating = False
                   
                   intKW = resInput
                   
                 
                   'clear sheet contents and formats
                   Dim wks As Worksheet
                   Set wks = Worksheets(1)
                   wks.Cells.ClearContents
                   wks.Cells.ClearComments
                   wks.Cells.ClearFormats
                   
                   '########################## Start Summary Headline ###########################
                   'Print Headline
                   wks.Cells(XLS_START_OUTPUT_ROW, 5).Value = "Summary Of KW: " & intKW
                   'Fomat the Folder-Name in Bold
                   wks.Cells(XLS_START_OUTPUT_ROW, 5).Font.Bold = True
                   
                   'Cell Borders at Bottom
                    wks.Cells(XLS_START_OUTPUT_ROW, 5).Borders(xlEdgeBottom).Weight = xlThick
                    wks.Cells(XLS_START_OUTPUT_ROW, 6).Borders(xlEdgeBottom).Weight = xlThick
                    wks.Cells(XLS_START_OUTPUT_ROW, 7).Borders(xlEdgeBottom).Weight = xlThick
                    '########################## End Summary Headline ###########################
                   
                   'Print selected Folder Name
                   OutputFolderName wks, mySelectedFolder, XLS_START_OUTPUT_ROW, 1
                   
                   
                   'Count the Mail in Selected Root Folder.
                   'Loop though all Objects and check if it is MailItem
                   
                   For Each myItem In mySelectedFolder.Items
                       On Error Resume Next
                        If TypeOf myItem Is MailItem And Format(myItem.SentOn, "ww") = intKW Then
                           If Format(myItem.SentOn, "yyyy") = Format(Date, "yyyy") Then
                               intMailsCount = intMailsCount + 1
                               intOutputLastRow = XLS_START_OUTPUT_ROW + intMailsCount
                               'Value Output to Cells
                               wks.Cells(intOutputLastRow, 1).Value = intMailsCount
                               wks.Cells(intOutputLastRow, 2).Value = myItem.Subject
                               wks.Cells(intOutputLastRow, 3).Value = myItem.SentOn
                               'Debug.Print Format(myItem.SentOn, "ww") & vbTab & myItem
                               
                               
                               
                            End If
                       End If
                       
                   Next myItem
                   
                 
                   'Set the Row position for header
                   intHeaderStart = XLS_START_OUTPUT_ROW + 1
                   
                   'Output of Summary this folder
                   OutputSumFolder wks, mySelectedFolder.Name, 5, intMailsCount
                   
               
                   'Loop through all SubFolder in Selected Folders and Count the Mails
                   For Each olFld In mySelectedFolder.Folders
                       GetSubFolderMails wks, olFld, intKW
                   Next olFld
                   
                   
         
               Else
                   MsgBox "Invalid Calendar Week", vbExclamation, "Invalid Input"
                   GoTo resInput
               End If
           
           End If
       
       End If
       
   End If
   
   Application.ScreenUpdating = True
   
   Set mySelectedFolder = Nothing
   Set wks = Nothing
   If blnOlNewInstance Then
       myOlApp.Quit
   End If
   
   Set myOlApp = Nothing
   
   
End Function

Private Sub OutputFolderName(xlsSheet As Worksheet, olFolder As Folder, iRow As Integer, iCol As Integer)
   'Output of Selected Folder-Name
   xlsSheet.Cells(iRow, 1).Value = olFolder.Name
   
   Dim rComment As Range
   Set rComment = xlsSheet.Cells(iRow, 1)
   rComment.AddComment olFolder.FolderPath
   
   'Fomat the Folder-Name in Bold
   xlsSheet.Cells(iRow, 1).Font.Bold = True
   
   'Cell Borders at Bottom
    xlsSheet.Cells(iRow, iCol).Borders(xlEdgeBottom).Weight = xlThick
    xlsSheet.Cells(iRow, iCol + 1).Borders(xlEdgeBottom).Weight = xlThick
    xlsSheet.Cells(iRow, iCol + 2).Borders(xlEdgeBottom).Weight = xlThick
               
    Set rComment = Nothing
End Sub

Private Sub OutputSumFolder(xlsSheet As Worksheet, strFolderName As String, iCol As Integer, intMailsCount As Integer)
   
   xlsSheet.Cells(intHeaderStart, iCol).Value = strFolderName
   xlsSheet.Cells(intHeaderStart, iCol + 1).Value = intMailsCount
   intHeaderStart = intHeaderStart + 1
End Sub
Private Sub GetSubFolderMails(xlsSheet As Worksheet, olFolder As Folder, intKW As Integer)
   Dim myItem As Object
   Dim intMailsCount As Integer
       
       
    'Debug.Print olFolder.Name
   
   
   'Print selected Folder Name
   OutputFolderName xlsSheet, olFolder, intOutputLastRow + 2, 1
   intOutputLastRow = intOutputLastRow + 2
             
   For Each myItem In olFolder.Items
       On Error Resume Next
        If TypeOf myItem Is MailItem And Format(myItem.SentOn, "ww") = intKW Then
           If Format(myItem.SentOn, "yyyy") = Format(Date, "yyyy") Then
               intMailsCount = intMailsCount + 1
               intOutputLastRow = intOutputLastRow + 1
               'Value Output to Cells
               xlsSheet.Cells(intOutputLastRow, 1).Value = intMailsCount
               xlsSheet.Cells(intOutputLastRow, 2).Value = myItem.Subject
               xlsSheet.Cells(intOutputLastRow, 3).Value = myItem.SentOn
               'Debug.Print Format(myItem.SentOn, "ww") & vbTab & myItem
            End If
       End If
       
   Next myItem
                   
   'Output of Summary this folder
   
   OutputSumFolder xlsSheet, olFolder.Name, 5, intMailsCount
   
     
   If olFolder.Folders.Count > 0 Then
       Dim myOlFolder As Folder
       
       For Each myOlFolder In olFolder.Folders
           GetSubFolderMails xlsSheet, myOlFolder, intKW
       Next myOlFolder
 
   End If
   
End Sub
Private Function GetOpenMAPI_Folder(olInstance As Outlook.Application) As Folder
   Set GetOpenMAPI_Folder = myOlApp.GetNamespace("MAPI").Session.PickFolder
End Function

[Mikas]

Code:

Sub Alex_Outlook_auslesen()
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")

Dim objMAPIFolder As Object
Dim objFolder As Object
Dim strMails As String
Dim objNSpc As Object
Dim oFldInbox  As Object
Dim KW As String

Set objNSpc = objOutlook.GetNamespace("MAPI")
Set oFldInbox = objNSpc.GetDefaultFolder(6)

On Error GoTo errorhandler

strMails = oFldInbox.Items.Count
       
Set objOutlook = Nothing

KW = InputBox("Bitte geben Sie die KW ein, zu der Auftragszahlen hinzugefügt werden sollen.", "Eingabe KW")

KW = "C" & (KW + 5)
     
ActiveWorkbook.ActiveSheet.Range(KW).Value = strMails

KW = ""

errorhandler:

MsgBox "Bitte korrekte KW Angabe einfügen =)"

End Sub

[Mikas]

Code:

Option Explicit

Sub ListOutlookFolders()
   Dim olApp As Object
   Dim i As Long
   
   Set olApp = CreateObject("outlook.application")
   With olApp.GetNamespace("MAPI")
      For i = 1 To .Folders.Count
         ' Debug.Print .Folders(i).Name
         ShowFolder .Folders(i), 1
      Next
   End With
   
   Set olApp = Nothing
End Sub

Public Sub ShowFolder(objFolder As Object, intLevel As Integer)
   Dim objSubFolder As Object
   
   Debug.Print intLevel, objFolder.Name
   For Each objSubFolder In objFolder.Folders
      ShowFolder objSubFolder, intLevel + 1
   Next
End Sub

[Mikas]

Code:

Option Explicit
Dim i&
Sub x()
   Dim fldStart As MAPIFolder
   Dim olApp As Outlook.Application
   
'diverse Variable
   Dim x$, Ordner
'Verwendung der Variable "Ordner" ist mir nicht klar
   
'Vorbereitung eines neuen Ausgabeblattes
   x = Format(Time, "hh-mm-ss")
   Sheets.Add.Name = Ordner & " " & x
   [A1].Value = "Outlook-Folder"
   [B1].Value = "Datum / Uhrzeit"
   [C1].Value = "Virus"
   [D1].Value = "Computer"
   [E1].Value = "Betreffzeile"
   [F1].Value = "Folder"

   i = 2 'Startzeile der Ausgabe, 1 = Kopfzeile
   
   Set olApp = CreateObject("Outlook.Application")
   ShowFolder olApp.GetNamespace("MAPI").Session.PickFolder

   Set olApp = Nothing
End Sub

Sub ShowFolder(f As MAPIFolder)
Dim fsub As MAPIFolder

Dim Nachricht As Outlook.MailItem
Dim objekte As Outlook.Items
Dim Start1&, start2&, start3&, start4&, start5&, start6&
Dim Ende1&, Ende2&, Ende3&, Ende4&, Ende5&, Ende6&

Dim AnzEintraege&, AnzOrdner&

'diverse Variablen ????
Dim tage, GlobDat

tage = 1 'geändert zu Testzwecken
AnzEintraege = f.Items.Count 'gilt nur für den aktuellen Ordner

'-----------------------------------------
For Each Nachricht In f.Items
   With Nachricht
       If InStr(1, .Subject, "Virus", vbTextCompare) > 0 Or _
           InStr(1, .Subject, "found", vbTextCompare) > 0 Then
'----------------------
           Application.StatusBar = "Lese Posteingang " & _
           f.Name & " " & Format(i / AnzEintraege, "0%")
   ' i / AnzEintraege = Zeilennummer / Anzahl Mails? ein weiterer Zähler wäre nötig!

'-------------------
           If tage = 999 Then GoTo Alle
           GlobDat = Date - tage
           If .SentOn < GlobDat Then Exit For '
Alle:
           On Error Resume Next
           Cells(i, 1).Select ' gewollt? nicht nötig
           Start1 = InStr(1, .Body, "Virus", vbTextCompare)
           Ende1 = InStr(Start1, .Body, Chr(10), vbTextCompare)
           start2 = InStr(1, .Body, "Folder", vbTextCompare)
           Ende2 = InStr(start2, .Body, Chr(10), vbTextCompare)
           start3 = InStr(1, .Body, "File", vbTextCompare)
           Ende3 = InStr(start3, .Body, Chr(10), vbTextCompare)
           start4 = InStr(1, .Body, "Computer", vbTextCompare)
           Ende4 = InStr(start4, .Body, Chr(10), vbTextCompare)
           Cells(i, 1) = f.Name
           Cells(i, 2) = .SentOn
           Cells(i, 3) = Mid(.Body, Start1, Ende1 - Start1 - 1)
           Cells(i, 4) = Mid(.Body, start4, Ende4 - start4 - 1)
           Cells(i, 5) = .Subject
           Cells(i, 6) = Mid(.Body, start2, Ende2 - start2 - 1)
           Cells(i, 7) = Mid(.Body, start3, Ende3 - start3 - 1)
           i = i + 1
nexterSatz:
       End If
   End With
Next Nachricht
 
   For Each fsub In f.Folders
       ShowFolder fsub
   Next
   Set fsub = Nothing
   Set f = Nothing
End Sub

[Mikas]

Das ist dann die Lösung meines Problemes ::)
Leider wusste ich nicht wie ich diese einzelnen Module am besten aufzeige.


Vielen Dank für die hilfe.