MS-Outlook Mails und Anhänge ins Dateisystem exportieren

zurück Programmcode von 'DieseOutlookSitzung'
Option Explicit
'
'   ----------------------------------------------------------------------
'
'   Name:   khoSAM  - SaveAsMsg
'
'   Zweck:  Sichern bestimmter (neuer) Mails aus
'           Outlook-PST-Dateien in einzelne MSG-Files
'           Löschen von Mails nach nn Tagen
'
'   Author: Dipl.Inform. Karl-Holger Osterbuhr
'
'   Stand:  06.04.2008
'
'   Historie:
'           06.04.2008 - Prüfung auf Outlook-Version
'           06.04.2008 - Prüfung auf nicht gesendete Items
'           06.04.2008 - Geänderte Folders-Auflistung
'           30.03.2008 - Erweiterte Basis-Ordner-Prüfung/Erstellung
'           29.03.2008 - Mit Sicherung der Formular-Position
'           14.03.2008 - Mit %-Anzeige
'           13.03.2008 - Mit cOnceADay
'           12.02.2008 - Mit PST- und Folder im Logging
'           11.02.2008 - Mit Save- und Lösch-Logging
'           27.01.2008 - Mit Formular frmProgress
'           08.01.2007 - FreeFile vor jedem Datei-Öffnen
'           03.06.2006 - Statt 13 jetzt Len(cDeleteAfter)
'           03.06.2006 - If InStr(mf.Description, cNoBackUp) = 0 nur in der inneren Schleife
'           01.03.2006 - GetSaveFolder prüfen jedes Sub-Directory
'           25.08.2005 - Save-Dir als yyyy\mm\dd
'           23.08.2005 - DeleteAfter
'           17.07.2005 - Neu
'
'   ----------------------------------------------------------------------
'
'   Aufruf: 1. Im Outlook über Alt+F11 den VBA-Editor öffnen
'           2. Den gesamten Code in den Bereich
'           Microsoft Office Outlook Objekte / DieseOutlookSitzung kopieren
'   ----------------------------------------------------------------------
'
'   ----------------------------------------------------------------------
'   Konstanten für die Konfiguration
'   In diesem Bereich können Anpassungen vorgenommen werden
'   ----------------------------------------------------------------------
'
'   cSaveBase           Verzeichnis, in das die ausgelagerten Nachrichten
'                       exportiert werden sollen
Const cSaveBase         As String = "C:\Daten\Mail"
'   ----------------------------------------------------------------------
'   cDeleteAfter        String, der anzeigt, daß Mails dieses Ordners nach
'                       N Tagen ersatzlos gelöscht werden sollen.
'                       Er ist mit der Tagesanzahl in der Beschreibung
'                       des Ordners zu hinterlegen (Rechtsklick/Eigenschaften)
Const cDeleteAfter      As String = "#DeleteAfter="
'   ----------------------------------------------------------------------
'   cNoBackUp           String, der anzeigt, daß dieser Ordner NICHT in das
'                       Backup einbezogen werden soll. Er ist in der Beschreibung
'                       des Ordners zu hinterlegen (Rechtsklick/Eigenschaften)
Const cNoBackUp         As String = "#NoBackUp#"
'   ----------------------------------------------------------------------
'   cArchivePattern     Datumsmuster für die jeweils neu zu erzeugenden
'                       Archivunterordner
'                       yyyymmdd erzeugt täglich einen neuen Unterordner
Const cArchivePattern   As String = "yyyymmdd"
'   cArchive3Level      Die Archivunterordner in der Form YYYY\MM\DD
'                       erstellen
Const cArchive3Level    As Boolean = True
Const cArchivePatternY  As String = "yyyy"
Const cArchivePatternM  As String = "mm"
Const cArchivePatternD  As String = "dd"
'   ----------------------------------------------------------------------
'   cControlFileName    Name der Datei, in die das letzte
'                       Laufdatum eingetragen wird
Const cControlFileName  As String = "LastSAM.tim"
'   ----------------------------------------------------------------------
'   cLogFileName        Name der Log-Datei, in die Zähler aller Aktionen
'                       eingetragen werden
Const cLogFileName      As String = "LastSAM.csv"
'   ----------------------------------------------------------------------
'   cReadAndUnread      Schalter, der angibt, ob nur ungelesene Nachrichten (=False)
'                       oder alle Nachrichten (=True) exportiert werden sollen
Const cReadAndUnread    As Boolean = True
'   ----------------------------------------------------------------------
'   cSepSubject         Trennzeichen für Absender und Betreff
'                       Wenn das Zeichen ein \ ist, wird für den Absender ein
'                       eigener Ordner angelegt. Sonst werden alle Nachrichten
'                       direkt unterhalb des Archivordners abgelegt
Const cSepSubject       As String = "_"
'   ----------------------------------------------------------------------
'   cLogAction          Soll jede Sicherung und Löschung protolliert werden ?
'                       Bei ja, wird jeweils an die Datei cLogActionName
'                       pro Aktion eine Zeile angehängt
'                       Gültige Werte sind True|False
'                       Neu seit Version 2.1
Const cLogAction        As Boolean = False
'   ----------------------------------------------------------------------
'   cLogActionName      Name der Log-Datei, in die Details aller Aktionen
'                       eingetragen werden
'                       Neu seit Version 2.1
Const cLogActionName    As String = "ActionSAM.csv"
'   ----------------------------------------------------------------------
'   cFormPosName        Name der Datei zur Sicherung der Formularposition
'                       Neu seit Version 2.3
Const cFormPosName      As String = "frmProgress.Position"
'   ----------------------------------------------------------------------
'   cModuloCnt          Alle n-Aktionen ein Formular-Refresh
'                       Je kleiner, desto öfter, aber auch langsamer
'                       Neu seit Version 2.1
Const cModuloCnt        As Integer = 50 ' muß > 0 sein !
'   ----------------------------------------------------------------------
'   cOnceADay           Schalter, der angibt, ob die Prozedur nur 1x täglich
'                       (=True) oder bei jedem Schließen von Outlook (=False)
'                       durchgeführt werden soll
'                       Neu seit Version 2.2
Const cOnceADay         As Boolean = True
'   ----------------------------------------------------------------------
'   cNotSentYet         Ersatzzeichenfolge für leeren Absender
'                       Neu seit Version 2.4
Const cNotSentYet       As String = "_noch_nicht_gesendet_"
'   ----------------------------------------------------------------------
'   Ende der Konstanten für die Konfiguration
'   ----------------------------------------------------------------------

Const cModule           As String = "SaveAsMsg"
Const cVersion          As String = "2.4"
Const cVersionDate      As String = "06.04.2008"

Const cBL               As String = " "
Const cBS               As String = "\"
Const cUS               As String = "_"
Const cSK               As String = ";"
Const cPU               As String = "."

Dim iLevel              As Integer  ' nur zur Info
Dim iLevelMax           As Integer  ' für das Logfile
Dim lCntDatafile        As Long     ' gelesene PST-Dateien
Dim lCntFolder          As Long     ' gelesene Ordner
Dim lCntItems           As Long     ' gelesene Mails
Dim lSavItems           As Long     ' gesicherte Mails
Dim lDelItems           As Long     ' gelöschte Mails
Dim lSavAtt             As Long     ' gesicherte Anhänge
Dim lCntItemsPrevRun    As Long     ' gelesene Mails beim letzten Mal
Dim sPST                As String   ' Name des aktuellen PST-Files
Dim iOLversion          As Integer  ' aktuelle Outlook-Hauptversion

Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

Const HWND_DESKTOP As Long = 0
Const LOGPIXELSX As Long = 88
Const LOGPIXELSY As Long = 90
'
'   Abbruch erzwungen
'
Public bCancelSave As Boolean       '   Sicherungs-Abbruch erzwungen
Private Function ScreenX()
  ScreenX = GetSystemMetrics(SM_CXSCREEN)
End Function
Private Function ScreenY()
  ScreenY = GetSystemMetrics(SM_CYSCREEN)
End Function
Function TwipsPerPixelX() As Single
'--------------------------------------------------
'Returns the width of a pixel, in twips.
'--------------------------------------------------
  Dim lngDC As Long
  lngDC = GetDC(HWND_DESKTOP)
  TwipsPerPixelX = 1440& / GetDeviceCaps(lngDC, LOGPIXELSX)
  ReleaseDC HWND_DESKTOP, lngDC
End Function
Function TwipsPerPixelY() As Single
'--------------------------------------------------
'Returns the height of a pixel, in twips.
'--------------------------------------------------
  Dim lngDC As Long
  lngDC = GetDC(HWND_DESKTOP)
  TwipsPerPixelY = 1440& / GetDeviceCaps(lngDC, LOGPIXELSY)
  ReleaseDC HWND_DESKTOP, lngDC
End Function
Public Function intAppVersion() As Integer
Dim iPu         As Integer
Dim sVersion    As String
Dim sErg        As String
Dim iErg        As Integer

    sVersion = Application.Version
    iPu = InStr(sVersion, cPU)
    If iPu > 0 Then
        sErg = Left(sVersion, iPu - 1)
        If IsNumeric(sErg) Then
            iErg = CInt(sErg)
        Else
            iErg = 0
        End If
    Else
        iErg = 0
    End If
    
    intAppVersion = iErg
End Function
Public Function TestAppQuit()
    Call Application_Quit
    MsgBox "Testlauf beendet"
End Function
Private Sub Application_Quit()
'
'   Beim Beenden von Outlook die Sicherung anstoßen
'
Dim OLapp           As Outlook.Application  ' neu mit V2.4
Dim OLns            As Outlook.NameSpace    ' neu mit V2.4
Dim mf              As MAPIFolder
Dim ff              As Folders
Dim dLastRun        As Date
Dim sTarget         As String
Dim iCntDF          As Integer
Dim iHandle         As Integer
Dim sControlFile    As String
Dim sPositionFile   As String
Dim iHandleAction   As Integer
Dim sActionFile     As String
Dim sLogFile        As String
Dim iFormTop        As Integer
Dim iFormLeft       As Integer
Dim iSl             As Integer
Dim sDir            As String

    On Error GoTo ErrQuit
    '
    bCancelSave = False
    '
    '   Outlook-Version ermitteln, um auf notwendige
    '   Unterschiede reagieren zu können
    '
    iOLversion = intAppVersion
    '
    '   den Basisordner (über alle Ebenen) erstellen,
    '   wenn noch nicht vorhanden
    '
    For iSl = 4 To Len(cSaveBase)
        If Mid(cSaveBase, iSl, 1) = "\" Then
            sDir = Left(cSaveBase, iSl - 1)
            If Len(Dir(sDir, vbDirectory)) = 0 Then
                MkDir sDir
            End If
        End If
    Next iSl
    If Len(Dir(cSaveBase, vbDirectory)) = 0 Then
        MkDir cSaveBase
    End If
    '
    '   Das Fortschrittsformular laden
    '
    Load frmProgress
    '
    '   Prüfen, ob schon eine Position für das
    '   Formular gespeichert ist.
    '   Dann daraus die Koordinaten entnehmen.
    '   Sonst Default-Werte errechnen.
    '
    sPositionFile = FormPosFile
    If Len(Dir(sPositionFile)) > 0 Then
        iHandle = FreeFile
        Open sPositionFile For Input As #iHandle
        Input #iHandle, iFormLeft
        Input #iHandle, iFormTop
        Close #iHandle
    Else
        iFormLeft = (ScreenX - frmProgress.Width) / 2
        iFormTop = (ScreenY - frmProgress.Height) / 2
    End If
    '
    '   Das Fortschrittsformular positionieren
    '
    frmProgress.Move iFormLeft, iFormTop
    '
    '   Dateinamen festlegen
    '
    sControlFile = cSaveBase & cBS & cControlFileName
    sActionFile = cSaveBase & cBS & cLogActionName
    sLogFile = cSaveBase & cBS & cLogFileName
    '
    '   Prüfen, ob schon ein Sicherungslauf stattgefunden hat.
    '   Wenn nein, dann Startdatum='Gestern' setzen
    '
    If Len(Dir(sControlFile)) > 0 Then
        iHandle = FreeFile
        Open sControlFile For Input As #iHandle
        Input #iHandle, dLastRun
        '
        '   aus der zweiten Zeile die letzte Mail-Anzahl auslesen
        '   um damit einen ca. Fortschrittswert zu erzeugen
        '
        Input #iHandle, lCntItemsPrevRun
        Close #iHandle
    Else
        dLastRun = DateAdd("d", -1, Now)
        lCntItemsPrevRun = 100
    End If
    '
    '   Prüfen, ob heute schon ein Sicherungslauf stattgefunden hat.
    '   Wenn ja+Flag gesetzt, dann ist sofort Schluss
    '
    If DateDiff("d", Date, dLastRun) = 0 And cOnceADay Then
        Unload frmProgress
        Exit Sub
    End If
    '
    '   Das ActionLog ggf. öffnen
    '
    If cLogAction Then
        iHandleAction = FreeFile
        If Len(Dir(sActionFile)) = 0 Then
            Open sActionFile For Output As #iHandleAction
            Print #iHandleAction, "Zeitpunkt;PST;Ordner;Aktion;Betreff"
        Else
            Open sActionFile For Append As #iHandleAction
        End If
    End If
    '
    '   Das Fortschrittsformular anzeigen
    '
    frmProgress.Show (False)
    '
    '   Initialisierungen
    '
    sTarget = GetSaveFolder
    iLevel = 0
    iLevelMax = 0
    lCntDatafile = 0
    lCntFolder = 0
    lCntItems = 0
    lSavItems = 0
    lDelItems = 0
    lSavAtt = 0
    iCntDF = 0
    '
    '   Haupt-Schleife über alle Ordner der obersten Ebene
    '   ab 2.4: Nutzung von OLns, damits auch mit OL2000 klappt
    '
    Set OLapp = New Outlook.Application
    Set OLns = OLapp.GetNamespace("MAPI")
    lCntDatafile = OLns.Folders.Count 'Application.GetNamespace("MAPI").Folders.Count
    For Each mf In OLns.Folders 'Application.GetNamespace("MAPI").Folders --> hat bei OL2000/OLXP einen Fehler verursacht
        iCntDF = iCntDF + 1
        '
        '   aktuelles Datafile anzeigen
        '
        frmProgress.lblDatafile.Caption = iCntDF & "/" & lCntDatafile & ": " & mf.Name
        sPST = mf.Name
        frmProgress.lblMsg.Caption = "Verarbeite PST... " & sPST
        frmProgress.Repaint
        '
        '   In dieser Prozedur wird die eigentliche
        '   Arbeit (rekursiv) verrichtet
        '
        If bCancelSave Then Exit For
        Call ListSubFolders(dLastRun, sTarget, mf, iHandleAction)
        If bCancelSave Then Exit For
    Next mf
    frmProgress.lblMsg.Caption = "Verarbeitung beendet"
    '
    '   Abbruch ?
    '
    If bCancelSave Then
        frmProgress.lblDatafile.Caption = "Vorgang wurde durch Benutzer abgebrochen"
        frmProgress.Repaint
        If cLogAction Then
            Print #iHandleAction, Now & cSK & _
                sPST & cSK & cSK & "Cancel" & cSK & frmProgress.lblDatafile.Caption
            Close #iHandleAction
        End If
        Exit Sub
    End If
    frmProgress.lblDatafile.Caption = "Sicherung ist jetzt beendet"
    frmProgress.Repaint
    '
    '   Wegschreiben des Laufdatums (Zeile 1)
    '   Wegschreiben der aktuellen Mailanzahl (Zeile 2)
    '
    iHandle = FreeFile
    Open sControlFile For Output As iHandle
    Write #iHandle, Now
    Write #iHandle, lCntItems
    Close #iHandle
    '
    '   Fort-Schreiben der Protokolldatei mit 6 Spalten
    '   1.  Zeitstempel
    '   2.  Anzahl besuchter Ordner
    '   3.  Anzahl besuchter Mail-Items
    '   4.  Anzahl gesicherter Mail-Items
    '   5.  Anzahl gesicherter Anhänge
    '   6.  Maximal erreichte Rekursionstiefe
    '   7.  Anzahl gelöschter Mail-Items
    '
    '   Wenn die Datei noch nicht vorhanden ist,
    '   die Titelzeile hineinschreiben
    '
    iHandle = FreeFile
    If Len(Dir(sLogFile)) = 0 Then
        Open sLogFile For Output As iHandle
        Print #iHandle, "Zeitpunkt;Anzahl Ordner;Anzahl Mails;Mails gesichert;Anhänge gesichert;Rekursionstiefe;Mails gelöscht"
        Close #iHandle
    End If
    '
    Open sLogFile For Append As iHandle
    Print #iHandle, Now & cSK & lCntFolder & cSK & lCntItems & cSK & lSavItems & cSK & lSavAtt & cSK & iLevelMax & cSK & lDelItems
    Close #iHandle
    '
    '   Action-Log schließen
    '
    If cLogAction Then
        Close #iHandleAction
    End If
    Set OLns = Nothing
    Set OLapp = Nothing

ExitQuit:
    Unload frmProgress
    Exit Sub

ErrQuit:
    Select Case Err.Number
    Case Else
        MsgBox Err.Description, vbCritical, Me.Name
        Resume ExitQuit
    End Select
    Resume 'debug only

End Sub
Private Sub ListSubFolders(dFrom As Date, sTarget As String, f As MAPIFolder, iHandleAction As Integer)
'
'   Unterordner nach zu sichernden Mails durchsuchen
'   und ggf. weitere Unterodner rekursiv durchsuchen
'
'   Parameter:
'   dFrom       Nur Mails die nach diesem Datum in Outlook erstellt wurden
'   sTarget     Verzeichnis, in welches gesichert wird
'   f           Ordner, der aktuell durchsucht werden soll
'
Dim mf              As MAPIFolder
Dim mi              As MailItem
Dim oitms           As Outlook.Items
Dim i               As Integer
Dim j               As Integer
Dim k               As Integer
Dim iDays4Delete    As Integer
Dim iAnzAtt         As Integer
Dim sSaveAs         As String
Dim sEmailAddress   As String
Dim sEmailDir       As String

    On Error GoTo ErrListFolder
    '
    '   maximale Rekursionstiefe für das Protokoll ermitteln
    '   -hat nur statistischen Wert-
    '
    iLevel = iLevel + 1
    If iLevel > iLevelMax Then
        iLevelMax = iLevel
    End If
    '
    '   gehe durch alle Unter-Ordner des übergebenen Ordners
    '
    For Each mf In f.Folders
        lCntFolder = lCntFolder + 1
        '
        '   Nur die (Unter-) Ordner berücksichtigen,
        '   die ein DeleteAfter-Flag gesetzt haben
        '
        k = InStr(mf.Description, cDeleteAfter)
        If k > 0 Then
            '
            '   Die Lösch-Tage müssen 2-stellig eingetragen sein
            '
            If IsNumeric(Mid(mf.Description, k + Len(cDeleteAfter), 2)) Then
                iDays4Delete = Mid(mf.Description, k + Len(cDeleteAfter), 2)
                Set oitms = mf.Items
                Set mi = mf.Items.GetFirst
                '
                '   Schleife über alle Mail-Items
                '
                Do While Not mi Is Nothing
                    '
                    '   nur die Nicht-Markierten beachten
                    '
                    If mi.FlagStatus = olNoFlag Then
                        If mi.CreationTime < DateAdd("d", -iDays4Delete, Date) Then
                            '
                            '   Löschen, wenn älter als 'iDays4Delete'
                            '
                            frmProgress.lblMsg.Caption = "Lösche... " & mi.Subject
                            frmProgress.Repaint
                            If iHandleAction > 0 Then
                                Print #iHandleAction, Now & cSK & sPST & cSK & _
                                    mf.Name & cSK & "Delete" & cSK & mi.Subject
                            End If
                            lDelItems = lDelItems + 1
                            mi.Delete
                            DoEvents
                        Else
                            'Debug.Print mi.CreationTime
                        End If
                    Else
                        'Debug.Print mi.Subject, mi.CreationTime, mi.FlagStatus
                    End If ' no Flag
                    If bCancelSave Then Exit Do
                    Set mi = oitms.GetNext
                Loop
                Set mi = Nothing ' entsorgen
                '
                '   Abbruch ?
                '
                If bCancelSave Then
                    frmProgress.lblDatafile.Caption = "Vorgang wurde durch Benutzer abgebrochen"
                    frmProgress.Repaint
                    iLevel = iLevel - 1         ' Rekursionstiefe vermindern
                    Exit Sub
                End If
            Else
                'Stop
            End If 'numeric
        End If 'k>0
        '
        '   Nur die (Unter-) Ordner berücksichtigen,
        '   die kein NoBackUp-Flag gesetzt haben
        '
        If InStr(mf.Description, cNoBackUp) = 0 Then
            '
            '   Nur die ungelesenen oder alle ...
            '   Achtung: Laufzeit bei 'alle'
            '
            If mf.UnReadItemCount > 0 Or cReadAndUnread Then
                i = mf.Items.Count
                Set oitms = mf.Items
                Set mi = mf.Items.GetFirst
                '
                '   Schleife über alle Mail-Items
                '
                Do While Not mi Is Nothing
                    lCntItems = lCntItems + 1
                    If Modulo(lCntItems, cModuloCnt) Then
                        frmProgress.lblCounter.Caption = Format(lCntItems, "#,##0")
                        frmProgress.lblProzent.Caption = Format(lCntItems / lCntItemsPrevRun, "0%")
                        frmProgress.Repaint
                        DoEvents
                    End If
                    '
                    '   Nur die ungelesenen oder alle ...
                    '
                    If mi.UnRead Or cReadAndUnread Then
                        '
                        '   Nur die sichern, die seit dem letzten
                        '   Lauf (in Outlook) erzeugt wurden
                        '
                        If mi.CreationTime > dFrom Then
                            '
                            '   Ab 2.4: Prüfung auf sent
                            '
                            If mi.Sent Then
                                '
                                '   Ab 2.4: Prüfung auf Unterschiede in den Outlook-Versionen
                                '
                                If iOLversion < 10 Then
                                    sEmailAddress = ProperName(mi.SenderName)
                                Else
                                    sEmailAddress = ProperName(mi.SenderEmailAddress)
                                End If
                            Else
                                sEmailAddress = cNotSentYet
                            End If
                            'sEmailAddress = ProperName(mi.SenderEmailAddress)
                            sEmailDir = sTarget & cBS & sEmailAddress
                            sSaveAs = sEmailDir & cSepSubject & _
                                ProperName(mi.Subject) & ".msg"
                            '
                            '   ggf. EMail-Directory erzeugen
                            '
                            If cSepSubject = cBS Then
                                If Len(Dir(sEmailDir, vbDirectory)) = 0 Then
                                    MkDir sEmailDir
                                End If
                            End If
                            '
                            '   Nachricht speichern
                            '
                            If Len(Dir(sSaveAs)) = 0 Then
                                frmProgress.lblMsg.Caption = "Sichere... " & mi.Subject
                                If cLogAction Then
                                    Print #iHandleAction, Now & cSK & sPST & cSK & _
                                        mf.Name & cSK & "SaveAs" & cSK & mi.Subject
                                End If
                                frmProgress.Repaint
                                mi.SaveAs sSaveAs, olMSG
                                lSavItems = lSavItems + 1
                            End If
                            '
                            '   Anlagen extra speichern
                            '
                            iAnzAtt = mi.Attachments.Count
                            If iAnzAtt > 0 Then
                                For j = 1 To iAnzAtt
                                    '
                                    '   je nach Separator die Attachments
                                    '   ggf. ein Level höher oder tiefer
                                    '   abspeichern
                                    '
                                    If cSepSubject <> cBS Then
                                        sSaveAs = sTarget & cBS & _
                                            mi.Attachments.Item(j).FileName
                                    Else
                                        sSaveAs = sEmailDir & _
                                            cSepSubject & _
                                            mi.Attachments.Item(j).FileName
                                    End If
                                    If Len(Dir(sSaveAs)) = 0 Then
                                        mi.Attachments.Item(j).SaveAsFile sSaveAs
                                        If cLogAction Then
                                            Print #iHandleAction, Now & cSK & sPST & _
                                                cSK & mf.Name & cSK & "SaveAtt" & cSK & sSaveAs
                                        End If
                                        lSavAtt = lSavAtt + 1
                                    End If
                                Next j
                            End If
                        End If
                    End If
                    If bCancelSave Then Exit Do
                    Set mi = oitms.GetNext
                Loop
                Set mi = Nothing ' entsorgen
            End If
        End If
        If bCancelSave Then Exit For
        '
        '   weitere Unter-Ordner rekursiv durchsuchen
        '
        Call ListSubFolders(dFrom, sTarget, mf, iHandleAction)
        If bCancelSave Then Exit For
    Next mf

ExitListFolder:
    iLevel = iLevel - 1         ' Rekursionstiefe vermindern
    Exit Sub

ErrListFolder:
    '
    '   Warum dieser Fehler bei einigen sehr alten
    '   Mails auftritt, ist mir nicht ganz klar
    '   Er wird hier auf jeden Fall ignoriert
    '
    If Err.Number = 13 Then
        Resume Next
    Else
        MsgBox Err.Description
        Resume ExitListFolder
    End If
    Resume 'debug only
End Sub
Private Function ProperName(sIn As String) As String
'
'   Einen 'erlaubten' Dateinamen bilden
'
Dim sTmp As String

    sTmp = sIn
    sTmp = Replace(sTmp, "/", cUS)
    sTmp = Replace(sTmp, "\", cUS)
    sTmp = Replace(sTmp, "*", cUS)
    sTmp = Replace(sTmp, "?", cUS)
    sTmp = Replace(sTmp, """", cUS)
    sTmp = Replace(sTmp, "<", cUS)
    sTmp = Replace(sTmp, ">", cUS)
    sTmp = Replace(sTmp, "|", cUS)
    sTmp = Replace(sTmp, ":", cUS)
    
    ProperName = sTmp
End Function
Private Function GetSaveFolder(Optional sBase As String = cSaveBase) As String
'
'   Speicherordner ermitteln bzw. erzeugen
'
'-u-01.03.2006  Aufteilung der Folder-Prüfung in mehrere Schritte
'
Dim sSaveFolder As String
    
    On Error GoTo ErrGetSaveFolder
    '
    '   ggf. ein abschließendes \ anfügen
    '
    If Right(sBase, 1) <> cBS Then
        sBase = sBase & cBS
    End If
    '
    '   Schritt 1: Jahresordner
    '
    sSaveFolder = sBase & Format(Date, "yyyy")
    '
    '   den neuen Jahresordner nur erstellen,
    '   wenn noch nicht vorhanden
    '
    If Len(Dir(sSaveFolder, vbDirectory)) = 0 Then
        MkDir sSaveFolder
    End If
    '
    '   Schritt 2: Monatsordner
    '
    sSaveFolder = sSaveFolder & cBS & Format(Date, "mm")
    '
    '   den neuen Monatsordner nur erstellen,
    '   wenn noch nicht vorhanden
    '
    If Len(Dir(sSaveFolder, vbDirectory)) = 0 Then
        MkDir sSaveFolder
    End If
    '
    '   Schritt 2: Tagesordner
    '
    sSaveFolder = sSaveFolder & cBS & Format(Date, "dd")
    '
    '   den neuen Archivordner nur erstellen,
    '   wenn noch nicht vorhanden
    '
    If Len(Dir(sSaveFolder, vbDirectory)) = 0 Then
        MkDir sSaveFolder
    End If
    '
    '   Ergebnis abliefern
    '
    GetSaveFolder = sSaveFolder
    
ExitGetSaveFolder:
    Exit Function

ErrGetSaveFolder:
    '
    MsgBox Err.Description, vbCritical, cModule & cBL & cVersion & ": GetSaveFolder"
    Resume ExitGetSaveFolder
    Resume 'debug only
    
End Function
Function Modulo(lAkt As Long, lFix As Long) As Boolean
    
    If Int(lAkt / lFix) - (lAkt / lFix) = 0 Then
        Modulo = True
    Else
        Modulo = False
    End If
    
End Function
Public Function khoSAMversion() As String
    khoSAMversion = cModule & " V" & cVersion & " vom " & cVersionDate
End Function
Public Function FormPosFile() As String
    FormPosFile = cSaveBase & cBS & cFormPosName
End Function
zurück Copyright: Karl-Holger Osterbuhr 2005-2008 - Alle Rechte vorbehalten Stand: 06.04.2008