[Sonstiges] Outlook 2010 VBA: Verzeichnisstruktur aus Dateinamen erstellen

A

amn.ssy

Erfahrenes Mitglied
Hallo,

u.a. mit dem nachfolgenden Outlook-Makro lege ich Emails auf der NAS ab.
Das funktioniert soweit auch recht gut.

Klar - der Code ist ja auch nicht von mir

Nun möchte ich die Mails idealerweise gleich etwas struktuierter ablegen und daher mittels
Datum und Sender bzw. Empfänger auf einen vorhanden Ordner prüfen und ggf. erstellen.
Die Struktur könnte dabei etwa so aussehen

Visual Basic: 
Z:\Mailarchiv\
|--> In
      |--> Date
            |--> Sender
|--> Out
      |--> Date
            |--> Receiver

Die notwendigen Informationen gibt die Funktionen ja bereits aus.
Was eben noch fehlt wäre unterhalb von Mailarchiv die entsprechenden Ordner anzulegen und dabei idealerweise feststellen ob es sich um ein ein- oder ausgehendes Mail handelt (wäre möglicherweise über eine Konstante lösbar - wenn <SENDER> = "müller, lieschen" dann Verzeichnis = out.
Wäre super wenn jemand einen Ansatz hätte.

Visual Basic: 
Option Explicit

'-------------------------------------------------------------
' OPTIONS
'-------------------------------------------------------------
'Email format:
' MSG = Outlook msg format (incl. attachments, embedded objects etc.)., TXT = plain text
Private Const EXM_OPT_MAILFORMAT As String = "MSG"
'Date format of filename
Private Const EXM_OPT_FILENAME_DATEFORMAT As String = "yyyy-mm-dd_hh-nn-ss"
'Build filename; placeholders: <DATE> for date, <SENDER> for sender's name, <RECEIVER> for receiver, <SUBJECT> for subject
Private Const EXM_OPT_FILENAME_BUILD As String = "<DATE>_<SENDER>_to_<RECEIVER>_<SUBJECT>"
'Use browse folder? Set to FALSE if you don't want to use browser for selecting target folder
Private Const EXM_OPT_USEBROWSER As Boolean = True
'Target folder (used if EXM_OPT_USEBROWSER is set to FALSE)
Private Const EXM_OPT_TARGETFOLDER As String = "Z:\Mailarchiv\"
'Maximum number of emails to be selected & exported. Please don't use a huge number as this will cause
'performance and maybe other issues. Recommended is a value between 5 and 20.
Private Const EXM_OPT_MAX_NO As Integer = 15
'Email subject prefixes (such us "RE:", "FW:" etc.) to be removed. Please note that this is a
'RegEx expression, google for "regex" for further information. For instance "\s" means blank " ".
Private Const EXM_OPT_CLEANSUBJECT_REGEX As String = "RE:\s|Re:\s|AW:\s|FW:\s|WG:\s|SV:\s|Antwort:\s"
'-------------------------------------------------------------


'-------------------------------------------------------------
' TRANSLATIONS
'-------------------------------------------------------------
'-- English
'Const EXM_007 = "Script terminated"
'Const EXM_013 = "Selected Outlook item is not an e-mail"
'Const EXM_014 = "File already exists"
'-- German
Private Const EXM_001 As String = "Die E-Mail wurde erfolgreich abgelegt."
Private Const EXM_002 As String = "Die E-Mail konnte nicht abgelegt werden, Grund:"
Private Const EXM_003 As String = "Ausgewählter Pfad:"
Private Const EXM_004 As String = "E-Mail(s) ausgewählt und erfolgreich abgelegt."
Private Const EXM_005 As String = "<FREE>"
Private Const EXM_006 As String = "<FREE>"
Private Const EXM_007 As String = "Script abgebrochen"
Private Const EXM_008 As String = "Fehler aufgetreten: Sie haben mehr als [LIMIT_SELECTED_ITEMS] E-Mails ausgewählt. Die Aktion wurde beendet."
Private Const EXM_009 As String = "Es wurde keine E-Mail ausgewählt."
Private Const EXM_010 As String = "Es ist ein Fehler aufgetreten: es war keine Email im Fokus, so dass die Ablage nicht erfolgen konnte."
Private Const EXM_011 As String = "Es ist ein Fehler aufgetreten:"
Private Const EXM_012 As String = "Die Aktion wurde beendet."
Private Const EXM_013 As String = "Ausgewähltes Outlook-Dokument ist keine E-Mail"
Private Const EXM_014 As String = "Datei existiert bereits"
Private Const EXM_015 As String = "<FREE>"
Private Const EXM_016 As String = "Bitte wählen Sie den Ordner zum Exportieren:"
Private Const EXM_017 As String = "Fehler beim Exportieren aufgetreten"
Private Const EXM_018 As String = "Export erfolgreich"
Private Const EXM_019 As String = "Bei [NO_OF_FAILURES] E-Mail(s) ist ein Fehler aufgetreten:"
Private Const EXM_020 As String = "[NO_OF_SELECTED_ITEMS] E-Mail(s) wurden ausgewählt und [NO_OF_SUCCESS_ITEMS] E-Mail(s) erfolgreich abgelegt."
'-------------------------------------------------------------


'-------------------------------------
'For browse folder
'-------------------------------------
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260
Private 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

Public Sub ExportEmailToDrive()
    
    Const PROCNAME As String = "Mail2Drive"
    
    On Error GoTo ErrorHandler
    
    Dim myExplorer As Outlook.Explorer
    Dim myfolder As Outlook.MAPIFolder
    Dim myItem As Object
    Dim olSelection As Selection
    Dim strBackupPath As String
    Dim intCountAll As Integer
    Dim intCountFailures As Integer
    Dim strStatusMsg As String
    Dim vSuccess As Variant
    Dim strTemp1 As String
    Dim strTemp2 As String
    Dim strErrorMsg As String
 
    '-------------------------------------
    'Get target drive
    '-------------------------------------
    If (EXM_OPT_USEBROWSER = True) Then
        strBackupPath = GetFileDir
        If Left(strBackupPath, 15) = "ERROR_OCCURRED:" Then
            strErrorMsg = Mid(strBackupPath, 16, 9999)
            Error 5004
        End If
    Else
        strBackupPath = EXM_OPT_TARGETFOLDER
    End If
    If strBackupPath = "" Then GoTo ExitScript
    If (Not Right(strBackupPath, 1) = "\") Then strBackupPath = strBackupPath & "\"
    
    
 
    '-------------------------------------
    'Process according to what is in the focus: an opened e-mail or a folder with selected e-mails.
    'Case 2 would also work for opened e-mail, however it does not always work (for instance if
    ' an e-mail is saved on the file system and being opened from there).
    '-------------------------------------

    Set myExplorer = Application.ActiveExplorer
    Set myfolder = myExplorer.CurrentFolder
    If myfolder Is Nothing Then Error 5001
    If Not myfolder.DefaultItemType = olMailItem Then GoTo ExitScript
    
    'Stop if more than x emails selected
    If myExplorer.Selection.Count > EXM_OPT_MAX_NO Then Error 5002
      
    'No email selected at all?
    If myExplorer.Selection.Count = 0 Then Error 5003
     
    Set olSelection = myExplorer.Selection
    intCountAll = 0
    intCountFailures = 0
    For Each myItem In olSelection
        intCountAll = intCountAll + 1
        vSuccess = ProcessEmail(myItem, strBackupPath)
        If (Not vSuccess = True) Then
            Select Case intCountFailures
                Case 0: strStatusMsg = vSuccess
                Case 1: strStatusMsg = "1x " & strStatusMsg & Chr(10) & "1x " & vSuccess
                Case Else: strStatusMsg = strStatusMsg & Chr(10) & "1x " & vSuccess
            End Select
            intCountFailures = intCountFailures + 1
        End If
    Next
    If intCountFailures = 0 Then
        strStatusMsg = intCountAll & " " & EXM_004
    End If

        
    'Final Message
    If (intCountFailures = 0) Then  'No failure occurred
        MsgBox strStatusMsg & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 64, EXM_018
    ElseIf (intCountAll = 1) Then   'Only one email was selected and a failure occurred
        MsgBox EXM_002 & Chr(10) & vSuccess & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 48, EXM_017
    Else    'More than one email was selected and at least one failure occurred
        strTemp1 = Replace(EXM_020, "[NO_OF_SELECTED_ITEMS]", intCountAll)
        strTemp1 = Replace(strTemp1, "[NO_OF_SUCCESS_ITEMS]", intCountAll - intCountFailures)
        strTemp2 = Replace(EXM_019, "[NO_OF_FAILURES]", intCountFailures)
        MsgBox strTemp1 & Chr(10) & Chr(10) & strTemp2 & Chr(10) & Chr(10) & strStatusMsg _
        & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 48, EXM_017
    End If


ExitScript:
    Exit Sub
ErrorHandler:
    Select Case Err.Number
    Case 5001:  'Not an email
        MsgBox EXM_010, 64, EXM_007
    Case 5002:
        MsgBox Replace(EXM_008, "[LIMIT_SELECTED_ITEMS]", EXM_OPT_MAX_NO), 64, EXM_007
    Case 5003:
        MsgBox EXM_009, 64, EXM_007
    Case 5004:
        MsgBox EXM_011 & Chr(10) & Chr(10) & strErrorMsg, 48, EXM_007
    Case Else:
        MsgBox EXM_011 & Chr(10) & Chr(10) _
        & Err & " - " & Error$ & Chr(10) & Chr(10) & EXM_012, 48, EXM_007
    End Select
    Resume ExitScript
End Sub

Private Function ProcessEmail(myItem As Object, strBackupPath As String) As Variant
    'Saves the e-mail on the drive by using the provided path.
    'Returns TRUE if successful, and FALSE otherwise.

    Const PROCNAME As String = "ProcessEmail"

    On Error GoTo ErrorHandler

    Dim myMailItem As MailItem
    Dim strDate As String
    Dim strSender As String
    Dim strReceiver As String
    Dim strSubject As String
    Dim strFinalFileName As String
    Dim strFullPath As String
    Dim vExtConst As Variant
    Dim vTemp As String
    Dim strErrorMsg As String

    If TypeOf myItem Is MailItem Then
         Set myMailItem = myItem
    Else
        Error 1001
    End If

    'Set filename
    strDate = Format(myMailItem.ReceivedTime, EXM_OPT_FILENAME_DATEFORMAT)
    strSender = myMailItem.SenderName
    strReceiver = myMailItem.To 'All receiver, semikolon separated string
    If InStr(strReceiver, ";") > 0 Then strReceiver = Left(strReceiver, InStr(strReceiver, ";") - 1)
    strSubject = myMailItem.Subject
    strFinalFileName = EXM_OPT_FILENAME_BUILD
    strFinalFileName = Replace(strFinalFileName, "<DATE>", strDate)
    strFinalFileName = Replace(strFinalFileName, "<SENDER>", strSender)
    strFinalFileName = Replace(strFinalFileName, "<RECEIVER>", strReceiver)
    strFinalFileName = Replace(strFinalFileName, "<SUBJECT>", strSubject)
    strFinalFileName = CleanString(strFinalFileName)
    If Left(strFinalFileName, 15) = "ERROR_OCCURRED:" Then
        strErrorMsg = Mid(strFinalFileName, 16, 9999)
        Error 1003
    End If
    strFinalFileName = IIf(Len(strFinalFileName) > 251, Left(strFinalFileName, 251), strFinalFileName)
    strFullPath = strBackupPath & strFinalFileName
    
    'Save as msg or txt?
    Select Case UCase(EXM_OPT_MAILFORMAT)
        Case "MSG":
            strFullPath = strFullPath & ".msg"
            vExtConst = olMSG
        Case Else:
            strFullPath = strFullPath & ".txt"
            vExtConst = olTXT
    End Select
    'File already exists?
    If CreateObject("Scripting.FileSystemObject").FileExists(strFullPath) = True Then
        Error 1002
    End If
    
    'Save file
    myMailItem.SaveAs strFullPath, vExtConst
    
    'Return true as everything was successful
    ProcessEmail = True

ExitScript:
    Exit Function
ErrorHandler:
    Select Case Err.Number
    Case 1001:  'Not an email
        ProcessEmail = EXM_013
    Case 1002:
        ProcessEmail = EXM_014
    Case 1003:
        ProcessEmail = strErrorMsg
    Case Else:
        ProcessEmail = "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"
    End Select
    Resume ExitScript
End Function


Private Function CleanString(strData As String) As String

    Const PROCNAME As String = "CleanString"

    On Error GoTo ErrorHandler

    'Instantiate RegEx
    Dim objRegExp As Object
    Set objRegExp = CreateObject("VBScript.RegExp")
    objRegExp.Global = True

    'Cut out strings we don't like
    objRegExp.Pattern = EXM_OPT_CLEANSUBJECT_REGEX
    strData = objRegExp.Replace(strData, "")

    'Replace and cut out invalid strings.
    strData = Replace(strData, Chr(9), "_")
    strData = Replace(strData, Chr(10), "_")
    strData = Replace(strData, Chr(13), "_")
    objRegExp.Pattern = "[/\\*]"
    strData = objRegExp.Replace(strData, "-")
    objRegExp.Pattern = "[""]"
    strData = objRegExp.Replace(strData, "'")
    objRegExp.Pattern = "[:?<>\|]"
    strData = objRegExp.Replace(strData, "")
    
    'Replace multiple chars by 1 char
    objRegExp.Pattern = "\s+"
    strData = objRegExp.Replace(strData, " ")
    objRegExp.Pattern = "_+"
    strData = objRegExp.Replace(strData, "_")
    objRegExp.Pattern = "-+"
    strData = objRegExp.Replace(strData, "-")
    objRegExp.Pattern = "'+"
    strData = objRegExp.Replace(strData, "'")
            
    'Trim
    strData = Trim(strData)
    
    'Return result
    CleanString = strData
  
  
ExitScript:
    Exit Function
ErrorHandler:
    CleanString = "ERROR_OCCURRED:" & "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"
    Resume ExitScript
End Function

Private Function GetFileDir() As String
    
    Const PROCNAME As String = "GetFileDir"

    On Error GoTo ErrorHandler

    Dim ret As String
    Dim lpIDList As Long
    Dim sPath As String
    Dim udtBI As BrowseInfo
    Dim RdStrings() As String
    Dim nNewFiles As Long

    'Show a browse-for-folder form:
    With udtBI
        .lpszTitle = lstrcat(EXM_016, "")
        .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
    
    'Strip Nulls
    If (InStr(sPath, Chr$(0)) > 0) Then sPath = Left$(sPath, InStr(sPath, Chr(0)) - 1)

    'Return Dir
    GetFileDir = sPath

ExitScript:
    Exit Function
ErrorHandler:
    GetFileDir = "ERROR_OCCURRED:" & "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"
    Resume ExitScript
End Function

LG
opiwahn
 
Zu den Foldern

In Zeile 238 arebeitest du mit dem FSO
Visual Basic: 
    If CreateObject("Scripting.FileSystemObject").FileExists(strFullPath) = True Then

Dort kannst du nicht nur testen ob ein FIle exisitert, sondern auch ob ein Ordner existiert und ggf diesen anlegen.

In Zeile 226 setzt du den Pfad zusammen. Dort kommt noch das Datum mit hinein

Für das Datum währen dass so ungefähr meine Zeilen für die 226-238
Visual Basic: 
    'FSO Object erstellen
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    
    'Das datum an den pfad anhängen
    'fso.buildPath() verwenden, damit man sich nicht um die \ kümmern muss
    strbackuppath = fso.BuildPath(strbackuppath, format(Now, "yyyymmdd"))
    
    'Den Ordner ggf anlegen
    If Not fso.FolderExists(strbackuppath) Then
        fso.CreateFolder (strbackuppath)
    End If
    
    strFullPath = fso.BuildPath(strbackuppath, strFinalFileName)
    
    'Save as msg or txt?
    Select Case UCase(EXM_OPT_MAILFORMAT)
        Case "MSG":
            strFullPath = strFullPath & ".msg"
            vExtConst = olMSG
        Case Else:
            strFullPath = strFullPath & ".txt"
            vExtConst = olTXT
    End Select
    'File already exists?
    If fso.FileExists(strFullPath) = True Then
        Error 1002
    End If
    'FSO Object zerstören
    Set fso = Nothing


Ob es in oder out ist, solltest du glaub anhand des Outlook-Folders herausfinden können
 
Hallo Yaslaw,
Hallo Zvoni,

danke für euere Hinweise.
Ich habe gestern Abend noch ein wenig gebastelt und deinen Vorschlag, Yaslaw, implementiert.
Das Ganze sieht gerade auszugweise so aus:
Visual Basic: 
Private Function ProcessEmail(myItem As Object, strBackupPath As String) As Variant
    'Saves the e-mail on the drive by using the provided path.
    'Returns TRUE if successful, and FALSE otherwise.

    Const PROCNAME As String = "ProcessEmail"

    On Error GoTo ErrorHandler

    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim myMailItem As MailItem
    Dim strFolderDate As String
    Dim strFileDate As String
    Dim strSender As String
    Dim strReceiver As String
    Dim strSubject As String
    Dim strFinalFileName As String
    Dim strFullPath As String
    Dim vExtConst As Variant
    Dim vTemp As String
    Dim strErrorMsg As String
    
    If TypeOf myItem Is MailItem Then
         Set myMailItem = myItem
    Else
        Error 1001
    End If
    
    
'*** StartTest Folder
    Dim strParentFolder As String
    Dim strFolder As String
    strParentFolder = Application.ActiveExplorer.CurrentFolder.Parent
    strFolder = Application.ActiveExplorer.CurrentFolder.Name
    If strFolder = "Posteingang" Then
       strFolder = "InMails"
    ElseIf strFolder = "Gesendete Elemente" Then
       strFolder = "OutMails"
    End If
    MsgBox strFolder & "-" & strParentFolder
'*** EndTest Folder
    
    'Set filename
    strFolderDate = Format(myMailItem.ReceivedTime, EXM_OPT_FOLDERNAME_DATEFORMAT)
    strFileDate = Format(myMailItem.ReceivedTime, EXM_OPT_FILENAME_DATEFORMAT)
    strSender = myMailItem.SenderName
    strReceiver = myMailItem.To 'All receiver, semikolon separated string
    If InStr(strReceiver, ";") > 0 Then strReceiver = Left(strReceiver, InStr(strReceiver, ";") - 1)
    strSubject = myMailItem.Subject
    strFinalFileName = EXM_OPT_FILENAME_BUILD
    strFinalFileName = Replace(strFinalFileName, "<DATE>", strFileDate)
    strFinalFileName = Replace(strFinalFileName, "<SENDER>", strSender)
    strFinalFileName = Replace(strFinalFileName, "<RECEIVER>", strReceiver)
    strFinalFileName = Replace(strFinalFileName, "<SUBJECT>", strSubject)
    strFinalFileName = CleanString(strFinalFileName)
    If Left(strFinalFileName, 15) = "ERROR_OCCURRED:" Then
        strErrorMsg = Mid(strFinalFileName, 16, 9999)
        Error 1003
    End If
    strFinalFileName = IIf(Len(strFinalFileName) > 251, Left(strFinalFileName, 251), strFinalFileName)
    strBackupPath = fso.BuildPath(strBackupPath, strFolderDate)
    
    If Not fso.FolderExists(strBackupPath) Then
        fso.CreateFolder (strBackupPath)
    End If

    strFullPath = fso.BuildPath(strBackupPath, strFinalFileName)
    
    'Save as msg or txt?
    Select Case UCase(EXM_OPT_MAILFORMAT)
        Case "MSG":
            strFullPath = strFullPath & ".msg"
            vExtConst = olMSG
        Case Else:
            strFullPath = strFullPath & ".txt"
            vExtConst = olTXT
    End Select
    'File already exists?
    If fso.FileExists(strFullPath) = True Then
        Error 1002
    End If
    
    'Save file
    myMailItem.SaveAs strFullPath, vExtConst
    
    'Return true as everything was successful
    ProcessEmail = True

ExitScript:
    Exit Function
ErrorHandler:
    Select Case Err.Number
    Case 1001:  'Not an email
        ProcessEmail = EXM_013
    Case 1002:
        ProcessEmail = EXM_014
    Case 1003:
        ProcessEmail = strErrorMsg
    Case Else:
        ProcessEmail = "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"
    End Select
    Resume ExitScript
End Function

Zumindest kann ich analog des Datum der Mail ein Ordner im Format JJJJ-MM-TT erstellen und alle Mails werden auch richtig im Taggenauen Ordner abgelegt.
Mit einem zwischengelagerten Test gelingt es mir auch herauszufinden ob es sich um einen Postein- oder ausgang handelt.
Nun habe ich aber immer noch das Problem ggf. entsprechende Unterordner zu erzeugen.
Etwa so:
Visual Basic: 
z:\Mailarchiv   <- gesetzt
    - InMails      
       - Date      <- funktioniert
        - Sender
    - OutMails
      - Date
        - Receiver
Der zwischengelagerte Test funktioniert leider nur wenn ich auf dem Hauptverzeichnis stehe.
Stehe ich bei einem Unterverzeichnis z.B. "Lieferanten" von Posteingang wird zwar der Name "Lieferanten" korrekt zurück gegeben, jedoch fehlt mir dann der Bezug zum Posteingang.
Sowas wie Parentfolder scheint es wohl nicht zu geben :-(
Wie komme ich an den übergeordneten Verzeichnisnamen, da ich diesen ja letztlich benötige um die zu erzeugende Verzeichnisstruktur anzusprechen bzw. anzulegen?

LG
opiwahn
 
Zuletzt bearbeitet:
Update 22.01.2013 12:03
Es ist nicht schön, aber so geht es dann ... mit Ausnahme der Untervezeichnisproblematik
Visual Basic: 
...
strFolder = Application.ActiveExplorer.CurrentFolder.Name
    If strFolder = "Posteingang" Then
       strFolder = "InMails"
    ElseIf strFolder = "Gesendete Elemente" Then
       strFolder = "OutMails"
    End If

    'Set filename
    strFolderDate = Format(myMailItem.ReceivedTime, EXM_OPT_FOLDERNAME_DATEFORMAT)
    strFileDate = Format(myMailItem.ReceivedTime, EXM_OPT_FILENAME_DATEFORMAT)
    strSender = myMailItem.SenderName
    strReceiver = myMailItem.To 'All receiver, semikolon separated string
    If InStr(strReceiver, ";") > 0 Then strReceiver = Left(strReceiver, InStr(strReceiver, ";") - 1)
    strSubject = myMailItem.Subject
    strFinalFileName = EXM_OPT_FILENAME_BUILD
    strFinalFileName = Replace(strFinalFileName, "<DATE>", strFileDate)
    strFinalFileName = Replace(strFinalFileName, "<SENDER>", strSender)
    strFinalFileName = Replace(strFinalFileName, "<RECEIVER>", strReceiver)
    strFinalFileName = Replace(strFinalFileName, "<SUBJECT>", strSubject)
    strFinalFileName = CleanString(strFinalFileName)
    If Left(strFinalFileName, 15) = "ERROR_OCCURRED:" Then
        strErrorMsg = Mid(strFinalFileName, 16, 9999)
        Error 1003
    End If
    strFinalFileName = IIf(Len(strFinalFileName) > 251, Left(strFinalFileName, 251), strFinalFileName)
    
    strBackupPath = fso.BuildPath(strBackupPath, strFolder)
        If Not fso.FolderExists(strBackupPath) Then
            fso.CreateFolder (strBackupPath)
        End If
    
    strBackupPath = fso.BuildPath(strBackupPath, strFolderDate)
        If Not fso.FolderExists(strBackupPath) Then
            fso.CreateFolder (strBackupPath)
        End If
    
    If strFolder = "InMails" Then
        strBackupPath = fso.BuildPath(strBackupPath, strSender)
    Else
        strBackupPath = fso.BuildPath(strBackupPath, strReceiver)
    End If
    
        If Not fso.FolderExists(strBackupPath) Then
            fso.CreateFolder (strBackupPath)
        End If

    strFullPath = fso.BuildPath(strBackupPath, strFinalFileName)
...

Was kann man ab Zeile 28ff besser machen?
 
Mit der API die ich genannt habe entfällt das ganze Prüf-Getöse

Visual Basic: 
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
Private Sub Form_Load()
    'KPD-Team 2000
    'URL: http://www.allapi.net/
    'E-Mail: KPDTeam@Allapi.net
    'create the directory "c:\this\is\a\test\directory\", if it doesn't exist already
    MakeSureDirectoryPathExists "z:\MailArchiv\InMails\Date\Sender\"
    MakeSureDirectoryPathExists "z:\MailArchiv\OutMails\Date\Receiver\"
End Sub

Das einzige was du wissen/machen musst: Wie baue ich meinen Pfad zusammen!

EDIT: Ich hab gerade deine Zeile 13+14 gesehen
Visual Basic: 
strReceiver = myMailItem.To 'All receiver, semikolon separated string
    If InStr(strReceiver, ";") > 0 Then strReceiver = Left(strReceiver, InStr(strReceiver, ";") - 1)

Wieso Dim'st du nicht ein leeres Array und benutzt Split?
Visual Basic: 
Dim arrReceiver() As String

arrReceiver=Split(myMailItem.To, ";")
 
Zuletzt bearbeitet:
Hallo Zvoni,

wie ich eingangs schon erwähnte passe ich gerade einen Code auf meine Bedürfnisse an, der nicht von mir ist, aber zu 80% das tut was ich erreichen möchte.
Bis jetzt sieht das Ganze so aus:
Soweit man auf einer Mail steht die abgelegt werden soll, reicht ein Klick auf ein Button in der Menüleiste von Outlook und die Mail wird in einer dynamisch erzeugten Verzeichnisstruktur abgelegt.
Da der Internetexplorer aussteigt wenn ich ein Bild hochladen will dann eben so:
Visual Basic: 
Z:\Mailarchiv <-- festgelegter Ordner, was darunter folgt ist dynamisch erzeugt
    |--- InMails
          |--- 2014-01-20 <-- Datum der eingehenden Mails
                |--- Maier, Kurt   <-- Sender (in diesem Verzeichnis liegen dann alle abgelegten Mails
                                                             vom Maier Kurt an diesem Tag)
                |--- Becker, Hilde
                |--- Becker, Stefan
          |--- 2014-01-19
               |--- ...
               |--- ...
    |--- Outmails
          |--- 2014-01-20 <-- Datum der ausgehenden Mails
                |--- Maier, Kurt   <-- Receiver (in diesem Verzeichnis liegen dann alle abgelegten Mails
                                                               an Maier Kurt an diesem Tag)
                |--- Becker, Hilde
                |--- Becker, Stefan
          |--- 2014-01-19
               |--- ...
               |--- ...
Bis dahin funktioniert das :)
Was letztlich noch fehlt ist die Sache mit ggf. Unterverzeichnisse vom Postein- bzw. ausgang.
Da es sich mir derzeit nicht erschließt wie ich sinnvoll in die Verzeichnisstruktur oben auch noch Subdirectories integrieren soll muß es mir irgendwie gelingen das jeweilige Unterverzeichnis dem Hauptverzeichnis zuzuordnen (Lieferant unter Posteingang = Posteingang).
Der Vorschlag die API anzuzapfen ist grundsätzlich ein gute Alternative, jedoch befürchte ich, daß ich mit meinen nicht gerade tiefgehenden Kenntnisse ein Fass aufmache, das ich dann nicht mehr zu bekomme oder nach Goethe: "Die Geister, die ich rief ..."

Gruß
opiwahn
 
Zuletzt bearbeitet:
Damit wäre der letzte Schritt dann auch noch gemacht :)
Den Part von Zeile 2-7 von oben habe ich ersetzt durch:
Visual Basic: 
  If TypeOf obj Is Outlook.Inspector Then
    Set obj = obj.CurrentItem
  Else
    Set obj = obj.Selection(1)
  End If
  Set F = obj.Parent
  If InStr(1, F.folderPath, "Posteingang") Then
    strFolder = "InMails"
  ElseIf InStr(1, F.folderPath, "Gesendete Elemente") Then
    strFolder = "OutMails"
  End If
Und schon läuft das ganze rund :)

LG
opiWahn
 
Um antworten zu können musst du eingeloggt sein.

Neue Beiträge

Zurück