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 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
steifhahn
Im Profil kannst Du frei den Rang ändern


Verfasst am:
28. Aug 2006, 09:55
Rufname:

Outlook-Script zum Speichern einer Mail - Outlook-Script zum Speichern einer Mail

Nach oben
       

Hallo!

Ich möchte folgendes erreichen:

Mitarbeiter sollen projektbezogenen Schriftverkehr in den Projektverzeichnissen im Ordner schriftverkehr ablegen.
Da das Format kompatibel sein soll, sollten Mails im Textformat als txt-Datei und Mails im HTML-Format als htm-Datei gespeichert werden.
Die Anlagen sollen in einem Unterordner, der so heisst wie die Maildatei, gespeichert werden.

Der Benutzer soll das Ablageverzeichnis frei wählen können.
Startverzeichnis ist \\*
Der voreingestellte Dateiname soll der Betreff der E-Mail sein. Er kann auch vom Benutzer geändert werden.
(Normaler Speichern-unter Dialog)

Die Funktion soll im Outlook über Menü und Button aufrufbar sein.

Soweit so gut.

Dank der Suchfunktion, konnte ich schon einen Button und und die Menüleiste erstellen!

Ich habe auch einige Beispiele zum Speichern der Mails gefunden!

Leider weiß ich nicht wie ich den Bogen zu dem Button und der Menüleiste spannen soll!

Also wenn ich auf den Button klicke, soll die Mail gespeichert werden:

Bitte helft mir!

Mein Code bis jetzt:
Code:
 Option Explicit
Private WithEvents Button As Office.CommandBarButton

'Button einbinden

Private Sub Application_Startup()
  Dim oExplorer As Outlook.Explorer

  ' Commandbar im aktuellen Explorer mit einem Button _
    erstellen und der Verweis speichern
  Set oExplorer = Application.ActiveExplorer
  Set Button = CreateCommandBarButton(oExplorer.CommandBars)
End Sub

Private Sub Button_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  ' Aufruf, wenn der Anwender auf den Button klickt.
 
End Sub

Private Function CreateCommandBarButton(oBars As Office.CommandBars) As Office.CommandBarButton
  On Error Resume Next
  Dim oMenu As Office.CommandBar
  Dim oBtn As Office.CommandBarButton
  Const BAR_NAME As String = "YourCommandBarName"
  Const CMD_NAME As String = "Schriftverkehr speichern"

  Set oMenu = oBars(BAR_NAME)
  If oMenu Is Nothing Then
    Set oMenu = oBars.Add(BAR_NAME, msoBarTop, , True)
    Set oBtn = oMenu.Controls.Add(msoControlButton, , CMD_NAME, , True)
    oBtn.Caption = CMD_NAME
    oBtn.Tag = CMD_NAME

  Else
    Set oBtn = oMenu.FindControl(, , CMD_NAME)
    If oBtn Is Nothing Then
      Set oBtn = oMenu.Controls.Add(msoControlButton, , CMD_NAME, , True)
    End If
  End If

  oMenu.Visible = True
  Set CreateCommandBarButton = oBtn
End Function

'Menüleiste einbinden

Public Sub CreateMenu()
Dim cbar As CommandBar
Dim ctlcbar  As CommandBarControl
Dim ctlNew  As CommandBarControl
' Verweis auf die Menüleiste setzen
Set cbar = ActiveExplorer.CommandBars("Menu Bar")
On Error Resume Next
Set ctlcbar = cbar.Controls("&Schriftverkehr")
If ctlcbar Is Nothing Then
  Set ctlcbar = cbar.Controls.Add(Type:=msoControlPopup, ID:=1)
End If
With ctlcbar
  .Caption = "&Schriftverkehr"
End With
' Prüfen, ob Eintrag bereits vorhanden ist.
Set ctlNew = ctlcbar.Controls("Schriftverkehr")
' oder per FindControl suchen
On Error GoTo 0
If ctlNew Is Nothing Then
  Set ctlNew = cbar.FindControl(Type:=msoControlButton, Tag:="Speichern unter", ID:=1, Recursive:=True)
End If
If ctlNew Is Nothing Then
  Set ctlNew = ctlcbar.Controls.Add(Type:=msoControlButton, ID:=1)
End If
With ctlNew
  .BeginGroup = True ' Trennt den Eintrag ab
  ' mit FaceId kann ein integrietes Symbol verwendet werden
  .FaceId = 21
  .Caption = "Speichern unter"
  ' Vollständiger Verweis auf das Makro
  .OnAction = "Projekt1.dialog.MeinMakro"
  ' optional z.B. zur Identifizierung
  .Tag = "NeuerEintrag"
  .TooltipText = "Hier steht der Tooltipp"
End With
' Eintrag anzeigen
cbar.Visible = True
End Sub

Andreas.Fischer
Outlook - Moderator


Verfasst am:
28. Aug 2006, 10:28
Rufname:
Wohnort: Berlin


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

Nach oben
       

Hallo,

Rufe in Private Sub Button_Click die Routine zum Speichern auf. Das sollte ungefähr so aussehen:
Code:
Private Sub Button_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
Mailspeichern
End Sub

Das Mailspeichern bezeichnet den Namen der Subroutine.

_________________
Gruß Andreas

Das besondere Erleben.
steifhahn
Im Profil kannst Du frei den Rang ändern


Verfasst am:
28. Aug 2006, 13:19
Rufname:

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

Nach oben
       

Habe es jetzt so gelöst, es gibt aber immer noch fehler:

Wenn keine Nachricht ausgewählt ist, kommt schon mal ein passender Hinweis.

Wenn eine NAchricht ausgewählt wurde kommt folgende Fehlermeldung:

Fehler beim Kompilieren Sub oder Function nicht definiert.
ret = fkt_FileSaveAs(dateiname)

Habe den Code von folgender HP:
http://www.chf-online.de/ol/olvbamailspeichern.htm

Code:

Option Explicit
Private WithEvents Button As Office.CommandBarButton

Private Sub Application_Startup()
  Dim oExplorer As Outlook.Explorer

  ' Commandbar im aktuellen Explorer mit einem Button _
    erstellen und der Verweis speichern
  Set oExplorer = Application.ActiveExplorer
  Set Button = CreateCommandBarButton(oExplorer.CommandBars)
End Sub

Private Sub Button_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  ' Aufruf, wenn der Anwender auf den Button klickt.
 
 ' Definition der Variablen
Dim myOLApp
Dim myInspector As Inspector
Dim myItem As MailItem
Dim myNameSpace As NameSpace
Dim myfolder As MAPIFolder
Dim myOlSel As Outlook.Selection
Dim myOlExp As Outlook.Explorer
Dim x As Integer
' Mail-Eingangsordner festlegen
Set myNameSpace = Outlook.GetNamespace("MAPI")
Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox)
' Markierter Eintrag
On Error Resume Next
' Ansicht auf Eingangsordner
Set Application.ActiveExplorer.CurrentFolder = _
    myNameSpace.GetDefaultFolder(olFolderInbox)
Set myOlExp = Outlook.ActiveExplorer
' Markierte Mails zuweisen
Set myOlSel = myOlExp.Selection
' Alle markierten Mails durchlaufen
For x = 1 To myOlSel.Count
  Set myItem = myOlSel.Item(x)
  If myItem Is Nothing Then
    MsgBox "Nichts markiert"
    Exit For
  End If
  On Error GoTo 0
    ' Exportieren
    fkt_Export myItem
  Next x
' Aufräumen
Set myItem = Nothing
Set myOlExp = Nothing
Set myOlSel = Nothing
Set myfolder = Nothing
Set myNameSpace = Nothing

End Sub

Function fkt_Export(ByRef myItem As MailItem)
Dim datum, Pfad, absender, Betreff, dateiname, antwort, Zeit
Dim myuser As Object
Dim ret As String
Dim antw As String
Dim sDate As Date
If myItem Is Nothing Then Exit Function
datum = Format(myItem.SentOn, "dd.mm.yyyy")
' Festlegung des Datumsformats für den Dateinamen
Zeit = Format(myItem.SentOn, "hh-mm-ss")
' Festlegung des Zeitformats für den Dateinamen
absender = myItem.SenderName
' Auslesen der Empfangsdaten
sDate = myItem.ReceivedTime
Set myuser = Application.GetNamespace("MAPI").CurrentUser
If absender = "" Then
  ' Wenn keine Absendername vorhanden, dann Benutzernamen verwenden
  absender = myuser
  datum = Format(Date, "dd.mm.yyyy")
  Zeit = Format(Time, "hh-mm-ss")
End If
Betreff = myItem.Subject
Betreff = Replace(Betreff, ":", "_")
Betreff = Replace(Betreff, Chr$(34), "_")
Betreff = Replace(Betreff, "<_>", "_")
Betreff = Replace(Betreff, "?", "_")
Betreff = Replace(Betreff, "/", "_")
Betreff = Replace(Betreff, "\", "_")
Betreff = Replace(Betreff, "*", "_")
dateiname = Pfad & absender & " - " & Betreff & " - " & datum & " " & Zeit
ret = fkt_FileSaveAs(dateiname)
If ret <> "" Then
myItem.SaveAs ret, olMSG
antw = fkt_setTime(ret, sDate)
End If
 


Private Function CreateCommandBarButton(oBars As Office.CommandBars) As Office.CommandBarButton
  On Error Resume Next
  Dim oMenu As Office.CommandBar
  Dim oBtn As Office.CommandBarButton
  Const BAR_NAME As String = "YourCommandBarName"
  Const CMD_NAME As String = "Mail speichern"

  Set oMenu = oBars(BAR_NAME)
  If oMenu Is Nothing Then
    Set oMenu = oBars.Add(BAR_NAME, msoBarTop, , True)
    Set oBtn = oMenu.Controls.Add(msoControlButton, , CMD_NAME, , True)
    oBtn.Caption = CMD_NAME
    oBtn.Tag = CMD_NAME

  Else
    Set oBtn = oMenu.FindControl(, , CMD_NAME)
    If oBtn Is Nothing Then
      Set oBtn = oMenu.Controls.Add(msoControlButton, , CMD_NAME, , True)
    End If
  End If

  oMenu.Visible = True
  Set CreateCommandBarButton = oBtn
End Function

Andreas.Fischer
Outlook - Moderator


Verfasst am:
29. Aug 2006, 07:35
Rufname:
Wohnort: Berlin

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

Nach oben
       

Hallo,

Du musst noch die beiden Funktionen von der Seite in dein Script einfügen:
Function fkt_FileSaveAs
Function fkt_setTime

_________________
Gruß Andreas

Das besondere Erleben.
steifhahn
Im Profil kannst Du frei den Rang ändern


Verfasst am:
29. Aug 2006, 08:18
Rufname:


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

Nach oben
       

und wo müssen die hin???

egal an welcher stelle ich die einbaue, es kommt immer eine fehlermeldung.

Jetzt hab ich alles "Diese Outlook Sitzung" geschrieben

Hab aber gelesen das ne public-anweisung auf Modul-ebene angewandt werden muss!
Andreas.Fischer
Outlook - Moderator


Verfasst am:
29. Aug 2006, 14:25
Rufname:
Wohnort: Berlin

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

Nach oben
       

Hallo,

Ich würde alles ain ein Modul schreiben, ausser den Teil, welchen du hier als erstes gepostet hattest. Den lässt du in DieseOutlookSitzung.
In die Subroutine Button_Click schreibst du nur noch denn Namen der Subroutine vom SpeichernCode.

Wenn nun noch Fehler auftreten, teile uns die mit und an welcher stelle des Codes dieser auftritt.

_________________
Gruß Andreas

Das besondere Erleben.
steifhahn
Im Profil kannst Du frei den Rang ändern


Verfasst am:
29. Aug 2006, 15:00
Rufname:

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

Nach oben
       

Erstmal danke für deine Hilfe!!!!!!!

Also mein Code in "DieseOutlookSitzung" sieht momentan so aus:
Code:

Option Explicit

Private WithEvents Button As Office.CommandBarButton

Private Sub Application_Startup()
  Dim oExplorer As Outlook.Explorer

  ' Commandbar im aktuellen Explorer mit einem Button erstellen und den Verweis speichern
  Set oExplorer = Application.ActiveExplorer
  Set Button = CreateCommandBarButton(oExplorer.CommandBars)
End Sub

Private Sub Button_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  ' Aufruf, wenn der Anwender auf den Button klickt.
 
 ' Definition der Variablen
Dim myOLApp
Dim myInspector As Inspector
Dim myItem As MailItem
Dim myNameSpace As NameSpace
Dim myfolder As MAPIFolder
Dim myOlSel As Outlook.Selection
Dim myOlExp As Outlook.Explorer
Dim x As Integer
' Mail-Eingangsordner festlegen
Set myNameSpace = Outlook.GetNamespace("MAPI")
Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox)
' Markierter Eintrag
On Error Resume Next
' Ansicht auf Eingangsordner
Set Application.ActiveExplorer.CurrentFolder = _
    myNameSpace.GetDefaultFolder(olFolderInbox)
Set myOlExp = Outlook.ActiveExplorer
' Markierte Mails zuweisen
Set myOlSel = myOlExp.Selection
' Alle markierten Mails durchlaufen
For x = 1 To myOlSel.Count
  Set myItem = myOlSel.Item(x)
  If myItem Is Nothing Then
    MsgBox "Nichts markiert"
    Exit For
  End If
  On Error GoTo 0
    ' Exportieren
    fkt_Export myItem
  Next x
' Aufräumen
Set myItem = Nothing
Set myOlExp = Nothing
Set myOlSel = Nothing
Set myfolder = Nothing
Set myNameSpace = Nothing

End Sub


 
Private Function CreateCommandBarButton(oBars As Office.CommandBars) As Office.CommandBarButton
  On Error Resume Next
  Dim oMenu As Office.CommandBar
  Dim oBtn As Office.CommandBarButton
  Const BAR_NAME As String = "YourCommandBarName"
  Const CMD_NAME As String = "Mail speichern"

  Set oMenu = oBars(BAR_NAME)
  If oMenu Is Nothing Then
    Set oMenu = oBars.Add(BAR_NAME, msoBarTop, , True)
    Set oBtn = oMenu.Controls.Add(msoControlButton, , CMD_NAME, , True)
    oBtn.Caption = CMD_NAME
    oBtn.Tag = CMD_NAME

  Else
    Set oBtn = oMenu.FindControl(, , CMD_NAME)
    If oBtn Is Nothing Then
      Set oBtn = oMenu.Controls.Add(msoControlButton, , CMD_NAME, , True)
    End If
  End If

  oMenu.Visible = True
  Set CreateCommandBarButton = oBtn
End Function


und im "Modul1" so:

Code:

Public Declare Function GetSaveFileName Lib "comdlg32.dll" _
  Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

Public Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

Function fkt_Export(ByRef myItem As MailItem)
Dim datum, Pfad, absender, Betreff, dateiname, antwort, Zeit
Dim myuser As Object
Dim ret As String
Dim antw As String
Dim sDate As Date
If myItem Is Nothing Then Exit Function
datum = Format(myItem.SentOn, "dd.mm.yyyy")
' Festlegung des Datumsformats für den Dateinamen
Zeit = Format(myItem.SentOn, "hh-mm-ss")
' Festlegung des Zeitformats für den Dateinamen
absender = myItem.SenderName
' Auslesen der Empfangsdaten
sDate = myItem.ReceivedTime
Set myuser = Application.GetNamespace("MAPI").CurrentUser
If absender = "" Then
  ' Wenn keine Absendername vorhanden, dann Benutzernamen verwenden
  absender = myuser
  datum = Format(Date, "dd.mm.yyyy")
  Zeit = Format(Time, "hh-mm-ss")
End If
Betreff = myItem.Subject
Betreff = Replace(Betreff, ":", "_")
Betreff = Replace(Betreff, Chr$(34), "_")
Betreff = Replace(Betreff, "<_>", "_")
Betreff = Replace(Betreff, "?", "_")
Betreff = Replace(Betreff, "/", "_")
Betreff = Replace(Betreff, "\", "_")
Betreff = Replace(Betreff, "*", "_")
dateiname = Pfad & absender & " - " & Betreff & " - " & datum & " " & Zeit
ret = fkt_FileSaveAs(dateiname)

'If ret <> "" Then
'myItem.SaveAs ret, olMSG
'antw = fkt_setTime(ret, sDate)
'End If


Function fkt_FileSaveAs(sModul, sType) As String
Dim sFilters As String
Dim intError As Integer
' Formattyp-Filter festlegen
sFilters = "Formulardateien(*.frm)" & vbNullChar & "*.frm" & vbNullChar & _
           "Basic-Dateien (*.bas)" & vbNullChar & "*.bas" & vbNullChar & _
           "Klassendateien (*.cls)" & vbNullChar & "*.cls" & vbNullChar & _
           "Alle Dateien" & vbNullChar & "*.*" & vbNullChar & vbNullChar
With OFName
  'Setzt die Größe der OPENFILENAME Struktur
  .lStructSize = Len(OFName)
  'Der Window Handle ist bei VBA fast immer &O0
  .hwndOwner = &O0
  ' Formattyp-Filter setzen
  .lpstrFilter = sFilters
  ' Auswerten des Dateityps zur Auswahl des Filers
  Select Case sType
  Case ".frm"
  .nFilterIndex = 1
  Case ".bas"
  .nFilterIndex = 2
  Case ".cls"
  .nFilterIndex = 3
  Case Else
  .nFilterIndex = 4
  End Select
  ' Buffer für Dateinamen erzeugen
  .lpstrFile = sModul & Space$(1024) & vbNullChar & vbNullChar
  ' Maximale Anzahl der Dateinamen-Zeichen
  .nMaxFile = Len(.lpstrFile)
  ' Buffer für Titel erzeugen
  .lpstrFileTitle = Space$(254)
  ' Maximale Anzahl der Titel-Zeichen
  .nMaxFileTitle = 255
  ' Anfangsverzeichnis vorgeben
  .lpstrInitialDir = "c:\temp"
  .lpstrDefExt = sType & vbNullChar & vbNullChar
  ' Titel des Dialogfester festlegen
  .lpstrTitle = "Modul exportieren"
  ' Flags zum Festlegen eines bestimmten Verhaltens,
  ' OFN_LONGNAMES = lange Dateinamen verwenden
  ' OFN_OVERWRITEPROMPT = Abfrage vorm Überschreiben
  .flags = OFN_LONGNAMES Or OFN_OVERWRITEPROMPT
End With
' API aufrufen und evtl. Fehler abfangen
intError = GetSaveFileName(OFName)
If intError <> 0 Then
  fkt_FileSaveAs = Left(OFName.lpstrFile, InStr(1, OFName.lpstrFile, Chr(0)) - 1)
ElseIf intError = 0 Then
  ' Abbruch durch Benutzer oder Fehler
End If
End Function


Bei klick auf den Button mit markierter mail kommt folgende Fehlermeldung:

Fehler beim Kompilieren:
Argument ist nicht optional

"Zeile 58 fkt_FileSaveAs" ist dabei grau unterlegt


Ich hoffe du kannst mir weiterhelfen!!

DANKE
Andreas.Fischer
Outlook - Moderator


Verfasst am:
30. Aug 2006, 07:11
Rufname:
Wohnort: Berlin

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

Nach oben
       

Hallo,

Also ich würde das ganze über den Haufen werfen. Ich habe das ganze mal getestet und da kommen Fehlermeldungen über Fehlermeldung.
Es sind z.B. Sprünge in Funktionen, die der Ersteller dieser Scripte nicht angegeben hat.

Ich hab mich mal rangesetzt und ein paar Codeschnipsel zu einem zusammengefasst.

DieseOutlookSitzung
Code:
Option Explicit
Private WithEvents Button As Office.CommandBarButton

'Button einbinden

Private Sub Application_Startup()
  Dim oExplorer As Outlook.Explorer

  ' Commandbar im aktuellen Explorer mit einem Button _
    erstellen und der Verweis speichern
  Set oExplorer = Application.ActiveExplorer
  Set Button = CreateCommandBarButton(oExplorer.CommandBars)
End Sub

Private Sub Button_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  SpeichernalsMSG 
End Sub

Private Function CreateCommandBarButton(oBars As Office.CommandBars) As Office.CommandBarButton
  On Error Resume Next
  Dim oMenu As Office.CommandBar
  Dim oBtn As Office.CommandBarButton
  Const BAR_NAME As String = "YourCommandBarName"
  Const CMD_NAME As String = "Schriftverkehr speichern"

  Set oMenu = oBars(BAR_NAME)
  If oMenu Is Nothing Then
    Set oMenu = oBars.Add(BAR_NAME, msoBarTop, , True)
    Set oBtn = oMenu.Controls.Add(msoControlButton, , CMD_NAME, , True)
    oBtn.Caption = CMD_NAME
    oBtn.Tag = CMD_NAME

  Else
    Set oBtn = oMenu.FindControl(, , CMD_NAME)
    If oBtn Is Nothing Then
      Set oBtn = oMenu.Controls.Add(msoControlButton, , CMD_NAME, , True)
    End If
  End If

  oMenu.Visible = True
  Set CreateCommandBarButton = oBtn
End Function

'Menüleiste einbinden

Public Sub CreateMenu()
Dim cbar As CommandBar
Dim ctlcbar  As CommandBarControl
Dim ctlNew  As CommandBarControl
' Verweis auf die Menüleiste setzen
Set cbar = ActiveExplorer.CommandBars("Menu Bar")
On Error Resume Next
Set ctlcbar = cbar.Controls("&Schriftverkehr")
If ctlcbar Is Nothing Then
  Set ctlcbar = cbar.Controls.Add(Type:=msoControlPopup, ID:=1)
End If
With ctlcbar
  .Caption = "&Schriftverkehr"
End With
' Prüfen, ob Eintrag bereits vorhanden ist.
Set ctlNew = ctlcbar.Controls("Schriftverkehr")
' oder per FindControl suchen
On Error GoTo 0
If ctlNew Is Nothing Then
  Set ctlNew = cbar.FindControl(Type:=msoControlButton, Tag:="Speichern unter", ID:=1, Recursive:=True)
End If
If ctlNew Is Nothing Then
  Set ctlNew = ctlcbar.Controls.Add(Type:=msoControlButton, ID:=1)
End If
With ctlNew
  .BeginGroup = True ' Trennt den Eintrag ab
  ' mit FaceId kann ein integrietes Symbol verwendet werden
  .FaceId = 21
  .Caption = "Speichern unter"
  ' Vollständiger Verweis auf das Makro
  .OnAction = "Projekt1.dialog.MeinMakro"
  ' optional z.B. zur Identifizierung
  .Tag = "NeuerEintrag"
  .TooltipText = "Hier steht der Tooltipp"
End With
' Eintrag anzeigen
cbar.Visible = True
End Sub


Modul
Code:
Sub SpeichernalsMSG()

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

strBackupPath = 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) & ".msg"

myItem.SaveAs strBackupPath & "\" & CleanString(strname), olMSG
       
Next
Ende:

End Sub

Private Function CleanString(strData As String) As String
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, """", "_")
strData = ReplaceChar(strData, "<strData> 0) Then
        OriginalStr = Left$(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
    End If
    StripNulls = OriginalStr
End Function


Ich hoffe der Code hilft dir eher weiter.

_________________
Gruß Andreas

Das besondere Erleben.
steifhahn
Im Profil kannst Du frei den Rang ändern


Verfasst am:
30. Aug 2006, 08:05
Rufname:

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

Nach oben
       

OK ok super...

Ich hab jetzt danke deiner Hilfe und nem anderen Beitrag was zusammengebastelt was erstmal funktioniert!!!!!

DANKE

Hier mein aktueller Code im Modul1:

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\" & CleanString(strname), 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



Gut jetzt speichert das Script die Mails als Text oder Html in dem angegebenen Pfad!

Nun meine neuen Probleme:
1. Wie kann man erreichen, dass man sich den Speicherort selbst aussucht?????? Da dieser nicht immer gleich ist.
2. Wie kann man erreichen, dass die Attachments in einen Unterordner gespeichert werden??????


Ich hoffe jemand hat noch eine Antwort auf Lager!

DANKE @Andreas.Fischer
Andreas.Fischer
Outlook - Moderator


Verfasst am:
30. Aug 2006, 10:32
Rufname:
Wohnort: Berlin

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

Nach oben
       

Sorry, da ist beim kopieren woll was schief gelaufen. Hier kommt noch mal der Code, welcher deine 1. Frage beantwortet:
Code:
Sub SpeichernalsMSG()

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

strBackupPath = 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) & ".msg"

myItem.SaveAs strBackupPath & "\" & CleanString(strname), olMSG
       
Next
Ende:

End Sub

Private Function CleanString(strData As String) As String
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, """", "_")
strData = ReplaceChar(strData, "|", "")
CleanString = Trim(strData)
End Function
Private Function ReplaceChar(strData As String, strBadChar As String, strGoodChar As String) As String
Dim tmpChar, 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

Public Function GetFileDir() As String
Dim ret As String
    Dim lpIDList As Long
    Dim sPath As String, udtBI As BrowseInfo
    Dim RdStrings() As String, nNewFiles As Long

    'Show a browse-for-folder form:
    With udtBI
        .lpszTitle = lstrcat("Bitte wählen Sie den Ordner zum Exportieren:", "")
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With

    lpIDList = SHBrowseForFolder(udtBI)
    If lpIDList = 0 Then Exit Function
       
    'Get the selected folder.
    sPath = String$(MAX_PATH, 0)
    SHGetPathFromIDList lpIDList, sPath
    CoTaskMemFree lpIDList
    sPath = StripNulls(sPath)
    GetFileDir = sPath
End Function

Public Function StripNulls(ByVal OriginalStr As String) As String
    If (InStr(OriginalStr, Chr$(0)) > 0) Then
        OriginalStr = Left$(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
    End If
    StripNulls = OriginalStr
End Function


Füge bei der Funktion CleanString noch folgende Zeilen ein:
strData = ReplaceChar(strData, "<", "")
strData = ReplaceChar(strData, ">", "")

Zur Frage 2: Der Code speichert die E-Mails als MSG-Dateien, wo auch die Anlagen mitgespeichert werden. Reicht das denn oder willst du die Anlagen extra speichern?

_________________
Gruß Andreas

Das besondere Erleben.
steifhahn
Im Profil kannst Du frei den Rang ändern


Verfasst am:
30. Aug 2006, 10:58
Rufname:

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

Nach oben
       

Hmm...

Beim Ausführen des Codes tritt ein Fehler auf:
Fehler beim Kompilieren
Benutzerdefinierter Typ nicht definiert

mit Verweis auf "udtBI As BrowseInfo"

Zur 2.Frage: Die Mail soll nicht als msg-Datei gespeichert werden sondern als txt-Datei. Dateiname soll der Betreff sein!! Und alle dazugehörigen Anhänge in einem Unterordner zur TXT-Datei!

Das mit dem Textformat habe ich schon selber erledigt...fehlt eben nur noch die Option zum Aussuchen des Speicherortes.
UNd die Anhang-sache

Danke
Andreas.Fischer
Outlook - Moderator


Verfasst am:
30. Aug 2006, 12:29
Rufname:
Wohnort: Berlin

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

Nach oben
       

steifhahn - 30. Aug 2006, 10:58 hat folgendes geschrieben:
Beim Ausführen des Codes tritt ein Fehler auf:

Da hat mal wieder was gefehlt. Ich habe das ganze noch mal getestet und die fehlenden Zeilen eingearbeitet.

Zusätlich habe ich nun den Teil mit dem Anlagen speichern hinzugefügt.
Jetzt wird die Mail rein mit dem Betreff als Textdatei gespeichert und die vorhandenen Anlagen in einem Ordner mit gleichem Namen.
Code:
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)

Public Const BIF_RETURNONLYFSDIRS = 1
Public Const MAX_PATH = 260

Public Type BrowseInfo
    hwndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type

Sub SpeichernalsMSG()

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
Dim lngAttCount As Long, i As Long

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

If Not myfolder.DefaultItemType = olMailItem Then GoTo Ende

strBackupPath = GetFileDir

Set olSelection = myExplorer.Selection

For Each myItem In olSelection

strname = IIf(Len(strBackupPath & myItem.Subject) > 255, _
Left(myItem.Subject, 255 - Len(strBackupPath)), myItem.Subject) & ".txt"

myItem.SaveAs strBackupPath & "\" & CleanString(strname), olTXT
       
'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

'    Datei schon gespeichert
      datei = strSubDir & "\" & .FileName
      geändert = False
      nummer = 1
      Prüfname = datei
Zurück:

      nummer = nummer + 1

       If CreateObject("Scripting.FileSystemObject").FileExists(Prüfname) = True Then
        dateiname = CreateObject("Scripting.FileSystemObject").GetBaseName(datei)
        Dateiendung = CreateObject("Scripting.FileSystemObject").GetExtensionName(datei)
        dateinameneu = dateiname & " (" & nummer & ")" & "." & Dateiendung
        Prüfname = strSubDir & "\" & dateinameneu
        geändert = True
        GoTo Zurück:
       Else
        If geändert = False Then dateinameneu = .FileName
       End If

     .SaveAsFile strSubDir & "\" & dateinameneu
    End With
   Next
  Else
  End If
Next
Ende:

End Sub

Private Function CleanString(strData As String) As String
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, """", "_")
strData = ReplaceChar(strData, "|", "")
CleanString = Trim(strData)
End Function

Private Function ReplaceChar(strData As String, strBadChar As String, strGoodChar As String) As String
Dim tmpChar, 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


Public Function GetFileDir() As String
Dim ret As String
    Dim lpIDList As Long
    Dim sPath As String, udtBI As BrowseInfo
    Dim RdStrings() As String, nNewFiles As Long

    'Show a browse-for-folder form:
    With udtBI
        .lpszTitle = lstrcat("Bitte wählen Sie den Ordner zum Exportieren:", "")
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With

    lpIDList = SHBrowseForFolder(udtBI)
    If lpIDList = 0 Then Exit Function
       
    'Get the selected folder.
    sPath = String$(MAX_PATH, 0)
    SHGetPathFromIDList lpIDList, sPath
    CoTaskMemFree lpIDList
    sPath = StripNulls(sPath)
    GetFileDir = sPath
End Function

Public Function StripNulls(ByVal OriginalStr As String) As String
    If (InStr(OriginalStr, Chr$(0)) > 0) Then
        OriginalStr = Left$(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
    End If
    StripNulls = OriginalStr
End Function


Füge bei der Funktion CleanString noch folgende Zeilen ein:
strData = ReplaceChar(strData, "<", "")
strData = ReplaceChar(strData, ">", "")

_________________
Gruß Andreas

Das besondere Erleben.
steifhahn
Im Profil kannst Du frei den Rang ändern


Verfasst am:
30. Aug 2006, 12:40
Rufname:

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

Nach oben
       

Man geil es klappt!!!!

Ich danke dir!!!!!
forumoperator
Im Profil kannst Du frei den Rang ändern


Verfasst am:
11. Dez 2006, 11:14
Rufname:

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

Nach oben
       

WOOOOOOOOOOOOOW!!!!!!!!!!!

Ich bin gerade vom Stuhl gefallen.....nach solch einer Lösung habe ich bereits lange Zeit gesucht und mich erst in PHP versucht, was (IMHO) absolut mühseelig zu programmieren ist.

Die Lösung hier funktioniert genau so und so zuverlässig, wie es nur sein soll. Ich danke euch echt, auch mir habt ihr damit extrem gut geholfen!!!!!!!!

Jetzt trennt mich nur noch eine Lösung von der Fertigstellung meiner Arbeit Smile
ameise
Gast


Verfasst am:
11. Jan 2007, 11:30
Rufname:


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

Nach oben
       Version: Office 2003

diese Lösung ist Klasse.

Ich so etwas dringend, allerdings sollten die Mails mit folgender syntax abgelegt werden

Datum_ Name des Absenders_Betreff_Name 1.Empfänger

Das Makro ist mittlerweile so kpmlex, daß ich mir keine Änderungen zutraue.
Neues Thema eröffnen   Neue Antwort erstellen Alle Zeiten sind
GMT + 1 Stunde

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

Seite 1 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