Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
Outlook-Script zum Speichern einer Mail
Gehe zu Seite Zurück  1, 2, 3, 4, 5, 6, 7, 8, 9  Weiter
zurück: Signatur per Makro bearbeiten weiter: Warnfenster falls Betreff schon im Postfach vorhanden ? Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Antwort Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen
Autor Nachricht
z-martin
Im Profil kannst Du frei den Rang ändern


Verfasst am:
04. Jul 2007, 23:27
Rufname:

AW: Outlook-Script zum Speichern einer Mail - AW: Outlook-Script zum Speichern einer Mail

Nach oben
       

Hi,

vielen Dank für die komplexen Skripte, genau sowas brauche ich im Moment.

Bei dieser Lösung:
Code:
Sub Speichern()

Dim myExplorer As Outlook.Explorer
Dim myfolder As Outlook.MAPIFolder
Dim strname As String
Dim myItem As MailItem
Dim olSelection As Selection
Dim strBackupPath As String

Set myExplorer = Application.ActiveExplorer
Set myfolder = myExplorer.CurrentFolder

If Not myfolder.DefaultItemType = olMailItem Then GoTo Ende

trBackupPath = GetFileDir

Set olSelection = myExplorer.Selection


For Each myItem In olSelection

strname = Format(myItem.ReceivedTime, "dd-mm-yyyy hh-nn-ss") _
& " " & IIf(Len(strBackupPath & myItem.Subject) > 255, _
Left(myItem.Subject, 255 - Len(strBackupPath)), myItem.Subject) & ".txt"

'myItem.SaveAs "C:\Dokumente und Einstellungen\Christina\Eigene Dateien\mails\" & CleanString(strname), HTML
myItem.SaveAs "C:\Dokumente und Einstellungen\Christina\Eigene Dateien\mails\" & CleanString(strname) & ".HTML"


'olTXT
       
Next
Ende:

End Sub

Private Function CleanString(strData As String) As String

    'Replace invalid strings.
    strData = ReplaceChar(strData, "´", "_")
    strData = ReplaceChar(strData, "`", "_")
    strData = ReplaceChar(strData, "'", "_")
    strData = ReplaceChar(strData, "{", "(")
    strData = ReplaceChar(strData, "[", "(")
    strData = ReplaceChar(strData, "]", ")")
    strData = ReplaceChar(strData, "}", ")")
    strData = ReplaceChar(strData, "/", "-")
    strData = ReplaceChar(strData, "\", "-")
    strData = ReplaceChar(strData, ":", "")
   
    'Cut out invalid signs.
    strData = ReplaceChar(strData, "*", "_")
    strData = ReplaceChar(strData, "?", "")
    strData = ReplaceChar(strData, """", "_")
    strData = ReplaceChar(strData, "<", "")
    strData = ReplaceChar(strData, ">", "")
    strData = ReplaceChar(strData, "|", "")
    CleanString = Trim(strData)
   
End Function


Private Function ReplaceChar(strData As String, strBadChar As String, strGoodChar As String) As String

    Dim tmpChar     As String
    Dim tmpString   As String
    Dim i           As Long
   
    For i = 1 To Len(strData)
   
        tmpChar = Mid(strData, i, 1)
       
        If tmpChar = strBadChar Then
            tmpString = tmpString & strGoodChar
        Else
            tmpString = tmpString & tmpChar
        End If
       
    Next i
   
    ReplaceChar = Trim(tmpString)

End Function



Wird jedoch die ganze Mail gespeichert. Für mich wäre jedoch nur der Inhalt, also der body interessant. Wie kann man das Skript so abändern, dass nur Dieser gespeichert wird?

Und noch eine Frage: Wie würde ein Code lauten, der die erstellte Datei direkt nach der Erstellung öffnet?


Vielen Dank
Martin
Andreas.Fischer
Outlook - Moderator


Verfasst am:
09. Jul 2007, 13:38
Rufname:
Wohnort: Berlin


AW: Outlook-Script zum Speichern einer Mail - AW: Outlook-Script zum Speichern einer Mail

Nach oben
       

Hallo Martin,

Zitat:
Wird jedoch die ganze Mail gespeichert. Für mich wäre jedoch nur der Inhalt, also der body interessant. Wie kann man das Skript so abändern, dass nur Dieser gespeichert wird?
Ich habe das Script Speichern angepasst. Du musst es nur noch durch dieses ersetzen. Die beiden Functionen nicht löschen.
Code:
Const strBackuppath = "C:\Dokumente und Einstellungen\Christina\Eigene Dateien\mails\"

Sub Speichern()

Dim myExplorer As Outlook.Explorer
Dim myfolder As Outlook.MAPIFolder
Dim strname As String
Dim myItem As MailItem
Dim olSelection As Selection
Dim saveItem As MailItem

Set myExplorer = Application.ActiveExplorer
Set myfolder = myExplorer.CurrentFolder

If Not myfolder.DefaultItemType = olMailItem Then GoTo Ende

Set olSelection = myExplorer.Selection

For Each myItem In olSelection

strname = Format(myItem.ReceivedTime, "dd-mm-yyyy hh-nn-ss") _
& " " & IIf(Len(strBackuppath & myItem.Subject) > 255, _
Left(myItem.Subject, 255 - Len(strBackuppath)), myItem.Subject) & ".html"

Set saveItem = Application.CreateItem(olMailItem)

saveItem.Body = myItem.Body
saveItem.SaveAs strBackuppath & CleanString(strname), olHTML

saveItem.Body = ""

Next
Ende:

End Sub

Zitat:
Und noch eine Frage: Wie würde ein Code lauten, der die erstellte Datei direkt nach der Erstellung öffnet?
Sorry. Da hab ich jetzt keine Lösung parat.
_________________
Gruß Andreas

Das besondere Erleben.
Gast



Verfasst am:
09. Jul 2007, 14:46
Rufname:

AW: Outlook-Script zum Speichern einer Mail - AW: Outlook-Script zum Speichern einer Mail

Nach oben
       

Hi,
vielen Dank für die schnelle Lösung und die Änderung des Skripts.


Martin
Gast



Verfasst am:
09. Jul 2007, 23:06
Rufname:

AW: Outlook-Script zum Speichern einer Mail - AW: Outlook-Script zum Speichern einer Mail

Nach oben
       

So,

Ich habe jetzt eine Lösung gefunden.

Code:
Private Function StartDoc(ByVal FileName As String, Optional CommandLine As String = "") As Long
Dim Scr_hDC As Long
Scr_hDC = GetDesktopWindow()
'change "Open" to "Explore" to bring up file explorer
StartDoc = ShellExecute(Scr_hDC, "Open", FileName, CommandLine, vbNullString, 1)

End Function


Diese Funktion am Ende des SUB Speichern aufrufen und schon funktioniert es wunderbar. Also, nochmal vielen Dank!
z-martin
Im Profil kannst Du frei den Rang ändern


Verfasst am:
09. Jul 2007, 23:09
Rufname:


AW: Outlook-Script zum Speichern einer Mail - AW: Outlook-Script zum Speichern einer Mail

Nach oben
       

Entschuldigung, irgendwie habe ich mich verklickt und konnte die Beiträge nicht ändern, weil ich nicht eingeloggt war.
z-martin
Im Profil kannst Du frei den Rang ändern


Verfasst am:
10. Jul 2007, 22:11
Rufname:

AW: Outlook-Script zum Speichern einer Mail - AW: Outlook-Script zum Speichern einer Mail

Nach oben
       

So,
die Freude war leider etwas verfrüht, bei manchen e-mails bekomme ich nun html Tags angezeigt. Scheinbar sind die Informationen hierzu im Kopf der Mail versteckt, so dass bei der Erstellung einer HTML Mail ohne Kopf die Tags angezeigt werden.

Hat vielleicht jemand eine Lösung, wie man aus dem Kopf die Info auslesen kann, ob die Mail HTML enthält, und vor allem, wie ich es schaffe, nur den Body zu speichern, aber dennoch die richtige Formatierung zu erhalten?


ciao,
Martin

Derzeitiger Stand der Dinge:
Code:
Set myfolder = myExplorer.CurrentFolder

If Not myfolder.DefaultItemType = olMailItem Then GoTo Ende

Set olSelection = myExplorer.Selection

For Each myItem In olSelection

strname = Format(myItem.ReceivedTime, "dd-mm-yyyy hh-nn-ss") _
& " " & IIf(Len(strBackuppath & myItem.Subject) > 255, _
Left(myItem.Subject, 255 - Len(strBackuppath)), myItem.Subject) & ".html"

Set saveItem = Application.CreateItem(olMailItem)

saveItem.Body = myItem.Body
saveItem.SaveAs strBackuppath & CleanString(strname), olHTML
saveItem.Body = ""

Next
Call StartDoc("C:\Dokumente und Einstellungen\Christina\Eigene Dateien\mails\" & strname)
Ende:

End Sub


Private Function CleanString(strData As String) As String

    'Replace invalid strings.
    strData = ReplaceChar(strData, "´", "_")
    strData = ReplaceChar(strData, "`", "_")
    strData = ReplaceChar(strData, "'", "_")
    strData = ReplaceChar(strData, "{", "(")
    strData = ReplaceChar(strData, "[", "(")
    strData = ReplaceChar(strData, "]", ")")
    strData = ReplaceChar(strData, "}", ")")
    strData = ReplaceChar(strData, "/", "-")
    strData = ReplaceChar(strData, "\", "-")
    strData = ReplaceChar(strData, ":", "")
   
    'Cut out invalid signs.
    strData = ReplaceChar(strData, "*", "_")
    strData = ReplaceChar(strData, "?", "")
    strData = ReplaceChar(strData, """", "_")
    strData = ReplaceChar(strData, "<", "")
    strData = ReplaceChar(strData, ">", "")
    strData = ReplaceChar(strData, "|", "")
    CleanString = Trim(strData)
   
End Function


Private Function ReplaceChar(strData As String, strBadChar As String, strGoodChar As String) As String

    Dim tmpChar     As String
    Dim tmpString   As String
    Dim i           As Long
   
    For i = 1 To Len(strData)
   
        tmpChar = Mid(strData, i, 1)
       
        If tmpChar = strBadChar Then
            tmpString = tmpString & strGoodChar
        Else
            tmpString = tmpString & tmpChar
        End If
       
    Next i
   
    ReplaceChar = Trim(tmpString)

End Function

Private Function StartDoc(ByVal FileName As String, Optional CommandLine As String = "") As Long
Dim Scr_hDC As Long
Scr_hDC = GetDesktopWindow()
'change "Open" to "Explore" to bring up file explorer
StartDoc = ShellExecute(Scr_hDC, "Open", FileName, CommandLine, vbNullString, 1)

End Function



Andreas.Fischer
Outlook - Moderator


Verfasst am:
11. Jul 2007, 10:53
Rufname:
Wohnort: Berlin

AW: Outlook-Script zum Speichern einer Mail - AW: Outlook-Script zum Speichern einer Mail

Nach oben
       

Hallo Martin,

Ich habe da noch etwas geändert. Ersetze diese Codezeilen:
Code:
saveItem.Body = myItem.Body
saveItem.SaveAs strBackuppath & CleanString(strname), olHTML
saveItem.Body = ""

durch die folgenden:
Code:
If myItem.BodyFormat = olFormatHTML Then

    saveItem.HTMLBody = myItem.HTMLBody

Else

    saveItem.Body = myItem.Body

End If

saveItem.SaveAs strBackuppath & CleanString(strname), olHTML

saveItem.Body = ""
saveItem.HTMLBody = ""

_________________
Gruß Andreas

Das besondere Erleben.
z-martin
Im Profil kannst Du frei den Rang ändern


Verfasst am:
11. Jul 2007, 20:39
Rufname:

AW: Outlook-Script zum Speichern einer Mail - AW: Outlook-Script zum Speichern einer Mail

Nach oben
       

Hi,
danke für deine Bemühungen, das Problem besteht leider immer noch unverändert.


Hast du eine Idee, woran das liegen könnte?

ciao,
Martin
Andreas.Fischer
Outlook - Moderator


Verfasst am:
16. Jul 2007, 11:22
Rufname:
Wohnort: Berlin

AW: Outlook-Script zum Speichern einer Mail - AW: Outlook-Script zum Speichern einer Mail

Nach oben
       

Hallo Martin,

Leider kann ich dein Problem nicht nachvollziehen und kann dir daher keine Lösung anbieten.

_________________
Gruß Andreas

Das besondere Erleben.
booN
Gast


Verfasst am:
22. Aug 2007, 07:52
Rufname:

AW: Outlook-Script zum Speichern einer Mail - AW: Outlook-Script zum Speichern einer Mail

Nach oben
       

Hallo
ich hab da eine Frage.
Wie kann ich mehrere Mails filtern und sortieren und alles speichern in ne textdatei.
also ich wähl nen ordner und er soll dann im gewählten ordner die mails mit einem parameter filtern und in word oder so speichern.



Code:
Dim strSearchString As String
Dim lCountOfFound As Long
Dim Path As String
Dim int_nichtmails
Dim int_mails

'Ordner auswählen
Set myNameSpace = Application.GetNamespace("MAPI")
Set objFolder = myNameSpace.PickFolder
    If objFolder Is Nothing Then
    MsgBox "Der Benutzer hat abgebrochen", vbInformation
    Else
    objFolder.Display
    End If


so habe ich das mit dem ordner zugriff gemacht
nagra
Office 2007 - VBA Programmierer


Verfasst am:
22. Aug 2007, 11:13
Rufname:

AW: Outlook-Script zum Speichern einer Mail - AW: Outlook-Script zum Speichern einer Mail

Nach oben
       

Hallo!

Ich danke euch auch für diese Zusammenstellung dieses Codes!
Allerdings möchte ich die Dateien (Attachments) nicht nur in einem seperaten Ordner, der den Titel der Mail enthält speichern, sondern nach Möglichkeit soll dort auch das Datum stehen.

Ich habe versucht den Code
Code:
'Anlagen speichern
  lngAttCount = myItem.Attachments.Count
   If lngAttCount > 0 Then
    For i = lngAttCount To 1 Step -1

     With myItem.Attachments.Item(i)
      strname = IIf(Len(strBackupPath & myItem.Subject) > 255, _
                Left(myItem.Subject, 255 - Len(strBackupPath)), myItem.Subject)
               
      strSubDir = strBackupPath & "\" & CleanString(strname)

       If Dir(strSubDir, vbDirectory) = "" Then
        MkDir strSubDir
       End If


zu ändern, aber das klappt alles nicht Sad.

Wäre um eure Mithilfe sehr dankbar!

MfG,
nagra
booN
Gast


Verfasst am:
23. Aug 2007, 08:06
Rufname:

AW: Outlook-Script zum Speichern einer Mail - AW: Outlook-Script zum Speichern einer Mail

Nach oben
       

Hi
bin jetzt bisl weiter gekommen, nur brauch ich noch nen filter der dann alles filtert was man im textfeld eingegeben hat

und wie man alles zusammenführt also ich hab ein formular bei der man als erstes den ordner auswählt dann ne textbox da schreibt man rein was man filtern will und klickt dann aufn button
danach soll er das gefilterte in eine txt datei speichern

hier mein code

Code:
'Aufgabenstellung:
    'Wählen eines privaten Ordners in Outlook.
    'Mails filtern nach Typ(z.B. Netzwerkprobleme, Softwareprobleme[Parameter?])
    'sortierte Mails formatiert(z.B. Überschrift Fett) in Word einfügen

Private Sub btnds_Click()
On Error Resume Next

Dim strSearchString As String
Dim lCountOfFound As Long
Dim Path As String
Dim int_nichtmails
Dim int_mails

'Ordner auswählen
Set myNameSpace = Application.GetNamespace("MAPI")
Set objFolder = myNameSpace.PickFolder
    If objFolder Is Nothing Then
    MsgBox "Der Benutzer hat abgebrochen", vbInformation
    Else
    objFolder.Display
    End If


End Sub


Sub WalkFolders()

Dim olApp As Outlook.Application
Dim olSession As Outlook.NameSpace
Dim olStartFolder As Outlook.MAPIFolder
Dim strPrompt As String
Dim datentyp As String


lCountOfFound = 0
Set olApp = New Outlook.Application
Set olSession = olApp.GetNamespace("MAPI")


'olApp.DisplayAlerts = False
Set olStartFolder = olApp.ActiveExplorer.CurrentFolder


Path = "D:\Outlook\" & olStartFolder
MkDir Path
ProcessFolder olStartFolder
'olApp.DisplayAlerts = True
MsgBox CStr(lCountOfFound) & " Nachrichten sind kopiert worden."

End Sub

Sub ProcessFolder(CurrentFolder As Outlook.MAPIFolder)

Dim i As Long
Dim olNewFolder As Outlook.MAPIFolder
Dim olTempItem As Object
Dim Time As String
Dim Time_temp As String
Dim n As Integer
Dim noch_kein_anhang As Boolean
Dim Title As String
Dim sender As String
Dim int_mails_nummer As String
Dim int_mails_string As String

int_nichtmails = 0
int_mails = 0

For i = CurrentFolder.Items.Count To 1 Step -1

    Set olTempItem = CurrentFolder.Items(i)
       
   
    If TypeOf olTempItem Is MailItem Then
   
        Title = Left(olTempItem.Subject, 20)
        ReinigeString Title
        Time = Format(olTempItem.ReceivedTime, "yyyy-mm-dd_hh-mm")
        sender = olTempItem.SenderName
        ReinigeString sender
        'ReinigeTime Time
        int_mails = int_mails + 1
        int_mails_string = CStr(int_mails)
        Ergaenze int_mails_string
       
        int_Anhang = olTempItem.Attachments.Count
       
        Path_mail = Path & "\" & Time & "-" & int_mails_string & "__" & sender & "__" & Title
        MkDir Path_mail
        olTempItem.SaveAs Path_mail & "\" & Time & "-" & int_mails_string & "__" & sender & "__" & Title & ".txt", olTXT

            If int_Anhang > 0 Then
                           
            For j = 1 To int_Anhang
                olTempItem.Attachments.Item(j).SaveAsFile Path_mail & "\" _
                & olTempItem.Attachments.Item(j).FileName
                Next j
               
            End If
           
        Else
       
               
       
       
        int_nichtmails = int_nichtmails + 1
        int_Anhang = olTempItem.Attachments.Count
            If int_Anhang > 0 Then
           
                For j = 1 To int_Anhang
                olTempItem.Attachments.Item(j).SaveAsFile Path & "\" _
                & olTempItem.Attachments.Item(j).FileName
                Next j
               
            End If

       
    End If

    lCountOfFound = lCountOfFound + 1

Next

' Loop through and search each subfolder of the current folder.
For Each olNewFolder In CurrentFolder.Folders

n = Len(CurrentFolder)
    Do While Right(Path, n) <> CurrentFolder

        Do While Right(Path, 1) <> "\"
        Path = Left(Path, Len(Path) - 1)
        Loop
    Path = Left(Path, Len(Path) - 1)
    Loop
   
    If Right(Path, 1) <> "\" Then
        Path = Path & "\" & olNewFolder
        Else
        Path = Path & olNewFolder
    End If

MkDir Path

      If olNewFolder.Name <> "Deleted Items" Then
         ProcessFolder olNewFolder
      End If

   Next

End Sub

Sub ReinigeString(ByRef Title As String)
Dim Title_temp As String

Title_temp = Title
Title = ""
    Do While Len(Title_temp) <> 0
        If Left(Title_temp, 1) = ":" Then
            Title = Title & "-"
            ElseIf Left(Title_temp, 1) = "." Then
            Title = Title & "-"
            ElseIf Left(Title_temp, 1) = " " Then
            Title = Title & "_"
            ElseIf Left(Title_temp, 1) = "?" Then
            Title = Title & "-"
            ElseIf Left(Title_temp, 1) = "#" Then
            Title = Title & ""
            ElseIf Left(Title_temp, 1) = "," Then
            Title = Title & ""
            ElseIf Left(Title_temp, 1) = ";" Then
            Title = Title & ""
            Else
            Title = Title & Left(Title_temp, 1)
        End If
Title_temp = Right(Title_temp, Len(Title_temp) - 1)
Loop
End Sub

Sub ReinigeTime(ByRef Time As String)
Dim n As Integer

n = Len(Time)
Time = Left(Time, 2) & "-" & Left(Right(Time, n - 3), 2) & "-" & Left(Right(Time, n - 6), 4) & "_" _
& Left(Right(Time, n - 11), 2) & "-" & Left(Right(Time, n - 14), 2) & "-" & Left(Right(Time, n - 17), 2)
End Sub


Sub Ergaenze(ByRef int_mails_string As String)
Dim n As Integer
Dim i As Integer

n = Len(int_mails)
For i = 1 To 4 - n
int_mails_string = "0" & int_mails_string
Next i

End Sub

Private Sub btnsave_Click()
'speichern der Mail funktioniert
Dim myExplorer As Outlook.Explorer
Dim myfolder As Outlook.MAPIFolder
Dim strname As String
Dim myItem As MailItem
Dim olSelection As Selection
Dim strBackupPath As String

Set myExplorer = Application.ActiveExplorer
Set myfolder = myExplorer.CurrentFolder

If Not myfolder.DefaultItemType = olMailItem Then GoTo Ende

trBackupPath = GetFileDir

Set olSelection = myExplorer.Selection

For Each myItem In olSelection

strname = Format(myItem.ReceivedTime, "dd-mm-yyyy hh-nn-ss") _
& " " & IIf(Len(strBackupPath & myItem.Subject) > 255, _
Left(myItem.Subject, 255 - Len(strBackupPath)), myItem.Subject) '& ".txt"


'speichern als .txt datei
'.doc geht nicht
'myItem.SaveAs "D:\Outlook\" & CleanString(strname), HTML
myItem.SaveAs "D:\Outlook\" & CleanString(strname) & ".txt"


'olTXT
       
Next
Ende:

End Sub

Private Function CleanString(strData As String) As String

    'Replace invalid strings.
    strData = ReplaceChar(strData, "´", "_")
    strData = ReplaceChar(strData, "`", "_")
    strData = ReplaceChar(strData, "'", "_")
    strData = ReplaceChar(strData, "{", "(")
    strData = ReplaceChar(strData, "[", "(")
    strData = ReplaceChar(strData, "]", ")")
    strData = ReplaceChar(strData, "}", ")")
    strData = ReplaceChar(strData, "/", "-")
    strData = ReplaceChar(strData, "\", "-")
    strData = ReplaceChar(strData, ":", "")
    strData = ReplaceChar(strData, "ÿ", "")
    strData = ReplaceChar(strData, "þ", "")
    strData = ReplaceChar(strData, "", "")
   
    'Cut out invalid signs.

    strData = ReplaceChar(strData, "*", "_")
    strData = ReplaceChar(strData, "?", "")
    strData = ReplaceChar(strData, """", "_")
    strData = ReplaceChar(strData, "<", "")
    strData = ReplaceChar(strData, ">", "")
    strData = ReplaceChar(strData, "|", "")
   
    CleanString = Trim(strData)
   
End Function


Private Function ReplaceChar(strData As String, strBadChar As String, strGoodChar As String) As String

    Dim tmpChar     As String
    Dim tmpString   As String
    Dim i           As Long
   
    For i = 1 To Len(strData)
   
        tmpChar = Mid(strData, i, 1)
       
        If tmpChar = strBadChar Then
            tmpString = tmpString & strGoodChar
        Else
            tmpString = tmpString & tmpChar
        End If
       
    Next i
   
    ReplaceChar = Trim(tmpString)

End Function


Bitte ist ganz wichtig das ich weiter komme.
Bin nicht grad gut in VB
booN
Gast


Verfasst am:
23. Aug 2007, 10:31
Rufname:

AW: Outlook-Script zum Speichern einer Mail - AW: Outlook-Script zum Speichern einer Mail

Nach oben
       

Code:
'Quelle
'http://www.office-loesung.de/ftopic164482_0_0_asc.php

'Aufgabenstellung:
    'Wählen eines privaten Ordners in Outlook.
    'Mails filtern nach Typ(z.B. Netzwerkprobleme, Softwareprobleme[Parameter?])
    'sortierte Mails formatiert(z.B. Überschrift Fett) in Word einfügen

Sub btnds_Click()
On Error Resume Next

Dim strSearchString As String
Dim lCountOfFound As Long
Dim Path As String
Dim int_nichtmails
Dim int_mails

'Ordner auswählen
Set myNameSpace = Application.GetNamespace("MAPI")
Set objFolder = myNameSpace.PickFolder
    If objFolder Is Nothing Then
    MsgBox "Der Benutzer hat abgebrochen", vbInformation
    Else
    objFolder.Display
    End If


End Sub
Sub WalkFolders()

On Error Resume Next

Dim olApp As Outlook.Application
Dim olSession As Outlook.NameSpace
Dim olStartFolder As Outlook.MAPIFolder
Dim strPrompt As String
Dim datentyp As String

lCountOfFound = 0
Set olApp = New Outlook.Application
Set olSession = olApp.GetNamespace("MAPI")

'olApp.DisplayAlerts = False
Set olStartFolder = olApp.ActiveExplorer.CurrentFolder

Path = "D:\Outlook\" & olStartFolder
MkDir Path
ProcessFolder olStartFolder
'olApp.DisplayAlerts = True
MsgBox CStr(lCountOfFound) & " Nachrichten sind kopiert worden."



End Sub

Sub ProcessFolder(CurrentFolder As Outlook.MAPIFolder)

Dim i As Long
Dim olNewFolder As Outlook.MAPIFolder
Dim olTempItem As Object
Dim Time As String
Dim Time_temp As String
Dim n As Integer
Dim noch_kein_anhang As Boolean
Dim Title As String
Dim sender As String
Dim int_mails_nummer As String
Dim int_mails_string As String

int_nichtmails = 0
int_mails = 0

For i = CurrentFolder.Items.Count To 1 Step -1

    Set olTempItem = CurrentFolder.Items(i)
       

   
    If TypeOf olTempItem Is MailItem Then
   
        Title = Left(olTempItem.Subject, 20)
        ReinigeString Title
        Time = Format(olTempItem.ReceivedTime, "yyyy-mm-dd_hh-mm-ss")
        sender = olTempItem.SenderName
        ReinigeString sender
        'ReinigeTime Time
        int_mails = int_mails + 1
        int_mails_string = CStr(int_mails)
        Ergaenze int_mails_string
       
        int_Anhang = olTempItem.Attachments.Count
       
        Path_mail = Path & "\" & Time & "-" & int_mails_string & "__" & sender & "__" & Title
        MkDir Path_mail
        olTempItem.SaveAs Path_mail & "\" & Time & "-" & int_mails_string & "__" & sender & "__" & Title & ".txt", olTXT

            If int_Anhang > 0 Then
                           
            For j = 1 To int_Anhang
                olTempItem.Attachments.Item(j).SaveAsFile Path_mail & "\" _
                & olTempItem.Attachments.Item(j).FileName
                Next j
               
            End If
           
        Else
       
        int_nichtmails = int_nichtmails + 1
        int_Anhang = olTempItem.Attachments.Count
            If int_Anhang > 0 Then
           
                For j = 1 To int_Anhang
                olTempItem.Attachments.Item(j).SaveAsFile Path & "\" _
                & olTempItem.Attachments.Item(j).FileName
                Next j
               
            End If

       
    End If

lCountOfFound = lCountOfFound + 1

Next

' Loop through and search each subfolder of the current folder.
For Each olNewFolder In CurrentFolder.Folders

n = Len(CurrentFolder)
Do While Right(Path, n) <> CurrentFolder

Do While Right(Path, 1) <> "\"
Path = Left(Path, Len(Path) - 1)
Loop
Path = Left(Path, Len(Path) - 1)
Loop
If Right(Path, 1) <> "\" Then
Path = Path & "\" & olNewFolder
Else
Path = Path & olNewFolder
End If

MkDir Path

      If olNewFolder.Name <> "Deleted Items" Then
         ProcessFolder olNewFolder
      End If

   Next

End Sub

Sub ReinigeString(ByRef Title As String)
Dim Title_temp As String

Title_temp = Title
Title = ""
Do While Len(Title_temp) <> 0
If Left(Title_temp, 1) = ":" Then
Title = Title & "-"
ElseIf Left(Title_temp, 1) = "." Then
Title = Title & "-"
ElseIf Left(Title_temp, 1) = " " Then
Title = Title & "_"
ElseIf Left(Title_temp, 1) = "?" Then
Title = Title & "-"
ElseIf Left(Title_temp, 1) = "#" Then
Title = Title & ""
ElseIf Left(Title_temp, 1) = "," Then
Title = Title & ""
ElseIf Left(Title_temp, 1) = ";" Then
Title = Title & ""
Else
Title = Title & Left(Title_temp, 1)
End If
Title_temp = Right(Title_temp, Len(Title_temp) - 1)
Loop
End Sub

Sub ReinigeTime(ByRef Time As String)
Dim n As Integer

n = Len(Time)
Time = Left(Time, 2) & "-" & Left(Right(Time, n - 3), 2) & "-" & Left(Right(Time, n - 6), 4) & "_" _
& Left(Right(Time, n - 11), 2) & "-" & Left(Right(Time, n - 14), 2) & "-" & Left(Right(Time, n - 17), 2)
End Sub


Sub Ergaenze(ByRef int_mails_string As String)
Dim n As Integer
Dim i As Integer

n = Len(int_mails)

For i = 1 To 4 - n
int_mails_string = "0" & int_mails_string
Next i

End Sub

Sub wordopen()

On Error Resume Next

Dim objWordDoc As DocumentItem
Dim wdApp As word.Application
Dim wdDoc As word.Document
Dim objFolder As MAPIFolder

Set objapp = CreateObject("word.Application")
objapp.Visible = True
objapp.ActiveWindow.envelopevisible = True

Set objFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)

Set objWordDoc = objFolder.Items.Add("IPM.Document.Word.Document.8")

Set wdApp = wdApp.Documents.Add
With wdApp.Selection
.Typetext "TEST"
.Typeparagraph
.Typetext "TEST!"
End With

'gettempdir gibt führendes \ zurück

strPath = gettempdir() & "Test.doc"
wdDoc.SaveAs strPath
wdDoc.Close

'das DocumentItem mit der Anlage wddoc speichern

With objWordDoc
.Subject = "Testing"
.Attachments.Add (strPath)
.Save

End With

'wddoc im temporären Ordner löschen
Kill strPath

End Sub


'sortieren und filtern
'umändern um Zugriff auf den privaten Ordner zu haben
Sub SortAFiltererdCollection_click()


'On Error Resume Next

'olFolderContacts = 10
'Set MyNameSpace = Application.GetNameSpace("MAPI")
'Set MyFolder = MyNameSpace.getdefaultfolder(olfoldercontacts)
'Set MyItems = MyFolder.items
'zuerst filtern dann sortieren
'set myFilter = MyItems.Restrict("[E-Mail] <> ''"
'nach Nachnamen in absteigender Folge sortieren
'MyFilter.sort "[Nachname]", True
'das erste gefilterte Element anzeigen
'MyFilter.Item(1).Display

End Sub

Sub FindAnItemInAFolder_click()

On Error Resume Next
Set myNameSpace = Application.GetNamespace("MAPI")
Set bldfolder = myNameSpace.Folders("Persönliche Ordner")
Set quickfolder = bldfolder.Folders("vbatest")
Set productideasfolder = quickfolder.Folders("vbatest")
Set myItem = productideasfolder.Items.Find("[Filter) = ''")
myItem.Display


End Sub



Private Sub btnsave_Click()
'speichern der Mail funktioniert
Dim myExplorer As Outlook.Explorer
Dim myfolder As Outlook.MAPIFolder
Dim strname As String
Dim myItem As MailItem
Dim olSelection As Selection
Dim strBackupPath As String

Set myExplorer = Application.ActiveExplorer
Set myfolder = myExplorer.CurrentFolder

If Not myfolder.DefaultItemType = olMailItem Then GoTo Ende

trBackupPath = GetFileDir

Set olSelection = myExplorer.Selection

For Each myItem In olSelection

strname = Format(myItem.ReceivedTime, "dd-mm-yyyy hh-nn-ss") _
& " " & IIf(Len(strBackupPath & myItem.Subject) > 255, _
Left(myItem.Subject, 255 - Len(strBackupPath)), myItem.Subject) '& ".txt"


'speichern als .txt datei
'.doc geht nicht
'myItem.SaveAs "D:\Outlook\" & CleanString(strname), HTML
myItem.SaveAs "D:\Outlook\" & CleanString(strname) & ".txt"


'olTXT
       
Next
Ende:

End Sub

Private Function CleanString(strData As String) As String

    'Replace invalid strings.
    strData = ReplaceChar(strData, "´", "_")
    strData = ReplaceChar(strData, "`", "_")
    strData = ReplaceChar(strData, "'", "_")
    strData = ReplaceChar(strData, "{", "(")
    strData = ReplaceChar(strData, "[", "(")
    strData = ReplaceChar(strData, "]", ")")
    strData = ReplaceChar(strData, "}", ")")
    strData = ReplaceChar(strData, "/", "-")
    strData = ReplaceChar(strData, "\", "-")
    strData = ReplaceChar(strData, ":", "")
    strData = ReplaceChar(strData, "ÿ", "")
    strData = ReplaceChar(strData, "þ", "")
    strData = ReplaceChar(strData, "", "")
   
    'Cut out invalid signs.

    strData = ReplaceChar(strData, "*", "_")
    strData = ReplaceChar(strData, "?", "")
    strData = ReplaceChar(strData, """", "_")
    strData = ReplaceChar(strData, "<", "")
    strData = ReplaceChar(strData, ">", "")
    strData = ReplaceChar(strData, "|", "")
   
    CleanString = Trim(strData)
   
End Function


Private Function ReplaceChar(strData As String, strBadChar As String, strGoodChar As String) As String

    Dim tmpChar     As String
    Dim tmpString   As String
    Dim i           As Long
   
    For i = 1 To Len(strData)
   
        tmpChar = Mid(strData, i, 1)
       
        If tmpChar = strBadChar Then
            tmpString = tmpString & strGoodChar
        Else
            tmpString = tmpString & tmpChar
        End If
       
    Next i
   
    ReplaceChar = Trim(tmpString)

End Function



hab paar sachen vergessen
Gast



Verfasst am:
27. Aug 2007, 07:05
Rufname:

AW: Outlook-Script zum Speichern einer Mail - AW: Outlook-Script zum Speichern einer Mail

Nach oben
       

ich kann dir da ned helfen sry
booN
Gast


Verfasst am:
29. Aug 2007, 09:48
Rufname:


AW: Outlook-Script zum Speichern einer Mail - AW: Outlook-Script zum Speichern einer Mail

Nach oben
       

habs jetzt geschafft
eine frage hab ich noch
wie kann ich wenn ich in eine textbox was eingebe mit nem button die suche starten?

Code:
Set olApp = New Outlook.Application
Set olSession = olApp.GetNamespace("MAPI")
           
'olApp.DisplayAlerts = False
Set olStartFolder = olApp.ActiveExplorer.CurrentFolder
Set myItems = olStartFolder.Items

Set itemssubject = myItems.Subject(1)
For Each myItem In myItems
    TextSubject = myItem.Subject
    textBody = myItem.Body
Next
Neues Thema eröffnen   Neue Antwort erstellen Alle Zeiten sind
GMT + 1 Stunde

Gehe zu Seite Zurück  1, 2, 3, 4, 5, 6, 7, 8, 9  Weiter
Diese Seite Freunden empfehlen

Seite 3 von 9
Gehe zu:  
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen

Verwandte Themen
Forum / Themen   Antworten   Autor   Aufrufe   Letzter Beitrag 
Keine neuen Beiträge Outlook Mail: Mail Absender falsch 8 Jürgen Eitler 3343 09. Sep 2005, 13:52
Gast Mail Absender falsch
Keine neuen Beiträge Outlook Mail: Outlook 2003 erste Mail wird nicht verschickt 6 Gast 2734 25. Aug 2005, 13:00
Krug Outlook 2003 erste Mail wird nicht verschickt
Keine neuen Beiträge Outlook Mail: Automatische Antworts mail (Urlaubsfunktion) 1 player-1 2825 21. Jul 2005, 20:04
wolf-it Automatische Antworts mail (Urlaubsfunktion)
Keine neuen Beiträge Outlook Mail: Outlook 2003 / Mail Weiterleiten / ich will es merken 4 Iceman008 1595 14. Jul 2005, 10:50
kraemer Outlook 2003 / Mail Weiterleiten / ich will es merken
Keine neuen Beiträge Outlook Mail: Kann man jede Adresse einer eingehenden Mail aut. speichern? 4 landau666 1425 13. Jul 2005, 17:21
Christi@n Kann man jede Adresse einer eingehenden Mail aut. speichern?
Keine neuen Beiträge Outlook Mail: Arbeitsspeicherprob. beim Anlagenhinzufügen einer neuen Mail 4 Tischler 995 11. Jul 2005, 15:19
Christi@n Arbeitsspeicherprob. beim Anlagenhinzufügen einer neuen Mail
Keine neuen Beiträge Outlook Mail: Abwesenheitsassistent, Mails weiterleiten zu ext. Mail 1 nicksan 1929 22. Feb 2005, 11:45
kraemer Abwesenheitsassistent, Mails weiterleiten zu ext. Mail
Keine neuen Beiträge Outlook Mail: Adressauswahl bei neuem Mail gestört 10 swissbird 912 19. Feb 2005, 15:49
macdeal Adressauswahl bei neuem Mail gestört
Keine neuen Beiträge Outlook Mail: Standard Dateiendung bei Speichern von E-Mails ändern 5 S.Thielen 4414 02. Feb 2005, 12:04
kraemer Standard Dateiendung bei Speichern von E-Mails ändern
Keine neuen Beiträge Outlook Mail: Mails in Extra Ordner speichern. 4 Jason 2540 30. Jan 2005, 14:51
Christi@n Mails in Extra Ordner speichern.
Keine neuen Beiträge Outlook Mail: Wie schreibe ich eine html - Mail mit outlook 2 Mike020174 13305 21. Jan 2005, 02:35
Gast Wie schreibe ich eine html - Mail mit outlook
Keine neuen Beiträge Outlook Mail: manuell mail verschicken 2 redrogue 801 04. Jan 2005, 19:13
redrogue manuell mail verschicken
 

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: Microsoft Excel-Formeln