MS-Outlook Mails und Anhänge ins Dateisystem exportieren
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