Thema Datum  Von Nutzer Rating
Antwort
Rot Outlook VBA | Zahlenfolge am Ende String variabel löschen
26.09.2022 12:57:30 SV
NotSolved
26.09.2022 17:44:47 volti
*****
Solved
26.09.2022 21:36:46 Mase
NotSolved
26.09.2022 23:35:11 volti
NotSolved
27.09.2022 06:40:25 Mase
NotSolved
27.09.2022 09:49:49 SV
NotSolved
27.09.2022 02:10:39 Gast43808
*****
Solved
27.09.2022 02:15:42 Gast43808
NotSolved
27.09.2022 10:19:47 SV
NotSolved
27.09.2022 10:28:14 Gast90743
NotSolved
27.09.2022 17:51:49 Gast41444
NotSolved

Ansicht des Beitrags:
Von:
SV
Datum:
26.09.2022 12:57:30
Views:
317
Rating: Antwort:
  Ja
Thema:
Outlook VBA | Zahlenfolge am Ende String variabel löschen

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

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Outlook VBA | Zahlenfolge am Ende String variabel löschen
26.09.2022 12:57:30 SV
NotSolved
26.09.2022 17:44:47 volti
*****
Solved
26.09.2022 21:36:46 Mase
NotSolved
26.09.2022 23:35:11 volti
NotSolved
27.09.2022 06:40:25 Mase
NotSolved
27.09.2022 09:49:49 SV
NotSolved
27.09.2022 02:10:39 Gast43808
*****
Solved
27.09.2022 02:15:42 Gast43808
NotSolved
27.09.2022 10:19:47 SV
NotSolved
27.09.2022 10:28:14 Gast90743
NotSolved
27.09.2022 17:51:49 Gast41444
NotSolved