Ответить

Ответить

Вот тебе код модуля:

Option Explicit

Private Type Node

Value As Long

Position As Boolean

ParentNode As Long

End Type

Dim Tree(255) As Node

Dim TreeExist As Boolean

Public Event ChangeProcent(ByVal Procent As Byte)

Public Sub CreateTree()

Dim I As Long

Dim NP As Boolean 'Новая позиция

Dim NPN As Long 'Новый верхний узел

Dim APN As Byte 'Повтор верхнего узла

DeleteTree

NPN = -1: APN = 1

For I = 0 To 255

With Tree(I)

.Value = I

.Position = NP

.ParentNode = NPN

End With

APN = APN + 1

If APN = 3 Then APN = 1: NPN = I

If NPN = -1 Then APN = 1: NPN = 0

NP = Not NP

RaiseEvent ChangeProcent(CByte(I / 2.55))

DoEvents

Next I

TreeExist = True

End Sub

Public Sub CompressFile(ByVal Source As String, ByVal Destination As String)

On Error GoTo RTE

Dim Bytes() As Byte, Count As Long

If Not FileExist(Source) Then

Err.Raise vbObjectError, "TextSystem.Compress.CompressFile(" & Source & ", " & Destination & ")", "Source file not exist"

End If

Open Source For Binary As #1

ReDim Bytes(LOF(1))

Count = LOF(1) + 1

Get #1, , Bytes()

Close #1

CompressBytes Bytes(), Count

ReDim Preserve Bytes(Count - 1)

If FileExist(Destination) Then Kill Destination

Open Destination For Binary As #1

Put #1, , Bytes()

Close #1

Exit Sub

RTE:

If Err.Number = 75 Then Err.Raise vbObjectError, "TextSystem.Compress.CompressFile(" & Source & ", " & Destination & ")", "File """ & Destination & """ can not open for write"

End Sub

Public Function CompressString(ByVal Str As String) As String

Dim Bytes() As Byte, Count As Long

Bytes() = StrConv(Str, vbFromUnicode)

Count = Len(Str)

CompressBytes Bytes(), Count

ReDim Preserve Bytes(Count - 1)

CompressString = StrConv(Bytes(), vbUnicode)

ReDim Bytes(0)

Count = 0

End Function

Public Function CompressBytes(ByteArray() As Byte, Count As Long)

Dim I As Long

Dim Bytes() As String

End Function

Public Function FileExist(FileName As String) As Boolean

On Error GoTo RTE

FileLen FileName

FileExist = True

Exit Function

RTE:

If Err.Number = 53 Then FileExist = False

End Function

Public Sub DeleteTree()

Dim I As Long

For I = 0 To 255

With Tree(I)

.Value = -1

.Position = True

.ParentNode = -1

End With

Next I

TreeExist = False

End Sub

Private Function GetHuffmanCode(Symbol As String) As String

Dim I As Long, NodeCode As Long

Symbol = Left(Symbol, 1)

For I = 0 To 255

If Tree(I).Value = Asc(Symbol) Then NodeCode = I: Exit For

Next I

While Tree(I).ParentNode <> -1

GetHuffmanCode = GetHuffmanCode & CStr(Abs(Tree(I).Position))

I = Tree(I).ParentNode

Wend

End Function

Ответить

Ответить

Ну если интерестно можешь посмотреть и на эту вариацию Хафмана....

http://mudator.by.ru/UoHuffman.zip

Как то занимался (да и счас немного) програмированием под игру UltimaOnline.... вообщем это вариант клиента для неё... без крипта используется только ... сжатие по хафману.... портировалось с программы Injection...

смотри класс..

Ответить

Ну если интерестно можешь посмотреть и на эту вариацию Хафмана....

http://mudator.by.ru/UoHuffman.zip

Как то занимался (да и счас немного) програмированием под игру UltimaOnline.... вообщем это вариант клиента для неё... без крипта используется только ... сжатие по хафману.... портировалось с программы Injection...

смотри класс..

Ответить