Hallo zusammen,

ich möchte in Outlook aus dem subject die letzten Zeichen bis zum Leerzeichen entfernen. Hierbei handelt es sich um eine Zahlenfolge, die Variable zwischen 0 und 5 Zahlen liegt und dann von rechts gesehen immer ein Leerzeichen vorstehen hat. 

Die Mails werden auf der Festplatte abgelegt. Aber das funktioniert einwandfrei. Leider erkennt er das Leerzeichen nicht immer an der richtigen Stelle und ich verzweifle woran das liegen kann.

In diesem Beispiel geht es um das Sub "Markierte_Mail_Speichern" und um meine bisher erfolglose Zeile. Gern nachstehend die Beispielmail, die ich durch die debug.print Methode nacheinander darstelle, um zu zeigen was der Output ist. Erst soll archiviert weg, dann KB, dann die Zahl der KB, die zwischen 1 und 5 Zeilen haben kann.

WG: Unterlagen zur Basisschulung DS-AP  - -ARCHIVIERT- 10462 KB
WG: Unterlagen zur Basisschulung DS-AP  10462 KB
WG: Unterlagen zur Basisschulung DS-AP  10462
 3 
WG: Unterlagen zur Basisschulung DS-AP  10 (Dieses Ergebnis brauche ich ohne die 10). Das klappt aber nicht.

Erfolglose Zeile: "subject = Replace(subject, Right(subject, InStr(subject, " ") - 1), "")"

Dim OutAppl As Object
Dim OutItem As Object
Dim OutName As Object
Dim OutFold As Object
Dim i As Integer
Dim pfad As String
Dim kunde As String
Dim Absender As String
Dim datum As String
Dim subject As String
Dim dateiname As String
Dim Fehlercounter As Long
Dim Gruppenpostfach As Long
Dim Fehlermail As String

Private Type BROWSEINFO
    hOwner          As Long
    pidlRoot        As Long
    pszDisplayName  As String
    lpszTitle       As String
    ulFlags         As Long
    lpfn            As Long
    lParam          As Long
    iImage          As Long
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
            "SHGetPathFromIDListA" (ByVal pidl As Long, _
            ByVal pszPath As String) As Long
            
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
            "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
            As Long
            
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" _
            (ByVal hWnd As Long, ByVal Msg As Long, wParam As Any, lParam As Any) _
            As Long
            
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BFFM_SETSELECTION = &H466
Private Const BFFM_INITIALIZED = 1

Global StartDir As String
Public Function VerzeichnisSuchen(szDialogTitle As String, StartVerzeichnis As String) As String

Dim X         As Long
Dim bi        As BROWSEINFO
Dim dwIList   As Long
Dim szPath    As String
Dim wPos      As Integer

StartDir = StartVerzeichnis

With bi
      .hOwner = hWndAccessApp
      .lpszTitle = szDialogTitle
      .ulFlags = BIF_RETURNONLYFSDIRS
      .lpfn = DummyFunc(AddressOf BrowseCallbackProc)
End With
  
dwIList = SHBrowseForFolder(bi)
szPath = Space$(512)
X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)

If X Then
    wPos = InStr(szPath, Chr(0))
    VerzeichnisSuchen = Left$(szPath, wPos - 1)
Else
    VerzeichnisSuchen = ""
End If
  
End Function
Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, _
                ByVal lParam As Long, ByVal lpData As Long) As Long

    Dim pathstring  As String
    Dim retval      As Long

    Select Case uMsg
        Case BFFM_INITIALIZED
            pathstring = StartDir
            retval = SendMessage(hWnd, BFFM_SETSELECTION, ByVal CLng(1), ByVal pathstring)
    End Select
    
    BrowseCallbackProc = 0

End Function
Public Function DummyFunc(ByVal param As Long) As Long
    DummyFunc = param
End Function
Public Function test() As String
test = VerzeichnisSuchen("Mail Speichern in:", "H:\"
End Function
Function parseChars(pcstr) As String
Dim i, ch, astr
astr = pcstr
For i = 1 To Len(astr)
  ch = Mid(astr, i, 1)
  ' test for "
  If Asc(ch) = 34 Then Mid(astr, i, 1) = "'"

  Select Case ch
    Case "<"
      Mid(astr, i, 1) = "["
    Case ">"
      Mid(astr, i, 1) = "]"
    Case "|"
      Mid(astr, i, 1) = "!"
    Case "?"
      Mid(astr, i, 1) = "!"
    Case "*"
      Mid(astr, i, 1) = "#"
    Case ":"
      Mid(astr, i, 1) = "-"
    Case "\"
      Mid(astr, i, 1) = "`"
    Case "/"
      Mid(astr, i, 1) = "'"
    Case "?"
      Mid(astr, i, 1) = "!"
    Case "."
      Mid(astr, i, 1) = "-"
End Select
Next
parseChars = astr
End Function

Sub Markierte_Mail_speichern()

Set OutAppl = GetObject(, "Outlook.Application")
Set OutName = OutAppl.GetNamespace("MAPI")
Set OutFold = Application.ActiveExplorer.Selection

Fehlermail = Empty
Fehlercounter = 0
Gruppenpostfach = 0
kunde = test

'Eingrenzen: Alles außer normale Namen?
For i = 1 To OutFold.Count
    datum = Format(OutFold.Item(i).ReceivedTime, "yyyy-mm-dd-hhmm")
    Absender = OutFold.Item(i).SenderName
    If Right(Absender, 15) = "Gruppenpostfach" Then
        datum = Format(OutFold.Item(i).ReceivedTime, "yyyy-mm-dd-hhmm")
        subject = OutFold.Item(i).subject
        subject = Replace(subject, " - -ARCHIVIERT-" & " ", "")
        subject = Replace(subject, " KB", "")
        'subject = Right(subject, InStr(subject, " ") - 1)
        pfad = datum & "_" & subject
        pfad = parseChars(pfad)
        dateiname = kunde & "\" & pfad & ".msg"
    Else
        On Error Resume Next
        Absender = Left(parseChars(Absender), InStr(Absender, ",") - 1)
        On Error GoTo 0
        subject = OutFold.Item(i).subject
        Debug.Print subject
        subject = Replace(subject, " - -ARCHIVIERT-" & " ", " ")
        Debug.Print subject
        subject = Replace(subject, " KB", "")
        Debug.Print subject
        Debug.Print Len(Right(subject, (InStr(subject, " ") - 1)))
        subject = Replace(subject, Right(subject, InStr(subject, " ") - 1), "")
        Debug.Print subject
        pfad = datum & "_" & subject
        pfad = parseChars(pfad)
        dateiname = kunde & "\" & pfad & Absender & " " & ".msg"
    End If
    'Prüfung, ob Dateiname über 260 Zeichen
    If Len(dateiname) > 260 Then
        Fehlercounter = Fehlercounter + 1
        Fehlermail = Fehlermail & dateiname & ";"
        Debug.Print Fehlermail
        Debug.Print Len(dateiname)
        Debug.Print dateiname
    Else: End If
    On Error Resume Next
    OutFold.Item(i).SaveAs dateiname  'Speichern
    On Error GoTo 0
Next i
   
If Fehlercounter > 0 Then
    MsgBox "Insgesamt konnten " & Fehlercounter & " von " & OutFold.Count & " Mails nicht abgelegt werden. Bitte prüfen Sie nachfolgende Mails:" & Chr(10) & Chr(10) & _
    Fehlermail, vbInformation, "Hinweis:"
Else: End If
   
Set OutName = Nothing
Set OutAppl = Nothing
Set OutFold = Nothing

End Sub