Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
bla
| Uploader: |  ThePuppetMaster |
| Datum/Zeit: | 02.07.2009 17:06:36 |
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "DP_Class"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_SHARE_READ = &H1
Private Const OPEN_EXISTING = &H3
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function SetEndOfFile Lib "kernel32" (ByVal hFile 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 CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Type DP_FileHeader_Type
T_InUse As Boolean
V_Crypted As String
V_FileName As String
V_Path As String
V_PathRelativ As Boolean
V_Filesize As Long
V_AddDate As String
V_Attribute As Long
V_DataPD() As Long
V_DataC As Long
End Type
Private Type DP_InfoHeader_Type
V_Blocksize As Byte
V_Locked As Boolean
V_CreateDate As String
V_Compressed As Boolean
V_Author As String
V_Copyright As String
V_Informations As String
V_PassProtect As String
V_FileD() As DP_FileHeader_Type
V_FileC As Long
V_FreePD() As Long
V_FreeC As Long
T_FileC As Long
End Type
Private DP_Path As String
Private DP_InfoHeader As DP_InfoHeader_Type
Private DP_Change As Boolean
Private DP_BlockCount As Long
Private DP_FileLen As Long
Private DP_FN As Integer
Private XTot As Double
Private XTotN As Double
Public Event DPProgressMax(V_ID As Long, V_Max As Long)
Public Event DPProgressValue(V_ID As Long, V_Value As Long)
Public Event DPState(V_ID As Long, V_Data As String)
Private Function ErrC() As Boolean
ErrC = False
If Err.Number <> 0 Then
ErrC = True
Err.Clear
End If
End Function
Private Sub Class_Terminate()
On Error Resume Next
DP_DPClose
End Sub
Public Function DP_DPCreate(V_Path As String, V_Compressed As Byte, V_Author As String, V_Copyright As String, V_Informations As String, V_Blocksize As Byte, V_Solid As Byte, V_Locked As Byte, V_PassProtect As String) As Long
On Error Resume Next
DP_DPCreate = -1
If DP_FN <> 0 Then DP_DPCreate = 14: Exit Function
If File_CheckExist(V_Path) = True Then DP_DPCreate = 2: Exit Function
If File_Open(V_Path, DP_FN, True) = False Then DP_DPCreate = 3: Exit Function
DP_Path = V_Path
Dim DPI As DP_InfoHeader_Type
DP_InfoHeader = DPI
With DP_InfoHeader
.V_Blocksize = V_Blocksize
If .V_Blocksize = 0 Then .V_Blocksize = 1
.V_Compressed = V_Compressed
.V_Author = V_Author
.V_Copyright = V_Copyright
.V_Informations = V_Informations
.V_CreateDate = Format(Now, "yyyymmddhhnnss")
File_Put DP_FN, 1, Chr(.V_Blocksize)
End With
DP_FileLen = 1
DP_BlockCount = 0
DP_Change = True
DP_DPCreate = 0
End Function
Public Function DP_DPOpen(V_Path As String) As Long
On Error Resume Next
DP_DPOpen = -1
If DP_FN <> 0 Then DP_DPOpen = 14: Exit Function
If File_CheckExist(V_Path) = False Then DP_DPOpen = 2: Exit Function
If File_Open(V_Path, DP_FN, True) = False Then DP_DPOpen = 3: Exit Function
DP_Path = V_Path
If DP_FileLen = 0 Then DP_DPOpen = 4: Exit Function
DP_Change = False
Dim DPI As DP_InfoHeader_Type
DP_InfoHeader = DPI
Dim TD As String
File_Get DP_FN, 1, 1, TD
DP_InfoHeader = DPI
DP_InfoHeader.V_Blocksize = Asc(TD)
File_Header_Read False
DP_DPOpen = 0
End Function
Public Function DP_DPClose()
On Error Resume Next
If DP_FN <> 0 Then
File_Header_Write
Close DP_FN
DP_FN = 0
End If
End Function
Public Function DP_Info(B_DPSize As Long, B_Compressed As Byte, B_Author As String, B_Copyright As String, B_Informations As String, B_CreateDate As String, B_Solid As Byte, B_Locked As Byte, B_Protected As Byte, B_Filecount As Long, B_Blocksize As Byte) As Long
On Error Resume Next
DP_Info = -1
If DP_FN = 0 Then DP_Info = 1: Exit Function
With DP_InfoHeader
B_DPSize = LOF(DP_FN)
If .V_Compressed = True Then B_Compressed = 1 Else B_Compressed = 0
B_Author = .V_Author
B_Copyright = .V_Copyright
B_Informations = .V_Informations
B_CreateDate = Mid(.V_CreateDate, 1, 4) & "." & Mid(.V_CreateDate, 5, 2) & "." & Mid(.V_CreateDate, 7, 2) & "-" & Mid(.V_CreateDate, 9, 2) & ":" & Mid(.V_CreateDate, 11, 2) & ":" & Mid(.V_CreateDate, 13, 2)
If .V_FreeC = 0 Then B_Solid = 1 Else B_Solid = 0
If .V_PassProtect <> "" Then B_Protected = 1 Else B_Protected = 0
B_Filecount = .V_FileC
B_Blocksize = .V_Blocksize
End With
DP_Info = 0
End Function
Public Function DP_FileAdd(V_Data As String, V_DataIsPath As Boolean, V_FileName As String, V_Path As String, V_PathIsRelativ As Boolean, V_CryptData As Boolean, V_CryptKey As String, B_FileID As Long) As Long
On Error Resume Next
DP_FileAdd = -1
If DP_FN = 0 Then DP_FileAdd = 1: Exit Function
If V_Data = "" Then DP_FileAdd = 10: Exit Function
If V_DataIsPath = True And File_CheckExist(V_Data) = False Then DP_FileAdd = 11: Exit Function
Dim TFN As Integer
If V_DataIsPath = True Then If File_Open(V_Data, TFN, False) = False Then DP_FileAdd = 12: Exit Function
RaiseEvent DPState(11, "")
Dim MX As Long
If V_DataIsPath = True Then
MX = LOF(TFN)
Else: MX = Len(V_Data)
End If
Dim FIHID As Long
RaiseEvent DPProgressMax(1, MX)
If DP_Change = False Then File_Header_Read True
With DP_InfoHeader
FIHID = 0
Dim X As Long
For X = 1 To .T_FileC
If .V_FileD(X).T_InUse = False Then
FIHID = X
Exit For
End If
Next
If FIHID = 0 Then
.V_FileC = .V_FileC + 1
.T_FileC = .T_FileC + 1
FIHID = .V_FileC
ReDim Preserve .V_FileD(.V_FileC) As DP_FileHeader_Type
End If
Dim FIHT As DP_FileHeader_Type
.V_FileD(FIHID) = FIHT
With .V_FileD(FIHID)
.T_InUse = True
.V_Crypted = ""
.V_FileName = V_FileName
.V_Filesize = MX
.V_Path = V_Path
.V_PathRelativ = V_PathIsRelativ
.V_AddDate = Format(Now, "yyyymmddhhnnss")
If V_DataIsPath = True Then .V_Attribute = GetAttr(V_Data)
Dim Y As Long
Dim BFID As Long
Dim XStep As Long
Dim D As String
XStep = GetBlockStepSequenz
For X = 1 To MX Step XStep
If V_DataIsPath = True Then
D = String(XStep, " ")
If MX - X < XStep Then D = String(MX - X + 1, " ")
Get TFN, X, D
Else: D = Mid(D, X, XStep)
End If
If Len(D) < XStep Then D = D & String(XStep - Len(D), Chr(1))
With DP_InfoHeader
BFID = 0
For Y = 1 To .V_FreeC
If .V_FreePD(Y) > 0 Then
BFID = .V_FreePD(Y)
.V_FreePD(Y) = 0
Exit For
End If
Next
If BFID = 0 Then
DP_BlockCount = DP_BlockCount + 1
BFID = DP_BlockCount
End If
End With
.V_DataC = .V_DataC + 1
ReDim Preserve .V_DataPD(.V_DataC) As Long
.V_DataPD(.V_DataC) = BFID
File_Put DP_FN, 2 + (BFID - 1) * XStep, D
DP_FileLen = DP_FileLen + XStep
RaiseEvent DPProgressValue(1, X)
If XTot < Timer Or XTotN < Now Then DoEvents: XTot = Timer: XTotN = Now
Next
RaiseEvent DPProgressValue(1, MX)
End With
End With
If TFN <> 0 Then Close TFN
DP_FileAdd = 0
End Function
Public Function DP_FileDel(V_FileID As Long, V_DelSpace As Boolean) As Long
On Error Resume Next
DP_FileDel = -1
If DP_FN = 0 Then DP_FileDel = 1: Exit Function
With DP_InfoHeader
If V_FileID <= 0 Or V_FileID > .V_FileC Then DP_FileDel = 12: Exit Function
Dim X As Long
Dim XFID As Long
If DP_Change = False Then File_Header_Read True
For X = 1 To .T_FileC
If .V_FileD(X).T_InUse = True Then XFID = XFID + 1
If XFID = V_FileID Then XFID = X: Exit For
Next
.V_FileD(XFID).T_InUse = False
If V_DelSpace = True Then
Dim D As String
Dim XStep As Long
XStep = GetBlockStepSequenz
D = String(XStep, Chr(0))
With .V_FileD(XFID)
RaiseEvent DPProgressMax(2, .V_DataC)
For X = 1 To .V_DataC
File_Put DP_FN, 1 + (.V_DataPD(X) - 1) * XStep, D
RaiseEvent DPProgressValue(2, X)
If XTot < Timer Or XTotN < Now Then DoEvents: XTot = Timer: XTotN = Now
Next
RaiseEvent DPProgressValue(2, .V_DataC)
End With
End If
.V_FileC = .V_FileC - 1
End With
DP_FileDel = 0
End Function
Public Function DP_FileGet(V_FileID As Long, VB_Data As String, V_DataIsPath As Boolean, V_OverridePath As Boolean) As Long
On Error Resume Next
DP_FileGet = -1
If DP_FN = 0 Then DP_FileGet = 1: Exit Function
With DP_InfoHeader
If V_FileID <= 0 Or V_FileID > .V_FileC Then DP_FileGet = 12: Exit Function
Dim X As Long
Dim XFID As Long
For X = 1 To .T_FileC
If .V_FileD(X).T_InUse = True Then XFID = XFID + 1
If XFID = V_FileID Then XFID = X: Exit For
Next
With .V_FileD(XFID)
Dim D As String
Dim TFN As Integer
If V_DataIsPath = True Then
If File_Open(VB_Data, TFN, False) = False Then DP_FileGet = 13: Exit Function
Else: VB_Data = ""
End If
Dim XStep As Long
Dim AKL As Long
XStep = GetBlockStepSequenz
RaiseEvent DPProgressMax(3, .V_DataC)
For X = 1 To .V_DataC
File_Get DP_FN, 2 + (.V_DataPD(X) - 1) * XStep, XStep, D
If X = .V_DataC Then D = Mid(D, 1, .V_Filesize Mod XStep)
If V_DataIsPath = True Then
File_Put TFN, AKL + 1, D
AKL = AKL + Len(D)
Else: VB_Data = VB_Data & D
End If
RaiseEvent DPProgressValue(3, X)
If XTot < Timer Or XTotN < Now Then DoEvents: XTot = Timer: XTotN = Now
Next
RaiseEvent DPProgressValue(3, .V_DataC)
If TFN <> 0 Then Close TFN
End With
End With
DP_FileGet = 0
End Function
Public Function DP_FileGetCount(B_Filecount As Long) As Long
On Error Resume Next
DP_FileGetCount = -1
If DP_FN = 0 Then DP_FileGetCount = 1: Exit Function
B_Filecount = DP_InfoHeader.V_FileC
DP_FileGetCount = 0
End Function
Public Function DP_FileGetInfo(V_FileID As Long, B_Crypted As Boolean, B_AddDate As String, B_FileName As String, B_Filesize As Long, B_Attribute As Long, B_Path As String, B_PathIsRelativ As Boolean) As Long
On Error Resume Next
DP_FileGetInfo = -1
If DP_FN = 0 Then DP_FileGetInfo = 1: Exit Function
With DP_InfoHeader
If V_FileID <= 0 Or V_FileID > .V_FileC Then DP_FileGetInfo = 12: Exit Function
Dim X As Long
Dim XFID As Long
For X = 1 To .T_FileC
If .V_FileD(X).T_InUse = True Then XFID = XFID + 1
If XFID = V_FileID Then XFID = X: Exit For
Next
With .V_FileD(XFID)
If .V_Crypted <> "" Then B_Crypted = True Else B_Crypted = False
B_AddDate = Mid(.V_AddDate, 1, 4) & "." & Mid(.V_AddDate, 5, 2) & "." & Mid(.V_AddDate, 7, 2) & "-" & Mid(.V_AddDate, 9, 2) & ":" & Mid(.V_AddDate, 11, 2) & ":" & Mid(.V_AddDate, 13, 2)
B_FileName = .V_FileName
B_Filesize = .V_Filesize
B_Attribute = .V_Attribute
B_Path = .V_Path
B_PathIsRelativ = .V_PathRelativ
End With
End With
DP_FileGetInfo = 0
End Function
Private Function File_CheckExist(V_Path As String) As Boolean
On Error Resume Next
File_CheckExist = False
If Dir(V_Path, vbArchive Or vbHidden Or vbNormal Or vbReadOnly Or vbSystem) <> "" Then File_CheckExist = True
End Function
Private Function File_Open(V_Path As String, B_FileID As Integer, V_SetDPFL As Boolean) As Boolean
On Error Resume Next
File_Open = False
ErrC
B_FileID = FreeFile
Open V_Path For Binary As B_FileID
If ErrC = False Then
If V_SetDPFL = True Then DP_FileLen = LOF(B_FileID)
File_Open = True
Else: B_FileID = 0
End If
End Function
Private Function File_Header_Write()
On Error Resume Next
If DP_Change = False Then Exit Function
DP_Change = False
Dim T As String
Dim X As Long
T = ""
With DP_InfoHeader
If .V_Compressed = True Then T = T & Chr(1) Else T = T & Chr(2)
T = T & AC_ValOut(Len(.V_Author)) & .V_Author
T = T & AC_ValOut(Len(.V_Copyright)) & .V_Copyright
T = T & AC_ValOut(Len(.V_Informations)) & .V_Informations
T = T & AC_ValOut(Len(.V_CreateDate)) & .V_CreateDate
T = T & AC_ValOut(.V_FreeC)
For X = 1 To .V_FreeC
T = T & AC_ValOut(.V_FreePD(X))
Next
End With
T = T & File_HeaderFiles_Write
T = T & AC_ValOut(Len(T))
File_Put DP_FN, DP_FileLen + 1, T
End Function
Private Function File_Header_Read(V_ReadOut As Boolean)
On Error Resume Next
If DP_Change = True Then Exit Function
RaiseEvent DPState(10, "")
Dim TD As String
Dim TL As Long
Dim T As String
Dim X As Long
File_Get DP_FN, DP_FileLen - 2, 3, TD
TL = AC_ValIn(TD)
File_Get DP_FN, DP_FileLen - TL - 2, TL, TD
If V_ReadOut = True Then
DP_FileLen = DP_FileLen - TL - 2
File_SetLen DP_FileLen
DP_Change = True
End If
Debug.Print Mid(TD, 1, 2000)
With DP_InfoHeader
T = Left(TD, 1)
If Asc(T) = 1 Then .V_Compressed = True Else .V_Compressed = False
TD = Mid(TD, 2): TL = AC_ValIn(Mid(TD, 1, 3)): .V_Author = Mid(TD, 4, TL)
TD = Mid(TD, TL + 4): TL = AC_ValIn(Mid(TD, 1, 3)): .V_Copyright = Mid(TD, 4, TL)
TD = Mid(TD, TL + 4): TL = AC_ValIn(Mid(TD, 1, 3)): .V_Informations = Mid(TD, 4, TL)
TD = Mid(TD, TL + 4): TL = AC_ValIn(Mid(TD, 1, 3)): .V_CreateDate = Mid(TD, 4, TL)
TD = Mid(TD, TL + 4): .V_FreeC = AC_ValIn(Mid(TD, 1, 3))
ReDim .V_FreePD(.V_FreeC) As Long
For X = 1 To .V_FreeC
TD = Mid(TD, 4): .V_FreePD(X) = AC_ValIn(Mid(TD, 1, 3))
Next
TD = Mid(TD, 4)
File_HeaderFiles_Read TD
End With
End Function
Private Function File_HeaderFiles_Write() As String
On Error Resume Next
Dim X As Long
Dim Y As Long
Dim D As String
Dim T1 As String
With DP_InfoHeader
For X = 1 To .T_FileC
T1 = ""
With .V_FileD(X)
If .T_InUse = True Then
T1 = T1 & AC_ValOut(Len(.V_Crypted)) & .V_Crypted
T1 = T1 & AC_ValOut(Len(.V_AddDate)) & .V_AddDate
T1 = T1 & AC_ValOut(Len(.V_Path)) & .V_Path
If .V_PathRelativ = True Then T1 = T1 & Chr(1) Else T1 = T1 & Chr(2)
T1 = T1 & AC_ValOut(Len(.V_FileName)) & .V_FileName
T1 = T1 & AC_ValOut(.V_Filesize)
T1 = T1 & AC_ValOut(.V_Attribute)
T1 = T1 & AC_ValOut(.V_DataC)
For Y = 1 To .V_DataC
T1 = T1 & AC_ValOut(.V_DataPD(Y))
Next
D = D & AC_ValOut(Len(T1)) & T1
End If
End With
If XTot < Timer Or XTotN < Now Then DoEvents: XTot = Timer: XTotN = Now
Next
End With
File_HeaderFiles_Write = D
End Function
Private Function File_HeaderFiles_Read(V_Data As String)
On Error Resume Next
Dim D As String
Dim TD As String
Dim TL As Long
Dim X As Long
Dim Y As Long
D = V_Data
With DP_InfoHeader
.V_FileC = 0
.T_FileC = 0
For X = 1 To Len(D)
If Len(D) = 0 Then Exit For
TL = AC_ValIn(Mid(D, 1, 3))
TD = Mid(D, 4, TL)
D = Mid(D, TL + 4)
.V_FileC = .V_FileC + 1
.T_FileC = .T_FileC + 1
ReDim Preserve .V_FileD(.V_FileC) As DP_FileHeader_Type
With .V_FileD(.V_FileC)
.T_InUse = True
TL = AC_ValIn(Mid(TD, 1, 3)): .V_Crypted = Mid(TD, 4, TL)
TD = Mid(TD, TL + 4): TL = AC_ValIn(Mid(TD, 1, 3)): .V_AddDate = Mid(TD, 4, TL)
TD = Mid(TD, TL + 4): TL = AC_ValIn(Mid(TD, 1, 3)): .V_Path = Mid(TD, 4, TL)
TD = Mid(TD, TL + 4): If Asc(Mid(TD, 1, 1)) = 1 Then .V_PathRelativ = True Else .V_PathRelativ = False
TD = Mid(TD, 2): TL = AC_ValIn(Mid(TD, 1, 3)): .V_FileName = Mid(TD, 4, TL)
TD = Mid(TD, TL + 4): .V_Filesize = AC_ValIn(Mid(TD, 1, 3))
TD = Mid(TD, 4): .V_Attribute = AC_ValIn(Mid(TD, 1, 3))
TD = Mid(TD, 4): .V_DataC = AC_ValIn(Mid(TD, 1, 3))
ReDim Preserve .V_DataPD(.V_DataC) As Long
For Y = 1 To .V_DataC
TD = Mid(TD, 4): .V_DataPD(Y) = AC_ValIn(Mid(TD, 1, 3))
Next
End With
Next
End With
End Function
Private Function File_PutData(V_BlockID As Long, V_Data As String) As Boolean
On Error Resume Next
End Function
Private Function File_GetData(V_BlockID As Long, B_Data As String) As Boolean
On Error Resume Next
End Function
Private Function File_Put(V_FileID As Integer, V_Pos As Long, V_Data As String)
On Error Resume Next
Put V_FileID, V_Pos, V_Data
End Function
Private Function File_Get(V_FileID As Integer, V_Pos As Long, V_DataLen As Long, B_Data As String)
On Error Resume Next
B_Data = String(V_DataLen, " ")
Get V_FileID, V_Pos, B_Data
End Function
Private Function AC_ValOut(V_Value As Long) As String
On Error Resume Next
AC_ValOut = Space(4)
RtlMoveMemory ByVal AC_ValOut, V_Value, 4
End Function
Private Function AC_ValIn(ByVal V_Value As String) As Long
On Error Resume Next
RtlMoveMemory AC_ValIn, ByVal V_Value, 4
End Function
Public Function File_SetLen(V_FileLen As Long)
On Error Resume Next
Dim FN2 As Long
If DP_FN <> 0 Then Close DP_FN
FN2 = CreateFile(DP_Path, GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ, ByVal 0, OPEN_EXISTING, 0, 0)
If FN2 = -1 Then Exit Function
'Debug.Print SetFilePointer(FN2, V_FileLen, 0, 0)
'Debug.Print SetEndOfFile(FN2)
CloseHandle FN2
If DP_FN <> 0 Then
DP_FN = FreeFile
Open DP_Path For Binary As DP_FN
End If
End Function
Private Function GetBlockStepSequenz() As Long
On Error Resume Next
GetBlockStepSequenz = DP_InfoHeader.V_Blocksize * 1024
End Function
Public Function Get_BID_Description(V_BID As Long) As String
On Error Resume Next
Dim D As String
Select Case V_BID
Case -1: D = "Unbekannter Fehler"
Case 0: D = "Kein Fehler"
Case 1: D = "Es wurde keine Datei ge�ffnet"
Case 2: D = "Pfad nicht gefunden"
Case 3: D = "Konnte Datei nicht �ffnen"
Case 4: D = "Datei enth�lt keine Daten"
Case 10: D = "Es wurde kein Pfad zu einer Datenquelle bzw. keine Daten �bergeben"
Case 11: D = "Pfad der Datenquelle nicht gefunden"
Case 12: D = "FileID auserhalb des g�ltigen Bereichs"
Case 13: D = "Konnte Ziel-Datei nicht �ffnen"
Case 14: D = "Es wurde bereits eine Datei ge�ffnet"
End Select
Get_BID_Description = D
End Function
Public Function DP_CheckIsOpen(B_Locked As Boolean) As Boolean
On Error Resume Next
DP_CheckIsOpen = False
B_Locked = False
If DP_FN <> 0 Then DP_CheckIsOpen = True Else Exit Function
B_Locked = DP_InfoHeader.V_Locked
End Function