Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1192to1196
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Script zum Speichern

Script zum Speichern
René
- über Regel Speicherscript ausführen Nach oben
Version: Office 2003
--------------------------------------------------------------------------------
Hallo liebe Tüftler,
ich möchte über eine Regel automatisch Mails in einem Ordner im Explorer speichern. Die Regel soll schauen ob ein bestimmtes Wort in der Betreffzeile im mail vorkommt und dann ein Script ausführen welches die Datei speichert. Leider speichert im Moment das Script aber immer die Mail die gerade markiert ist. Wie kann ich das objItem auf die E-Mail setzen, die gerade eingetroffen ist?
Im Outlookforum bin ich nicht weiter gekommen. Daher frage ich hier. Ich bin nicht der Profi, der das alleine lösen kann und würde mich sehr freuen wenn ihr mir helft. Herzlichen dank im Voraus schon mal und einen schönen Advent MfG René
Sub SaveAsTXT(Mail As Outlook.MailItem)
Dim myItem As Outlook.Inspector
Dim objItem As Object
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set objItem = myItem.CurrentItem
strname = objItem.Subject
strname = Replace(strname, ":", " ")
strname = Replace(strname, "/", " ")
'Prompt the user for confirmation
Dim strPrompt As String
strPrompt = "Are you sure you want to save the item? If a file with the same name already  _
exists, it will be overwritten with this copy of the file."
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.SaveAs "C:\Technik\" & strname & ".msg", olMSG
End If
Else
MsgBox "There is no current active inspector."
End If
End 

Sub


		

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Script zum Speichern
19.12.2010 08:02:27
Dirk
Hallo Rene,
damit das was wird musst Du erst mal feststellen, das eine email eingetroffen ist.
Dazu mal folgendes Makro in Dein Outlook VBA project kopieren:
Private Sub Application_NewMailEx _
(ByVal EntryIDCollection As String)
Dim arr() As String
Dim i As Integer
Dim ns As Outlook.NameSpace
Dim itm As MailItem
Dim m As Outlook.MailItem
On Error Resume Next
Set ns = Application.Session
arr = Split(EntryIDCollection, ",")
For i = 0 To UBound(arr)
Set itm = ns.GetItemFromID(arr(i))
If itm.Class = olMail Then
Set m = itm
'ab hier kannst Du jetzt Deine Behandlungsroutine aufrufen e.g.
msgBox "Eine neue Email ist eingetroffen!"
'm.BodyFormat = olFormatPlain   'formatier Mailbody als plain text
'm.Save                                        'speichert email im  _
Standardverzeichnis
End If
Next
Set ns = Nothing
Set itm = Nothing
Set m = Nothing
End Sub
Ich hoffe, das hilft erst mal weiter.
gruss
Dirk aus Dubai
Anzeige
AW: Script zum Speichern
19.12.2010 21:42:24
Rene
Hallo lieber Dirk,
ich danke Dir erst mal recht herzlich. Ich probiere das morgen aus und schreibe Dir dann wieder. Was machst Du in Dubai. Bist Du beruflich dort?
Gruß aus der verschneiten Heimat René
AW: Script zum Speichern
20.12.2010 19:30:52
René
Hallo Dirk,
vielen Dank noch mal. Jetzt sieht der Code so aus wie unten. Allerdings bekomme ich es absolut nicht hin das die Betreffzeile ausgelesen wird und mit als Speichername verwendet wird.
Ist es möglich das die Betreffzeile, wie im ersten Bastelcode von mir, mit ausgelsen wird und zum Speichern genutzt wird? Wie kann ich verhindern das die Mail im Speicherordner überschrieben wird wenn der Dateiname schon vorhanden ist. Hier würde ich gern eine Erkennung haben die dann beispielsweise eine Nummerierung anhängt wenn ich zwei Mails bekomme mit gleichen strname bspw. Betreff: Aw:Rückmeldung zu Problem 1. Im Speicherordner soll es dann zwei Dateien geben
1. AW Rückmeldung zu Problem
2. AW Rückmeldung zu Problem 2
Private Sub Application_NewMailEx _
(ByVal EntryIDCollection As String)
Dim arr() As String
Dim i As Integer
Dim ns As Outlook.NameSpace
Dim itm As MailItem
Dim m As Outlook.MailItem
On Error Resume Next
Set ns = Application.Session
arr = Split(EntryIDCollection, ",")
For i = 0 To UBound(arr)
Set itm = ns.GetItemFromID(arr(i))
If itm.Class = olMail Then
Set m = itm
'ab hier kannst Du jetzt Deine Behandlungsroutine aufrufen e.g.
Dim strPrompt As String
m.SaveAs "O:\Technik\" & " " & Day(Date) & "_" & Month(Date) & "_" & Year(Date) & ". _
msg", olMSG
m.Close olSave
m.UnRead = True
End If
Next
Set ns = Nothing
Set itm = Nothing
Set m = Nothing
End Sub

Anzeige
AW: Script zum Speichern
21.12.2010 18:23:38
Dirk
Hallo Rene,
Um den Betreff zu Verwenden, musst Du diesen einfach auslesen, so wie in Deinem Ursprungscode:
SubjStr=itm.Subject
Um zu testen, ob die Datei mit dem Namen schon vorhanden ist, benutze einfach den Dir Befehl
If len(dir(Mein_ Pfad_inklusive_MeinDateiName))=0 then 'Dateiname nicht gefunden
'hier jetzt der Code zum Speichern
else
MeinDateiname=MeinDateiname & replace(cstr(cdec(now())),".","") 'haengt Datum & Zeit als Timeserial an
end if
Probier das mal aus und lass' hoeren, ob ok (nicht getestet)
Gruss
Dirk aus Dubai
AW: Script zum Speichern
21.12.2010 19:22:15
René
Hallo Dirk,
ich baue das heute abend noch mit ein und probiere es morgen auf Arbeit weil ich zu Hause kein Outlook verwende. Übrigens habe ich den Code von Dir jetzt wie folgt angepasst und habe noch zwei Fragen dazu.
Wie Du siehst habe ich eine If Anweisung eingebaut die nachschauen soll ob ein Q (soll dann mal ein Wort sein) in der Betreffzeile vorkommt. Demzufoge speichert das Makro aber nur Mails die eben nur Q im Betreff enthalten. Ich will aber das nur geschaut wird ob das Q (was eben später dann mal ein Wort sein soll oder mehrere wie zb. "Rückmeldung zu Beanstandung") als Betandteil im Betreff vorkommt.
Beispiel
im Betreff steht
Betreff: Rückmeldung zu Beanstandung 1/2011
If Anweisung soll schauen ob die Wörter "Rückmeldung zu Beanstandung" im Betreff vorkommen und Mail soll aber mit gesamter Betreffzeile als Speichername gespeichert werden.
Ich muss das machen weil in diesen Ordner eben nur unsere Rückmeldungen rein sollen und nicht alle Mails.
Schau Dir bitte mal meine If Anweisung an und gebe mir bitte einen Tip wie ich das änderen muss.
2. Problem
Kann ich das Makro auch automatisch ausführen lassen wenn ich morgens Outlook starte sonst werden die Mails die nachts angekommen sind ja nicht gespeichert. So nun mein geänderter Code mit strname und If (schaue ob Q im Betreff vorkommt).
Viele liebe Grüße aus der Heimat an Dich nach Dubai. Wir haben ganz viel Schnee im Erzgebirge und bestimmt eine weiße Weihnacht.

Private Sub Application_NewMailEx _
(ByVal EntryIDCollection As String)
Dim arr() As String
Dim i As Integer
Dim ns As Outlook.NameSpace
Dim itm As MailItem
Dim m As Outlook.MailItem
On Error Resume Next
Set ns = Application.Session
arr = Split(EntryIDCollection, ",")
For i = 0 To UBound(arr)
Set itm = ns.GetItemFromID(arr(i))
If itm.Class = olMail Then
Set m = itm
'ab hier kannst Du jetzt Deine Behandlungsroutine aufrufen e.g.
Set myItem = Application.Session.GetDefaultFolder(olFolderInbox).Items(1)
myItem.Display
Dim objItem As Object
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.ActiveInspector
strname = objItem.Subject
Set objItem = myItem.CurrentItem
strname = objItem.Subject
If Not objItem = "Q" Then
objItem.Close olSave
objItem.UnRead = True
Exit Sub
ElseIf objItem = "Q" Then
strname = Replace(strname, ":", " ")
strname = Replace(strname, "/", " ")
End If
Dim strPrompt As String
m.SaveAs "O:\Technik\" & strname & " " & "Datum" & "_" & Day(Date) & "_" & Month(Date) & _
_
_
_
"_" & Year(Date) & "_" & "Uhrzeit" & "_" & Hour(Time) & "_" & Minute(Time) & "_" & Second(Time) _
_
_
& ".msg", olMSG
Set objItem = myItem.CurrentItem
objItem.Close olSave
objItem.UnRead = True
End If
Next
Set ns = Nothing
Set itm = Nothing
Set m = Nothing
End Sub

Anzeige
AW: Script zum Speichern
22.12.2010 11:31:14
Dirk
Hallo Rene,
hier mal das Makro zum Speichern der emails waehrend outlook laeuft. (Die Mail wird weder geoeffnet noch verschoben!)
Fuer den Fall, das Du mails bekommen hast waehrend Dein outlook geschlossen war muesste man noch ein Makro schreiben, welches alle neueingetroffenen emails nach dem letzten Datum in Deinem Speicherordner durchsucht und dann entsprechend alle emails dorthin speichert, welche den Kriterien entsprechen.
Habe heute leider keine Zeit, das noch zu machen.
gruss
Dirk aus Dubai
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim strID As String
Dim objItem As Object
Dim itm As MailItem
Dim StrName As String
Dim MyBetreff As String
Dim m As Outlook.MailItem
MyBetreff = "Rückmeldung zu Beanstandung"
strID = EntryIDCollection
Set objItem = Application.Session.GetItemFromID(strID)
Set itm = objItem
If itm.Class = olMail Then
Set m = itm
'ab hier kannst Du jetzt Deine Behandlungsroutine aufrufen e.g.
StrName = m.Subject
If InStr(1, StrName, MyBetreff) = 0 Then
objItem.Close olSave
objItem.UnRead = True
Exit Sub
ElseIf InStr(1, StrName, MyBetreff)  0 Then
StrName = Replace(StrName, ":", " ")
StrName = Replace(StrName, "/", " ")
End If
m.SaveAs "D:\My Documents\MailTest\" & StrName & " " & "Datum" & "_" & Day(Now) & " _
_" & Month(Now) & "_" & _
Year(Now) & "_" & "Uhrzeit" & "_" & Hour(Now) & "_" & Minute(Now) & "_" & Second( _
Now) & ".msg" _
, olMSG
Set itm = Nothing
Set objItem = Nothing
End If
Debug.Print "Eine neue Email ist eingetroffen " & strID
End Sub

Anzeige
AW: Script zum Speichern
22.12.2010 11:51:59
Dirk
Sorry!
Hatt noch vergessen, das es ja auch noch Kalenderanforderungen gibt.
Hier der korrigierte code:
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim strID As String
Dim objItem As Object
Dim StrName As String
Dim MyBetreff As String
Dim m As Outlook.MailItem
MyBetreff = "Rückmeldung zu Beanstandung"
strID = EntryIDCollection
Set objItem = Application.Session.GetItemFromID(strID)
If objItem.Class = olMail Then
Set m = objItem
'ab hier kannst Du jetzt Deine Behandlungsroutine aufrufen e.g.
StrName = m.Subject
If InStr(1, StrName, MyBetreff) = 0 Then
objItem.Close olSave
objItem.UnRead = True
Exit Sub
ElseIf InStr(1, StrName, MyBetreff)  0 Then
StrName = Replace(StrName, ":", " ")
StrName = Replace(StrName, "/", " ")
End If
m.SaveAs "D:\My Documents\MailTest\" & StrName & " " & "Datum" & "_" & Day(Now) & " _
_" & Month(Now) & "_" & _
Year(Now) & "_" & "Uhrzeit" & "_" & Hour(Now) & "_" & Minute(Now) & "_" & Second( _
Now) & ".msg" _
, olMSG
Set objItem = Nothing
Debug.Print "A new mail arrived " & strID
End If
End Sub
BR
Dirk aus Dubai
Anzeige
AW: Script zum Speichern
22.12.2010 12:21:30
René
Hallo Dirk,
Du bist ein Profi, funktioniert super. Würde Dir am liebsten was gutes tun. Möchtest Du etwas aus Deutschland geschickt bekommen? Würde ich glatt machen.
Habe den Code jetzt wie hier unten in meinem Outllok und der funktioniert super.
Habe aber trotzdem noch Probleme mit dem Prüfen ob die Datei schon gespeichert ist. Habe lange gebastelt , bekomme es aber nicht gebacken.
MfG René
Private Sub Application_NewMailEx _
(ByVal EntryIDCollection As String)
Dim arr() As String
Dim i As Integer
Dim ns As Outlook.NameSpace
Dim itm As MailItem
Dim m As Outlook.MailItem
Dim MyBetreff As String
MyBetreff = "Rückmeldung zu Beanstandung"
On Error Resume Next
Set ns = Application.Session
arr = Split(EntryIDCollection, ",")
For i = 0 To UBound(arr)
Set itm = ns.GetItemFromID(arr(i))
If itm.Class = olMail Then
Set m = itm
Set myItem = Application.Session.GetDefaultFolder(olFolderInbox).Items(1)
myItem.Display
Dim objItem As Object
Set myOlApp = CreateObject("Outlook.Application")
Set myItem = myOlApp.ActiveInspector
StrName = objItem.Subject
Set objItem = myItem.CurrentItem
StrName = objItem.Subject
StrName = m.Subject
If InStr(1, StrName, MyBetreff) = 0 Then
objItem.Close olSave
objItem.UnRead = True
Exit Sub
ElseIf InStr(1, StrName, MyBetreff)  0 Then
StrName = Replace(StrName, ":", " ")
StrName = Replace(StrName, "/", " ")
End If
Dim strPrompt As String
m.SaveAs "O:\Technik\" & StrName & " " & "Datum" & "_" & Day(Date) & "_" & Month(Date) & _
"_" & Year(Date) & "_" & "Uhrzeit" & "_" & Hour(Time) & "_" & Minute(Time) & "_" & Second(Time) & ".msg", olMSG
Set objItem = myItem.CurrentItem
objItem.Close olSave
objItem.UnRead = True
End If
Next
Set ns = Nothing
Set itm = Nothing
Set m = Nothing
End Sub

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige