1 Makro aus 8

Tech-Archive recommends: Speed Up your PC by fixing your registry

Liebe NG,

ich habe 8 Makros für Outlook, um meine Mails im msg-Format zu speichern.
Ich würde diese
gernealle in einem Makro zusammenfassen, damit ich nicht 8 Makros laufen
lassen muss, um meine Mails abzuspeichern, sondern alles in einem Schritt
geht.

Jedes Makro deckt einen Mail-Ordner ab. Der Pfad ist:

"E:\Postfach\Outlook\Mail Store\Inbox\... s. jeweils unten\"


Inbox
Inbox Geschäftlich
Inbox Privat
Sent Items
Sent Geschäftlich
Sent Privat
Drafts
Outbox

Im Anschluss an meine weiteren Fragen habe ich den Code zu den Makros
einkopiert.

Hier meine weiteren Fragen: Wenn ich die Makros ausführe, verliert meine
Shell32.dll ihre Icons. Diese sind nach einem Neustart des Computers zwar
wieder vorhanden, das bedeutet aber, dass ich einen Neustart machen muss, um
normal weiterarbeiten zu können, wenn ich meine Mails abgespeichert habe.
Woran liegt das? Ordner, die ein Icon aus dieser Shell32.dll bekommen haben,
haben kein Icon mehr. Ausserdem würde mich noch interessieren, wieso ich
seit dem Anlegen dieser Makros von Outlook gefragt werde, ob ich Makros
enablen möchte, wenn ich Makros aufrufe. Ich habe die Makro-Sicherheitsstufe
auf mittel gestellt. Ist das ok?

Hier ist der Code zu meinen 8 Makros:

Makro Nummer 1:

Sub SaveAllMsgs()
Dim objNamespace As NameSpace
Dim objFolder As MAPIFolder
Dim objTmp As Object
Dim Cnt&
Dim strFName As String, strDate As String

Const cstrFolder = "E:\Postfach\Outlook\Mail Store\Inbox\Inbox\"

Set objNamespace = GetNamespace("MAPI")
Set objFolder = objNamespace.PickFolder
If objFolder Is Nothing Then Exit Sub
If objFolder.DefaultItemType <> olMailItem Then
Beep
MsgBox "Ordner ist kein Nachrichtenordner!", _
vbOKOnly + vbExclamation, "!!! Problem !!!"
Exit Sub
End If


Cnt = 0
For Each objTmp In objFolder.Items
With objTmp
On Error Resume Next
strDate = Format$(.ReceivedTime, _
"yyyy-mm-dd hh-nn-ss")
If Err <> 0 Then strDate = Format$(Now, _
"yyyy-mm-dd hh-nn-ss")
strFName = cstrFolder & strDate & " " & _
FileSysName(objTmp.Subject)
.SaveAs strFName, olMSG
End With
Cnt = Cnt + 1
Next objTmp

Beep
If Cnt > 0 Then
MsgBox "Es wurden " & CStr(Cnt) & _
" Nachrichten in " & _
cstrFolder & " gesichert...", _
vbOKOnly + vbInformation, _
"Alle Nachrichten speichern:"
Else
MsgBox "Keine Nachrichten zum Speichern gefunden!", _
vbOKOnly + vbExclamation, _
"Alle Nachrichten speichern:"
End If

End Sub

Function FileSysName(strSubject As String) As String
Dim strInvalid
Dim I&

strInvalid = "\/:+*?<>|" & Chr$(34)
For I = 1 To Len(strSubject)
If InStr(strInvalid, Mid$(strSubject, I, 1)) <> 0 Then
Mid$(strSubject, I, 1) = "_"
End If
Next I
FileSysName = strSubject & ".msg"

End Function




Makro Nummer 2:

Sub SaveAllMsgs()
Dim objNamespace As NameSpace
Dim objFolder As MAPIFolder
Dim objTmp As Object
Dim Cnt&
Dim strFName As String, strDate As String

Const cstrFolder = "E:\Postfach\Outlook\Mail Store\Inbox\Inbox
Geschäftlich\"

Set objNamespace = GetNamespace("MAPI")
Set objFolder = objNamespace.PickFolder
If objFolder Is Nothing Then Exit Sub
If objFolder.DefaultItemType <> olMailItem Then
Beep
MsgBox "Ordner ist kein Nachrichtenordner!", _
vbOKOnly + vbExclamation, "!!! Problem !!!"
Exit Sub
End If


Cnt = 0
For Each objTmp In objFolder.Items
With objTmp
On Error Resume Next
strDate = Format$(.ReceivedTime, _
"yyyy-mm-dd hh-nn-ss")
If Err <> 0 Then strDate = Format$(Now, _
"yyyy-mm-dd hh-nn-ss")
strFName = cstrFolder & strDate & " " & _
FileSysName(objTmp.Subject)
.SaveAs strFName, olMSG
End With
Cnt = Cnt + 1
Next objTmp

Beep
If Cnt > 0 Then
MsgBox "Es wurden " & CStr(Cnt) & _
" Nachrichten in " & _
cstrFolder & " gesichert...", _
vbOKOnly + vbInformation, _
"Alle Nachrichten speichern:"
Else
MsgBox "Keine Nachrichten zum Speichern gefunden!", _
vbOKOnly + vbExclamation, _
"Alle Nachrichten speichern:"
End If

End Sub

Function FileSysName(strSubject As String) As String
Dim strInvalid
Dim I&

strInvalid = "\/:+*?<>|" & Chr$(34)
For I = 1 To Len(strSubject)
If InStr(strInvalid, Mid$(strSubject, I, 1)) <> 0 Then
Mid$(strSubject, I, 1) = "_"
End If
Next I
FileSysName = strSubject & ".msg"

End Function


Makro Nummer 3:

Sub SaveAllMsgs()
Dim objNamespace As NameSpace
Dim objFolder As MAPIFolder
Dim objTmp As Object
Dim Cnt&
Dim strFName As String, strDate As String

Const cstrFolder = "E:\Postfach\Outlook\Mail Store\Inbox\Inbox Privat\"

Set objNamespace = GetNamespace("MAPI")
Set objFolder = objNamespace.PickFolder
If objFolder Is Nothing Then Exit Sub
If objFolder.DefaultItemType <> olMailItem Then
Beep
MsgBox "Ordner ist kein Nachrichtenordner!", _
vbOKOnly + vbExclamation, "!!! Problem !!!"
Exit Sub
End If


Cnt = 0
For Each objTmp In objFolder.Items
With objTmp
On Error Resume Next
strDate = Format$(.ReceivedTime, _
"yyyy-mm-dd hh-nn-ss")
If Err <> 0 Then strDate = Format$(Now, _
"yyyy-mm-dd hh-nn-ss")
strFName = cstrFolder & strDate & " " & _
FileSysName(objTmp.Subject)
.SaveAs strFName, olMSG
End With
Cnt = Cnt + 1
Next objTmp

Beep
If Cnt > 0 Then
MsgBox "Es wurden " & CStr(Cnt) & _
" Nachrichten in " & _
cstrFolder & " gesichert...", _
vbOKOnly + vbInformation, _
"Alle Nachrichten speichern:"
Else
MsgBox "Keine Nachrichten zum Speichern gefunden!", _
vbOKOnly + vbExclamation, _
"Alle Nachrichten speichern:"
End If

End Sub

Function FileSysName(strSubject As String) As String
Dim strInvalid
Dim I&

strInvalid = "\/:+*?<>|" & Chr$(34)
For I = 1 To Len(strSubject)
If InStr(strInvalid, Mid$(strSubject, I, 1)) <> 0 Then
Mid$(strSubject, I, 1) = "_"
End If
Next I
FileSysName = strSubject & ".msg"

End Function


Makro Nummer 4:

Sub SaveAllMsgs()
Dim objNamespace As NameSpace
Dim objFolder As MAPIFolder
Dim objTmp As Object
Dim Cnt&
Dim strFName As String, strDate As String

Const cstrFolder = "E:\Postfach\Outlook\Mail Store\Sent Items\Sent Items\"

Set objNamespace = GetNamespace("MAPI")
Set objFolder = objNamespace.PickFolder
If objFolder Is Nothing Then Exit Sub
If objFolder.DefaultItemType <> olMailItem Then
Beep
MsgBox "Ordner ist kein Nachrichtenordner!", _
vbOKOnly + vbExclamation, "!!! Problem !!!"
Exit Sub
End If


Cnt = 0
For Each objTmp In objFolder.Items
With objTmp
On Error Resume Next
strDate = Format$(.ReceivedTime, _
"yyyy-mm-dd hh-nn-ss")
If Err <> 0 Then strDate = Format$(Now, _
"yyyy-mm-dd hh-nn-ss")
strFName = cstrFolder & strDate & " " & _
FileSysName(objTmp.Subject)
.SaveAs strFName, olMSG
End With
Cnt = Cnt + 1
Next objTmp

Beep
If Cnt > 0 Then
MsgBox "Es wurden " & CStr(Cnt) & _
" Nachrichten in " & _
cstrFolder & " gesichert...", _
vbOKOnly + vbInformation, _
"Alle Nachrichten speichern:"
Else
MsgBox "Keine Nachrichten zum Speichern gefunden!", _
vbOKOnly + vbExclamation, _
"Alle Nachrichten speichern:"
End If

End Sub

Function FileSysName(strSubject As String) As String
Dim strInvalid
Dim I&

strInvalid = "\/:+*?<>|" & Chr$(34)
For I = 1 To Len(strSubject)
If InStr(strInvalid, Mid$(strSubject, I, 1)) <> 0 Then
Mid$(strSubject, I, 1) = "_"
End If
Next I
FileSysName = strSubject & ".msg"

End Function


Makro Nummer 5:

Sub SaveAllMsgs()
Dim objNamespace As NameSpace
Dim objFolder As MAPIFolder
Dim objTmp As Object
Dim Cnt&
Dim strFName As String, strDate As String

Const cstrFolder = "E:\Postfach\Outlook\Mail Store\Sent Items\Sent
Geschäftlich\"

Set objNamespace = GetNamespace("MAPI")
Set objFolder = objNamespace.PickFolder
If objFolder Is Nothing Then Exit Sub
If objFolder.DefaultItemType <> olMailItem Then
Beep
MsgBox "Ordner ist kein Nachrichtenordner!", _
vbOKOnly + vbExclamation, "!!! Problem !!!"
Exit Sub
End If


Cnt = 0
For Each objTmp In objFolder.Items
With objTmp
On Error Resume Next
strDate = Format$(.ReceivedTime, _
"yyyy-mm-dd hh-nn-ss")
If Err <> 0 Then strDate = Format$(Now, _
"yyyy-mm-dd hh-nn-ss")
strFName = cstrFolder & strDate & " " & _
FileSysName(objTmp.Subject)
.SaveAs strFName, olMSG
End With
Cnt = Cnt + 1
Next objTmp

Beep
If Cnt > 0 Then
MsgBox "Es wurden " & CStr(Cnt) & _
" Nachrichten in " & _
cstrFolder & " gesichert...", _
vbOKOnly + vbInformation, _
"Alle Nachrichten speichern:"
Else
MsgBox "Keine Nachrichten zum Speichern gefunden!", _
vbOKOnly + vbExclamation, _
"Alle Nachrichten speichern:"
End If

End Sub

Function FileSysName(strSubject As String) As String
Dim strInvalid
Dim I&

strInvalid = "\/:+*?<>|" & Chr$(34)
For I = 1 To Len(strSubject)
If InStr(strInvalid, Mid$(strSubject, I, 1)) <> 0 Then
Mid$(strSubject, I, 1) = "_"
End If
Next I
FileSysName = strSubject & ".msg"

End Function


Makro Nummer 6:

Sub SaveAllMsgs()
Dim objNamespace As NameSpace
Dim objFolder As MAPIFolder
Dim objTmp As Object
Dim Cnt&
Dim strFName As String, strDate As String

Const cstrFolder = "E:\Postfach\Outlook\Mail Store\Sent Items\Sent
Privat\"

Set objNamespace = GetNamespace("MAPI")
Set objFolder = objNamespace.PickFolder
If objFolder Is Nothing Then Exit Sub
If objFolder.DefaultItemType <> olMailItem Then
Beep
MsgBox "Ordner ist kein Nachrichtenordner!", _
vbOKOnly + vbExclamation, "!!! Problem !!!"
Exit Sub
End If


Cnt = 0
For Each objTmp In objFolder.Items
With objTmp
On Error Resume Next
strDate = Format$(.ReceivedTime, _
"yyyy-mm-dd hh-nn-ss")
If Err <> 0 Then strDate = Format$(Now, _
"yyyy-mm-dd hh-nn-ss")
strFName = cstrFolder & strDate & " " & _
FileSysName(objTmp.Subject)
.SaveAs strFName, olMSG
End With
Cnt = Cnt + 1
Next objTmp

Beep
If Cnt > 0 Then
MsgBox "Es wurden " & CStr(Cnt) & _
" Nachrichten in " & _
cstrFolder & " gesichert...", _
vbOKOnly + vbInformation, _
"Alle Nachrichten speichern:"
Else
MsgBox "Keine Nachrichten zum Speichern gefunden!", _
vbOKOnly + vbExclamation, _
"Alle Nachrichten speichern:"
End If

End Sub

Function FileSysName(strSubject As String) As String
Dim strInvalid
Dim I&

strInvalid = "\/:+*?<>|" & Chr$(34)
For I = 1 To Len(strSubject)
If InStr(strInvalid, Mid$(strSubject, I, 1)) <> 0 Then
Mid$(strSubject, I, 1) = "_"
End If
Next I
FileSysName = strSubject & ".msg"

End Function


Makro Nummer 7:

Sub SaveAllMsgs()
Dim objNamespace As NameSpace
Dim objFolder As MAPIFolder
Dim objTmp As Object
Dim Cnt&
Dim strFName As String, strDate As String

Const cstrFolder = "E:\Postfach\Outlook\Mail Store\Drafts\"

Set objNamespace = GetNamespace("MAPI")
Set objFolder = objNamespace.PickFolder
If objFolder Is Nothing Then Exit Sub
If objFolder.DefaultItemType <> olMailItem Then
Beep
MsgBox "Ordner ist kein Nachrichtenordner!", _
vbOKOnly + vbExclamation, "!!! Problem !!!"
Exit Sub
End If


Cnt = 0
For Each objTmp In objFolder.Items
With objTmp
On Error Resume Next
strDate = Format$(.ReceivedTime, _
"yyyy-mm-dd hh-nn-ss")
If Err <> 0 Then strDate = Format$(Now, _
"yyyy-mm-dd hh-nn-ss")
strFName = cstrFolder & strDate & " " & _
FileSysName(objTmp.Subject)
.SaveAs strFName, olMSG
End With
Cnt = Cnt + 1
Next objTmp

Beep
If Cnt > 0 Then
MsgBox "Es wurden " & CStr(Cnt) & _
" Nachrichten in " & _
cstrFolder & " gesichert...", _
vbOKOnly + vbInformation, _
"Alle Nachrichten speichern:"
Else
MsgBox "Keine Nachrichten zum Speichern gefunden!", _
vbOKOnly + vbExclamation, _
"Alle Nachrichten speichern:"
End If

End Sub

Function FileSysName(strSubject As String) As String
Dim strInvalid
Dim I&

strInvalid = "\/:+*?<>|" & Chr$(34)
For I = 1 To Len(strSubject)
If InStr(strInvalid, Mid$(strSubject, I, 1)) <> 0 Then
Mid$(strSubject, I, 1) = "_"
End If
Next I
FileSysName = strSubject & ".msg"

End Function


Makro Nummer 8:

Sub SaveAllMsgs()
Dim objNamespace As NameSpace
Dim objFolder As MAPIFolder
Dim objTmp As Object
Dim Cnt&
Dim strFName As String, strDate As String

Const cstrFolder = "E:\Postfach\Outlook\Mail Store\Outbox\"

Set objNamespace = GetNamespace("MAPI")
Set objFolder = objNamespace.PickFolder
If objFolder Is Nothing Then Exit Sub
If objFolder.DefaultItemType <> olMailItem Then
Beep
MsgBox "Ordner ist kein Nachrichtenordner!", _
vbOKOnly + vbExclamation, "!!! Problem !!!"
Exit Sub
End If


Cnt = 0
For Each objTmp In objFolder.Items
With objTmp
On Error Resume Next
strDate = Format$(.ReceivedTime, _
"yyyy-mm-dd hh-nn-ss")
If Err <> 0 Then strDate = Format$(Now, _
"yyyy-mm-dd hh-nn-ss")
strFName = cstrFolder & strDate & " " & _
FileSysName(objTmp.Subject)
.SaveAs strFName, olMSG
End With
Cnt = Cnt + 1
Next objTmp

Beep
If Cnt > 0 Then
MsgBox "Es wurden " & CStr(Cnt) & _
" Nachrichten in " & _
cstrFolder & " gesichert...", _
vbOKOnly + vbInformation, _
"Alle Nachrichten speichern:"
Else
MsgBox "Keine Nachrichten zum Speichern gefunden!", _
vbOKOnly + vbExclamation, _
"Alle Nachrichten speichern:"
End If

End Sub

Function FileSysName(strSubject As String) As String
Dim strInvalid
Dim I&

strInvalid = "\/:+*?<>|" & Chr$(34)
For I = 1 To Len(strSubject)
If InStr(strInvalid, Mid$(strSubject, I, 1)) <> 0 Then
Mid$(strSubject, I, 1) = "_"
End If
Next I
FileSysName = strSubject & ".msg"

End Function


So, das war's. Vielen Dank für Eure Hilfe.

--
Viktoria Fragstein

ViktoriaFragstein@xxxxxxxxxxx


XP Home SP2, Office 2003, IE + OE 6.0




.

Relevant Pages