Zufälliger Artikel

 Problemstellung:

Manchmal ist es erforderlich alte Dateien zu löschen, egal ob es alte Import-, Sicherungsdateien o.ä. sind.
Jetzt möchte man aber die zu löschenden Dateien einschränken, ob nun nach Dateinamen und/oder Dateidatum,
mit Unterverzeichnissen oder ohne.

Für dieses Problem möchte ich hier eine Lösung vorstellen.

Es ist eine Mischung aus FileSystemObject(FSO)- und API-Funktionen.

1. API-Aufrufe zum Löschen der Dateien

Hier kommt die API-Funktion "SHFileOperation" zum Einsatz

1.1. Declare- und Konstantendeklaration

Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" ( _
ByRef lpFileOp As SHFILEOPSTRUCT) As Long
Private Type SHFILEOPSTRUCT
   hWnd As Long
   wFunc As Long
   pFrom As String
   pTo As String
   fFlags As Integer
   fAnyOperationsAborted As Long
   hNameMappings As Long
   lpszProgressTitle As String
End Type
Private Const FO_DELETE = &H3&
Private Const FOF_ALLOWUNDO = &H40&
Private Const FOF_NOCONFIRMATION = &H10

Wobei die Konstante

Private Const FOF_ALLOWUNDO = &H40&

dafür zuständig ist das die gelöschten Dateien im Papierkorb landen

und die Konstante

Private Const FOF_NOCONFIRMATION = &H10&

die Bestätigung jeder Dateilöschung deaktiviert.

Dies rufen wir dann in dieser Sub auf:

1.2. Dateien in den Papierkorb löschen

Private Sub Delete_to_Trash(sFilename As String)
   Dim udtFileStructure As SHFILEOPSTRUCT
   With udtFileStructure
     .wFunc = FO_DELETE
     .pFrom = sFilename
     .fFlags = FOF_ALLOWUNDO Or FOF_NOCONFIRMATION
   End With
   SHFileOperation udtFileStructure
End Sub

2. Lesen der Dateien mit FSO, prüfen der Kriterien und löschen der Dateien

Die folgende Sub macht dann die eigentliche Arbeit

Public Sub DeleteCriteriaFiles(sPath As String, Optional sCriteria As String = "*.*", _
                               Optional dtCriteriaDate As String = "", _
                               Optional bSubFolder As Boolean = False)
    Dim oFSO As New FileSystemObject
    Dim oFolder As Folder
    Dim oSubFolders As Object, oSubFolder As Folder
    Dim oFile As File
    Set oFolder = oFSO.GetFolder(sPath)
    For Each oFile In oFolder.Files
        If oFile.Name Like sCriteria = True Then
            If dtCriteriaDate <> "" Then
                'Datumskriterium vorhanden
                If CDate(Left(oFile.DateLastModified, 10)) <= CDate(dtCriteriaDate) Then Delete_to_Trash oFile.Path
            Else
                'Datumskriterium nicht vorhanden
                Delete_to_Trash oFile.Path
            End If
        End If
    Next oFile
    'Unterverzeichnisse einbeziehen
    If bSubFolder = True Then
        Set oSubFolders = oFolder.SubFolders
        For Each oSubFolder In oSubFolders
            DeleteCriteriaFiles oSubFolder.Path, sCriteria, dtCriteriaDate, bSubFolder
        Next oSubFolder
    End If
    Set oFile = Nothing: Set oSubFolders = Nothing
    Set oFolder = Nothing: Set oSubFolder = Nothing
    Set oFSO = Nothing
End Sub

Folgende Parameter werden der Prozedur übergeben:

sPath As String

Der komplette Pfad des betreffenden Verzeichnisses mit abschliessenden Backslash

Optional sCriteria As String = "*.*" 

Das Filterkriterium für die Dateinamen, Standard = Alle (*.*)

Optional dtCriteriaDate As String = "" 

Das Filterkriterium für das Dateidatum Standard = Kein ("")
Bei einer Angabe eines Datums werden alle Dateien deren letztes Änderungsdatum <= dem Kriterium entspricht gelöscht.
Wird etwas anderes gewünscht muss diese Zeile angepasst werden:

If CDate(Left(oFile.DateLastModified, 10)) <= CDate(dtCriteriaDate) Then Delete_to_Trash oFile.Path
Optional bSubFolder As Boolean = False

Sollen Unterverzeichnisse einbezogen werden? Standard = Nein (False)
 
Der Aufruf z.B.:

DeleteCriteriaFiles "D:\users\Test0\", "*.txt", "01.09.2010", True 
 
Würde aus dem Verzeichnis "D:\Users\Test0", mit Unterverzeichnissen, alle txt-Dateien löschen deren letztes Änderungsdatum
kleiner gleich dem 01.09.2010 ist.
 

Ähnliche Artikel

Home

1 1 1 1 1 1 1 1 1 1 Rating 0.00 (0 Votes)

Problemstellung:
Bezugnehmend auf den Beitrag
Access-DB als Demo weitergeben
hab ich mal den Faden weiter gesponnen um das Demo mit einem Lizenzschlüssel freizuschalten.
Ich gehe aber hier nur auf die Registry-Lösung ein (mit der Property-Lösung ist aber genau so möglich).
Auch ist in der Bsp-DB nur die Möglichkeit der zeitlichen Limitierung enthalten, die Lösung mit der
Anzahl der DB-Starts funktioniert äquvivalent.

Voraussetzungen:
Das Bsp ist ab A00 lauffähig.

Funktionsweise:
In der Datei "tk_Lizenzverwaltung00.mdb" besteht die Möglichkeit mehrere Projekte zu verwalten.
Die MDB ist sehr einfach aufgebaut und nur zur Demonstration.
Im Formulare werden im HFO nur der Programmname und das Passwort festgelegt.




Das Kennwort ist das, welches dann im eigentlichen Programm als globale Konstante gesetzt wird.
Dieses Kennwort wird zur Verschlüsselung der Angaben benötigt.
Durch verschiedene Kennwörter kommt bei gleichen Usern niemals der gleiche Schlüssel raus.
Sprich bei verschiedenen Programmen muss nur immer ein anderes Kennwort festgelegt werden.
Möchte ein User das Programm lizenzieren, muss er seinen Namen und seine E-Mail Adresse angeben.
Daraus berechnet das Programm einen 16stelligen Schlüssel.
Ansicht des Feldes in der Abfrage:

UserKey: Hex$(CRC32Unicode(Encrypt([Username];[ProgrammPWD]))) & "-" & Hex$(CRC32Unicode(Encrypt([User_EMail];[ProgrammPWD])))

Zur Ausführung werden die Module "mod_CRC32" und "mod_Crypter" benötigt.
Den erhaltenen Schlüssel erhält dann der User an seine E-Mail Adresse zur Freischaltung und damit kommen wir zu Teil2.

Im Modul "mod_Crypter" wird die globale Konstante "sPWD" mit dem Kennwort der DB festgelegt.

Public Const sPWD As String = "geheim"


Beim ersten Starten der "tk_Freischaltung97" bzw. "tk_Freischaltung00" wird der Registerschlüssel für den
Benutzungszeitraum gesetzt. Näheres dazu s. hier
Access-DB als Demo weitergeben
Wenn jetzt ein User das Programm freischalten will fordert er einen Lizenzschlüssel an, s.o.
Nach Erhalt dieses Schlüssels kann dieser in das Registrierformular eingegeben werden.

Die Eingabe von Namen und E-Mail Adresse muss genauso erfolgen wie bei der Anforderung.
Auch ist die Groß- und Kleinschreibung zu beachten. Sind alle Angaben gemacht werden mit
dem Button „Registrieren“ alle Angaben geprüft.

Private Sub cmd_Reg_Click()
    Dim sTempKey As String
sTempKey = Hex$(CRC32Unicode(Encrypt(Me.txt_Name, sPWD))) & "-" & _
           Hex$(CRC32Unicode(Encrypt(Me.txt_Email, sPWD)))
    If sTempKey = Me.txt_RegKey Then
        MsgBox "Der eingegebene Registrierschlüssel ist richtig." &amp; vbNewLine &amp; _
               "Das Programm ist jetzt registriert.", vbInformation + vbOKOnly, "Fehler"
        fStringSpeichern HKEY_CURRENT_USER, "WinApp", "WinAppLUser", Me.txt_Name
        fStringSpeichern HKEY_CURRENT_USER, "WinApp", "WinAppEMailUser", Me.txt_Email
        fStringSpeichern HKEY_CURRENT_USER, "WinApp", "WinAppLKey", sTempKey
        DoCmd.Close
        Forms![frm_Start]![txt_Start].SetFocus
        Forms![frm_Start]![cmd_Reg].Enabled = False
    Else
        MsgBox "Der eingegebene Registrierschlüssel ist falsch." &amp; vbNewLine &amp; _
               "Bitte geben Sie den richtigen Schlüssel ein.", vbCritical + vbOKOnly, "Fehler"
    End If
End Sub


Es wird aus Name, E-Mail Adresse und Kennwort der Lizenzschlüssel gebildet und mit dem eingegebenen verglichen.
Stimmen beide überein werden die Angaben in die Registry geschrieben ansonsten ist die Registrierung fehlgeschlagen.


Beim nächsten Starten der DB werden die Schlüssel gesucht und geprüft. Ist alles o.k. startet das Programm ganz normal.
Wurde dagegen der Schlüssel manipuliert wird das Programm wieder in den Demo-Modus zurück gesetzt.

Private Sub Form_Load()
    On Error Resume Next
    Dim sDateTemp As String
    Dim intDays As Integer
    Dim sTemp As String, sTemp2 As String
    Dim sTemp3 As String, sTemp4 As String
    Dim sTempKey As String
    Dim sValue As String
    Dim dateTemp As Date
    sTemp = fWertLesen(HKEY_CURRENT_USER, "WinApp", "WinAppValue")
    sTemp2 = fWertLesen(HKEY_CURRENT_USER, "WinApp", "WinAppLKey")
    sTemp3 = fWertLesen(HKEY_CURRENT_USER, "WinApp", "WinAppLUser")
    sTemp4 = fWertLesen(HKEY_CURRENT_USER, "WinApp", "WinAppEMailUser")
    sValue = Encrypt(Day(Date) & Format(Month(Date), "00") & Year(Date), sPWD)
    If sTemp = "" Then
        fStringSpeichern HKEY_CURRENT_USER, "WinApp", "WinAppValue", sValue
        MsgBox "Sie können das Programm noch 30 Tage testen"
    Else
        If sTemp2 <> "" Or sTemp3 <> "" Or sTemp4 <> "" Then
            Me.cmd_Reg.Enabled = False
            sTempKey = Hex$(CRC32Unicode(Encrypt(sTemp3, sPWD))) & "-" & _
                       Hex$(CRC32Unicode(Encrypt(sTemp4, sPWD)))
            If sTempKey <> sTemp2 Then
                MsgBox "Der in der Registry vorhandene Schlüssel ist falsch." & vbNewLine & _
                       "Bitte geben Sie den richtigen Schlüssel neu ein.", vbCritical + vbOKOnly, "Fehler"
                fWerteLoeschen HKEY_CURRENT_USER, "WinApp", "WinAppLKey"
                fWerteLoeschen HKEY_CURRENT_USER, "WinApp", "WinAppLUser"
                fWerteLoeschen HKEY_CURRENT_USER, "WinApp", "WinAppEMailUser"
                Me.cmd_Reg.Enabled = True
            End If
        Else
            Me.cmd_Reg.Enabled = True
            sDateTemp = Decrypt(sTemp, sPWD)
            dateTemp = DateSerial(Right(sDateTemp, 2), Mid(sDateTemp, 3, 2), Left(sDateTemp, 2))
            intDays = DateDiff("d", Date, dateTemp)
            If intDays < (intCountDays * -1) Then
                MsgBox "Testzeitraum abgelaufen"
                DoCmd.Quit
            Else
                MsgBox "Sie können das Programm noch " & intCountDays + intDays & " Tage testen"
            End If
        End If
    End If
End Sub
Zusammenfassung:
Diese Lösung stellt keine ultimative Lösung und schon gar nicht den absoluten Schutz des Programms dar aber ist eine einfache Alternative.
Sinn würde der Einsatz nur in MDE-Dateien oder in MDB-Dateien mit geschütztem VBA-Code machen.

Dateien:

Demos von Access-DB's freischalten

ab A00

Die Zip-Datei enthält eine Version ab A00

Datum 05.02.2018
Dateigröße 93.15 KB
Download 2.075

Ähnliche Artikel

Kommentar schreiben

Sicherheitscode
Aktualisieren

Login Form

1.png1.png9.png1.png6.png6.png7.png
Heute1
Gestern84
Diese Woche224
Dieser Monat1600
Total1191667

  • IP: 54.161.45.156
  • Browser: Unknown
  • Version:
  • OS: Unknown

Online

1
Online

26. April 2018