Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0708: Dateien verkürzen ohne zu kopieren

VB 5/6-Tipp 0708: Dateien verkürzen ohne zu kopieren

 von Klaus Langbein

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CloseHandle, CreateFileA (CreateFile), SetEndOfFile, SetFilePointer

Download: Download des Beispielprojektes [6,1 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Schaltfläche "Command6"
' Steuerelement: Schaltfläche "Command5"
' Steuerelement: Schaltfläche "Command4"
' Steuerelement: Schaltfläche "Command3"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Linien-Steuerelement "Line1" (Index von 0 bis 1)
'
' Autor: K. Langbein Klaus@ActiveVB.de
'
' Beschreibung:
'
' Dateien verkürzen
'
' Manchmal kommt es vor dass das Ergebnis einer Dateibearbeitung zu
' einer Dateilänge führt, die kürzer ist, als die Länge des Originals.
' Da VB keine Möglichkeit bietet, eine Datei zu verkürzen, behilft man
' sich meist damit, das Ergebnis in eine neue Datei umzuspeichern, was
' jedoch zeitaufwändig ist. Will man z.B. ein Byte aus einer Binärdatei
' entfernen, so öffnet man üblicherweise eine 2. Datei, liest den Bereich
' vor dem zu entfernenden Byte per Get ein, schreibt ihn per Put in die
' 2. Datei, liest dann den Bereich nach dem zu entfernenden Zeichen ein
' und schreibt diesen ebenfalls in die 2. Datei. Anschließend wird die
' ursprüngliche Datei gelöscht werden und die neue datei erhält den Namen
' des Originals.
' Mit Hilfe des API-Befehls SetEndOfFile kann eine Datei jedoch auf eine
' neue Länge gestutzt werden, d.h. überschüssige Bytes können  abgeschnitten
' werden, so dass man ausschließlich mit einer Datei arbeiten kann. Dies ist
' insbesondere dann von Vorteil, wenn es sich um sehr große Dateien handelt.

Option Explicit

Private Const GENERIC_WRITE As Long = &H40000000
Private Const GENERIC_READ As Long = &H80000000
Private Const CREATE_ALWAYS As Long = 2&
Private Const OPEN_ALWAYS As Long = 4&
Private Const INVALID_HANDLE_VALUE As Long = -1&
Private Const FILE_BEGIN As Long = 0&

Private Const FILE_ATTRIBUTE_HIDDEN As Long = &H2&
Private Const FILE_ATTRIBUTE_NORMAL As Long = &H80&
Private Const FILE_ATTRIBUTE_READONLY As Long = &H1&
Private Const FILE_ATTRIBUTE_SYSTEM As Long = &H4&
Private Const FILE_ATTRIBUTE_TEMPORARY As Long = &H100&

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" ( _
                         ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _
                         ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, _
                         ByVal dwCreationDisposition As Long, _
                         ByVal dwFlagsAndAttributes As Long, _
                         ByVal hTemplateFile As Long) As Long
                         
Private Declare Function SetFilePointer Lib "kernel32" ( _
                         ByVal hFile As Long, ByVal lDistanceToMove As Long, _
                         lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
                         
Private Declare Function SetEndOfFile Lib "kernel32" (ByVal hFile As Long) As Long

Dim fname As String
Dim l As Long
Private Function DeleteBytesFromFile(ByVal fname As String, _
                                     ByVal PosStart As Long, _
                                     ByVal nBytes As Long) _
                                     As Long
                                     
    Dim Buffer As String
    Dim fno As Long
    Dim lOld As Long
    Dim lNew As Long
    Dim ret As Long
    
    fno = FreeFile
    Open fname For Binary As #fno
    lOld = LOF(fno)
    
    Buffer = Space$(lOld - (PosStart + nBytes) + 1)
    
    Get #fno, PosStart + nBytes, Buffer
    Put #fno, PosStart, Buffer
    Close #fno
    lNew = lOld - nBytes
    ret = TruncateFile(fname, lNew)
    DeleteBytesFromFile = lNew
    
End Function

Function ReplaceInFile(ByVal FileName As String, ByVal OldString As String, _
    ByVal NewString As String) As Long

    Dim Text As String
    Dim fno As Long
    Dim lOld As Long
    Dim lNew As Long
    Dim ret As Long
    
    lOld = FileLen(FileName)
    fno = FreeFile

    Open FileName For Binary As fno
    Text = Space$(lOld)
    
    Get #fno, 1, Text
    Text = Replace(Text, OldString, NewString)
    Put #fno, 1, Text
    lNew = Seek(fno) - 1 ' Neue Länge berechnen. Der Dateizeiger steht
    Close #fno           ' immer hinter dem bereits beschriebenen Bereich.
    
    If lNew < lOld Then
        ' Wenn die neue Länge kleiner ist, verkürzen wir die Datei. Sie
        ' muß jedoch vorher geschlossen werden, das sie per API erneut
        ' geöffnet wird.
        ret = TruncateFile(FileName, lNew, FILE_ATTRIBUTE_NORMAL, True)
    End If
    ReplaceInFile = FileLen(FileName)

End Function





Function ReplaceInFileVB(ByVal FileName As String, ByVal OldString As String, _
    ByVal NewString As String) As Long

    ' Hier zum Vergleich die VB-Methode. Unter VB gibt es keine
    ' Möglichkeit eine bestehende Datei zu verkürzen.

    Dim Text As String
    Dim fno As Long
    Dim lOld As Long
    Dim lNew As Long
       
    lOld = FileLen(FileName)
    fno = FreeFile
    Open FileName For Binary As fno
    
    Text = Space$(lOld)
    Get #fno, 1, Text
    Text = Replace(Text, OldString, NewString)

    If lNew < lOld Then    ' Wenn die neue Länge kleiner ist, als die des
        Close #fno         ' Originals, muß man eine neue Datei erzeugen, um
        Kill FileName     ' die Dateilänge zurückzusetzen. Bei sehr großen
        fno = FreeFile     ' Dateien (100 MB) sollte man 2 Dateien offen-
        Open FileName For Binary As fno 'halten, um umzuspeichern.
    End If
    
    Put #fno, 1, Text
    Close #1
    ReplaceInFileVB = FileLen(FileName)

End Function

Private Function TruncateFile(ByVal FileName As String, _
                              ByVal NewLength As Long, _
                              Optional ByVal Attrib As Long _
                              = FILE_ATTRIBUTE_NORMAL, _
                              Optional ByVal RaiseError As Boolean _
                              ) As Long
    
    If RaiseError = False Then ' Wahlweise lösen wir einen Fehler aus
        On Error Goto err1     ' oder geben nur eine Fehlernr. zurück.
    End If
    
    Dim hFile As Long
    Dim FDate As String
    Dim ret As Long

    ' Wir verwenden FileDatetime um zu überprüfen, ob die Datei existiert.
    ' Dies ist günstiger, als Dir$(), da so auch falsche Pfade einen Fehler
    ' auslösen (was hier erwünscht ist).
    FDate = FileDateTime(FileName)
    
    ' Falls kein Fehler aufgetreten ist, wird die Datei geöffnet und wir
    ' erhalten ein Handle.
    hFile = CreateFile(FileName, GENERIC_WRITE Or GENERIC_READ, _
                       0, 0, OPEN_ALWAYS, Attrib, 0)
                       
    'Falls kein Handle zurückgegeben wird, lösen wir einen Fehler aus
    ' und/oder geben eine Fehlernr. zurück.
    If (hFile = 0) Or (hFile = INVALID_HANDLE_VALUE) Then
        ret = -1
        If RaiseError = True Then  ' Falls erwünscht, lösen wir einen Fehler
            Err.Raise 70           ' aus, der in der aufrufenden Funktion so
        End If                     ' behandelt, wird, wie bei einem VB-Fehler
        Goto exi                   ' üblich.
    End If
    
    ' Jetzt wird der Dateizeiger an die gewünschte Stelle geschoben. Dies
    ' entspricht der Seek-Anweisung.
    ret = SetFilePointer(hFile, NewLength, 0, FILE_BEGIN)
    If ret = 0 Then
        ret = -2                ' Falls SetFilePointer erfolglos war,
        Call CloseHandle(hFile) ' machen wir zu und verlassen die
        Goto exi                ' Funktion.
    End If
    
    ' Per SetEndOfFile wird die Datei an der aktuellen Position
    ' abgeschnitten.
    ret = SetEndOfFile(hFile)
    If ret = 0 Then
        ret = -3                ' falls erfolglos, was unwahrscheinlich,
        Call CloseHandle(hFile) ' ist schließen und verlassen.
        Goto exi
    End If
    
    ' Wenn kein Fehler auftrat, schließen wir das Handle hier.
    ret = CloseHandle(hFile)
    If ret = 0 Then
        ret = -4
    End If
    
exi:
    
    TruncateFile = ret
    Exit Function
    
err1:
    Select Case Err
    
    Case 53
        ret = Err * -1
        Resume exi
    Case 76
        ret = Err * -1
        Resume exi
    Case Else
        'MsgBox err & " " & Error$
    End Select
    
End Function


Private Sub Command1_Click()
    
    On Error Goto err1
        
    Dim fname As String
    Dim l As Long
    
    ' Als Beispiel für eine Dateibearbeitung, die zu einer Verringerung
    ' der Länge führt, wandeln wir hier normalen Text, welcher vbCrLf
    ' (Chr$(13) & Chr$(10)) als Zeilentrennzeichen enthält in das
    ' Unix-Format um, wo ein Zeilenende nur durch ein vbLF (Chr$(10))
    ' markiert wird.
    
    fname = App.Path + "\Beispiel.txt"
    MsgBox "Dateilänge: " & FileLen(fname)
    l = ReplaceInFile(fname, vbCrLf, vbLf)
    MsgBox "Neue Dateilänge: " & l
    Exit Sub
    
err1:
    MsgBox Error
    
End Sub

Private Sub Command2_Click()
    
    Dim fname As String
    Dim l As Long
    
    ' Und das Ganze rückgängig machen:
    
    fname = App.Path + "\Beispiel.txt"
    MsgBox "Dateilänge: " & FileLen(fname)
    l = ReplaceInFile(fname, vbLf, vbCrLf)
    MsgBox "Neue Dateilänge: " & l
    
End Sub

Private Sub Command3_Click()
    
    On Error Goto err1
        
    Dim fname As String
    Dim l As Long
    
    ' Dies nur zum Vergleich:
    
    fname = App.Path + "\Beispiel.txt"
    MsgBox "Dateilänge: " & FileLen(fname)
    l = ReplaceInFileVB(fname, vbCrLf, vbLf)
    MsgBox "Neue Dateilänge: " & l
    
    Exit Sub
    
err1:
    MsgBox Error
    
End Sub


Private Sub Command4_Click()
    
    fname = App.Path + "\Beispiel.txt"
    MsgBox "Dateilänge: " & FileLen(fname)
    l = ReplaceInFileVB(fname, vbLf, vbCrLf)
    MsgBox "Neue Dateilänge: " & l
    
End Sub

Private Sub Command5_Click()

    ' Als weitere Anwendung der Funktion TruncateFile, bzw.
    ' DeleteBytesFromFile entfernen wir hier ein paar Byte
    ' aus einer Datei.

    Dim fno As Long
    Dim Buffer As String
    Dim pos As Long
    Dim Remove As String

    
    ' Wir suchen zunächst mal nach dem zu entfernenden String:
    Remove = "**********"
    
    fno = FreeFile
    fname = App.Path + "\Beispiel.txt"
    Open fname For Binary As #1
    Buffer = Space$(LOF(fno))
    Get #fno, 1, Buffer
    Close #fno
 
    MsgBox "Dateilänge: " & FileLen(fname)
    
    pos = InStr(Buffer, Remove)
    If pos > 0 Then
        ' Falls der String vorhanden ist, entfernen wir ihn
        l = DeleteBytesFromFile(fname, pos, Len(Remove))
    End If
    MsgBox "Neue Dateilänge: " & FileLen(fname)
    
    
End Sub

Private Sub Command6_Click()
    
    MsgBox "Zur Übung selber programmieren :-)", vbInformation
    
End Sub

'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Project1.vbp --------------