AW: Einen entspr. Tipp hast Du doch schon erhalten...
18.01.2018 17:06:26
firmus
Hi Mario,
hier ein getestetes Beispiel:
1. läuft in outlook, in einem eigenem Modul (kann aber auch in VBAProjectOTM sein).
2. initiert eine Excel-instanz
3. erstellt ein XLS-Workbook
4. Sucht einen bestimmten Outlook-Ordner
5. Liest aus diesem Outlook-Ordner alle Emails aus.
6. Liest aus jedem Email anhand von "Eyecatchern" mehrere Werte aus,
und setzt sie in das XLS-Blatt (1 email = 1 Zeile)
7. speichert die xls-file in ein ganz normales Datenverzeichnis
8. Erstellt eine Email und attached diese xls-file
9. prüft, ob es eine gültige Emailadresse für den Versand ist.
10 verschickt die Email.
Ein Fortschrittsbalken ist enthalten, den solltest du entfernen, da die Forms nicht dabei ist.
' Markieren und Auslesen der BRAENS entries in der Inbox OLUT nnnn
Sub OLUT310_BRAENS_2XLS()
Dim myMail As Object 'MailItem
Dim TSTmail As Object 'MailItem
Dim TSTreCipient As String
TSTreCipient = "Test01@mydomain.de"
'MsgBox "works ok, but needs some more testing regards: all taken?"
Dim myENTRIESCount As Long, x As Long
Dim O300BRAENSolApp As Outlook.Application
Dim O300BRAENS_NS As Outlook.NameSpace
Dim O300BRAENS_FO1 As Outlook.MAPIFolder
Dim O300BRAENS_FO2 As Outlook.MAPIFolder
Dim tmpC1, tmpC2, tmpC3, tmpC4, tmpC5, tmpC6, tmpC7, tmpC8, tmpC9 As String
Dim tmpN1, tmpN2, tmpN3, tmpN4, tmpN5, tmpN6, TSTTABZ As Long
Dim tmpX1, tmpX2, tmpX3, tmpX4, tmpX5, tmpX6 As Long
Dim outFile As String
Dim excApp As Object
Dim excWkb As Object
Dim excWks As Object
Dim intRow As Long, k As Long
' EXCEL-File: Task aufsetzen.
Set excApp = Nothing
Set excApp = New Excel.Application
excApp.Visible = True 'für debug
excApp.ScreenUpdating = True 'False
excApp.Workbooks.Add
Set excWkb = excApp.ActiveWorkbook
Set excWks = excWkb.Sheets(1)
' OUTLOOK: auf Folder "BRAENS" aufsetzen, Counter festhalten
Set O300BRAENSolApp = CreateObject("Outlook.Application")
Set O300BRAENS_NS = O300BRAENSolApp.GetNamespace("MAPI")
Set O300BRAENS_FO1 = O300BRAENS_NS.GetDefaultFolder(olFolderInbox)
For tmpN1 = 1 To O300BRAENS_FO1.Folders.count
tmpC1 = O300BRAENS_FO1.Folders(tmpN1).Name
If InStr(1, O300BRAENS_FO1.Folders(tmpN1).Name, "BRAENS") Then
Set O300BRAENS_FO2 = O300BRAENS_FO1.Folders(tmpN1)
End If
Next tmpN1
myENTRIESCount = O300BRAENS_FO1.Items.count
TEXT1.Show vbModeless
TEXT1.Caption = "Fortschrittbalken (count + %)"
' Alle Entries der Inbox auf BRAENS als Absender prüefen + Fortschrittsbalken update
Dim TSTTAB(20, 2) As Variant
TSTTABZ = 17
TSTTAB(1, 1) = "Contact Phone ="
TSTTAB(2, 1) = "Contact Name ="
TSTTAB(3, 1) = "Subject ="
TSTTAB(4, 1) = "Created Date ="
TSTTAB(5, 1) = "Account Name ="
TSTTAB(6, 1) = "Product ="
TSTTAB(7, 1) = "Component Code ="
TSTTAB(8, 1) = "Site Association ="
TSTTAB(9, 1) = "Component ="
TSTTAB(10, 1) = "Product Code ="
TSTTAB(11, 1) = "Case Owner ="
TSTTAB(12, 1) = "Case Number ="
TSTTAB(13, 1) = "Site Country ="
TSTTAB(14, 1) = "Severity ="
TSTTAB(15, 1) = "Component Name ="
TSTTAB(16, 1) = "CustomerID ="
TSTTAB(17, 1) = "Email-TIMESTAMP"
' EXCEL-File: Header in Zeile 1 setzen
GoTo ausgabeXLS
ausgabeXLS:
zeile = 1
For tmpN5 = 1 To TSTTABZ
excWks.Cells(zeile, tmpN5).Value = TSTTAB(tmpN5, 1) 'Headerbegriffe _
ausgeben
Next tmpN5
' Fortschrittsbalken update
For myENTRIESCount = 1 To O300BRAENS_FO2.Items.count
DoEvents
'progress stats
tmpN1 = Round(((myENTRIESCount * 100) / O300BRAENS_FO2.Items.count), 2)
tmpC3 = "done: " & myENTRIESCount & " of " & O300BRAENS_FO2.Items.count
tmpC3 = tmpC3 & " (" & tmpN1 & " %)"
TEXT1.Textbox1.Caption = tmpC3
'loop through Folder "BRAENS" and Verify
If O300BRAENS_FO2.Items(myENTRIESCount).Class = 43 Then 'olMailItem
Set myMail = O300BRAENS_FO2.Items(myENTRIESCount)
On Error Resume Next
tmpC4 = myMail.Subject
tmpC5 = UCase(myMail.SenderName)
On Error GoTo 0
' Check if BRAENS-entry found, work on it: SENDER=braens@ca.com
' Alle Entries in Folder "BRAENS" auf BRAENS als Absender prüefen + Fortschrittsbalken update
If InStr(1, tmpC5, "BRAENS") 0 Then 'Email FROM: email-adresse
tmpC4 = tmpC4 'debug Email-subject
tmpC8 = myMail.Body 'debug Email-body
'check the subject to verify
If InStr(1, tmpC4, "Cases Alert") 0 And InStr(1, tmpC4, " SEV1,") _
0 Then 'subject pruefen
tmpC4 = tmpC4
' Zeile zusammenstellen aus dem Email-Body
' Einzelne Parameter lt. Tabelle abgreifen, die Zeilen sind mit CHR(13) zu finden (Umkehr: ASC( _
))
' TAB(n,1) beinhaltet die VergleichsBEGRIFFE
' TAB(1,2) beinhaltet den dazugehörigen WERTE
tmpC2 = myMail.Body 'TMPC2 beinhaltet den Email-Body _
zum Vergleich.
'TabellenWERTE löschen vor Verwendung
For tmpN5 = 1 To TSTTABZ
TSTTAB(tmpN5, 2) = ""
Next tmpN5
'Werte in Tabellenraster setzen
For tmpN5 = 1 To TSTTABZ
If InStr(1, tmpC2, TSTTAB(tmpN5, 1)) > 0 Then 'Werte 1-n _
suchen im Body (tmpC2)
' tmpX1 = tmpN5 'index _
gefunden at entry "nnn" festhalten
tmpN3 = InStr(1, tmpC2, TSTTAB(tmpN5, 1)) 'position _
im Body festhalten: WO wurde der Parameterbegriff(n) gefunden."
tmpN4 = InStr(tmpN3, tmpC2, Chr(13)) 'position " _
end-of-line" im body suchen (Ende des ParameterWERTs)
tmpC5 = Mid(tmpC2, tmpN3, (tmpN4 - tmpN3)) 'Parameter- _
BEGRIFF + -WERT aus Body entnehmen, in TMPC5 setzen
tmpC5 = Replace(tmpC5, TSTTAB(tmpN5, 1), "") 'Parameter- _
BEGRIFF (x,1) per REPLACE entfernen.
TSTTAB(tmpN5, 2) = tmpC5 'Parameter- _
WERT in Tabelle setzen (x,2)
End If
Next tmpN5
TSTTAB(TSTTABZ, 2) = Format(myMail.ReceivedTime, "YYYYMMDD-hhmmss") _
'Format CHAR
' Excel-Zeile aus TSTTAB-werten zusammensetzen (x,2) entnehmen
zeile = zeile + 1
tmpC7 = ""
For tmpN5 = 1 To TSTTABZ
excWks.Cells(zeile, tmpN5).Value = TSTTAB(tmpN5, 2) '
Next tmpN5
excWks.Cells(zeile, tmpN5 + 1).Value = myMail.ReceivedTime ' _
Format DATE
End If
Else
x = x 'class is not MailItem
End If
End If
Set myMail = Nothing
Set TSTmail = Nothing
Next myENTRIESCount
x = x
' EXCEL-File formatieren und sortieren: Aktuelle Meldungen oben,
excWks.Activate
excWks.Cells.Columns.AutoFit
excWks.Cells.Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("Q2:Q999") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:Q9999")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' EXCEL-File speichern und per Email verschicken.
OutputFileName = "C:\My Documents\GEM\__SixSigma\MyPROJECT\CurrentData\" _
'Pfad
OutputFileName = OutputFileName & "GB_BR_BRAENS_Email" & Format((Now), "YYYYMMDD-hhmmss") & _
".xlsx" 'Filename+timestamp
excWkb.SaveAs FileName:=OutputFileName
'ActiveWorkbook.SaveAs FileName:=xfilename 'save file-backup mit timestamp
Set TSTmail = O300BRAENSolApp.CreateItem(olMailItem)
With TSTmail
With .Recipients.Add(TSTreCipient)
.Type = olTo
If Not .Resolve Then
MsgBox "O300BRAENS_msg002: Unable to resolve Mail-Address:" & _
TSTreCipient
Exit Sub
End If
End With
.Attachments.Add OutputFileName
.Subject = "BRAENS-Results-List, asof: " & Date & " " & Time()
.Body = "aktuelle BRAENS_Übersicht"
.Send
End With
x = x
MsgBox "O300BRAENS_msg003: Erfolgreich beendet," & Chr(13) & "NO Email an " & _
TSTreCipient & " versandt."
Unload TEXT1
x = x
closeANDend:
excWkb.Close
End Sub
Lass wissen, ob es klappt.
Gruss
Firmus