Lo Stream in Memoria

Lo stream è una struttura estremamante utile quando è necessario manipolare dati binari e avere la possibilità di creare ed utilizzare stream direttamente in memoria presenta molti vantaggi.

Quando è necessario creare, copiare, comprimere, criptare una certa quantità di dati, sebbene sia possibile usare dei normali file su disco, avendo a disposizione delle "code" di dati in memoria, è possibile ottenere prestazioni migliori.
Da un punto di vista tecnico, la classe ETMemoryStream utilizza l'allocazione sull'Heap globale, quindi consente di gestire stream di dimensioni limitate solo dalla quantità di RAM disponibile.
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ETMemoStream"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'**************************************************************
'* ETLib4VB - Easy Target Library for Visual Basic            *
'* (C) 2003 By Andrea Molino                                  *
'* Class: ETMemoStream                                        *
'* Enable to streaming data in a global memory area           *
'* Memory is dinamically allocated when needed                *
'**************************************************************

Option Explicit

Const GMEM_FIXED = 0&
Const GMEM_MOVEABLE = 2&
Const GMEM_ZEROINIT = &H40&
Const GMEM_DISCARDABLE = &H100&
Const GMEM_VALID_FLAGS = 32626&
Const GMEM_INVALID_HANDLE = &H8000&
Const GHND = GMEM_MOVEABLE Or GMEM_ZEROINIT
Const GPTR = GMEM_FIXED Or GMEM_ZEROINIT

Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long '(HGLOBAL)
Private Declare Function GlobalReAlloc Lib "kernel32" (ByVal hMem As Long, ByVal dwBytes As Long, ByVal uFlags As Integer) As Long '(HGLOBAL)
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long '(DWORD)
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long '(Pointer)
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal MemPtr As Long) As Boolean
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long '(HGLOBAL)
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwBytes As Long)


Public Enum ETMemoryStreamSeekOrigin
  msSoBegin = 1         'Offset is from the beginning of the resource. Seek moves to the position Offset. Offset must be >= 0.
  msSoCurrent = 2       'Offset is from the current position in the resource. Seek moves to Position + Offset.
  msSoEnd = 3           'Offset is from the end of the resource. Offset must be <= 0 to indicate a number of bytes before the end of the file.
End Enum

Private Const MemoryDelta = &H2000&  '(8 Kb) Must be a power of 2
Private Const FileBlocSize = &H2000&  '(8 Kb)

Private FMemoryHandle As Long
Private FMemoryPtr As Long
Private FCapacity As Long
Private FSize As Long
Private FPosition As Long

Private AuxByt As Byte
Private AuxInt As Integer
Private AuxLng As Long
Private AuxSng As Single
Private AuxDbl As Double
Private AuxCur As Currency
Private AuxDat As Date
Private AuxBoo As Boolean
Private AuxStr As String



Private Sub Class_Initialize()
  FMemoryHandle = GMEM_INVALID_HANDLE
  FMemoryPtr = 0
  FCapacity = 0
  FSize = 0
  FPosition = 0
End Sub

Private Sub Class_Terminate()
  Clear
End Sub

Private Sub ReAllocMem(ByVal NewCapacity As Long)
  If NewCapacity > 0 Then
    NewCapacity = (NewCapacity + (MemoryDelta - 1)) And Not (MemoryDelta - 1)
  End If
  If NewCapacity <> FCapacity Then
    If NewCapacity = 0 Then
      Call GlobalFree(FMemoryHandle)
      FMemoryHandle = GMEM_INVALID_HANDLE
      FCapacity = 0
    Else
      If FCapacity = 0 Then
        FMemoryHandle = GlobalAlloc(GHND, NewCapacity)
      Else
        FMemoryHandle = GlobalReAlloc(FMemoryHandle, NewCapacity, GHND)
      End If
      If (FMemoryHandle = GMEM_INVALID_HANDLE) Or (FMemoryHandle = 0) Then
        'FETObj.RaiseError FETKey, Me, etErrGlobalMemAlloc
      Else
        FCapacity = GlobalSize(FMemoryHandle)
      End If
    End If
  End If
End Sub

Private Sub SetCapacity(ByVal NewCapacity As Long)
Dim DoAllocation As Boolean
  
  DoAllocation = (FMemoryHandle = GMEM_INVALID_HANDLE)
  If Not DoAllocation Then DoAllocation = GlobalUnlock(FMemoryPtr)

  If DoAllocation Then
    Call ReAllocMem(NewCapacity)
    If NewCapacity > 0 Then
      FMemoryPtr = GlobalLock(FMemoryHandle)
      'If (FMemoryPtr = 0) Then FETObj.RaiseError FETKey, Me, etErrGlobalMemAlloc
    Else
      FMemoryPtr = 0
    End If
  End If
End Sub



Public Sub Clear()
  Call SetCapacity(0)
  FSize = 0
  FPosition = 0
End Sub

Public Function StreamSeek(ByVal Offset As Long, ByVal Origin As ETMemoryStreamSeekOrigin) As Long
  Select Case Origin
    Case msSoBegin:   FPosition = Offset
    Case msSoCurrent: FPosition = FPosition + Offset: If FPosition > FSize Then FPosition = FSize
    Case msSoEnd:     FPosition = FSize - Offset
  End Select
End Function

'Write a Byte or Byte Array to the stream
Public Function WriteB(Buffer As Byte, ByVal BCount As Long) As Long
Dim Pos As Long
Dim Dst As Long
  
  If BCount = 0 Then Exit Function
  Pos = FPosition + BCount
  If Pos > 0 Then
    If Pos > FSize Then
      If Pos > FCapacity Then Call SetCapacity(Pos)
      FSize = Pos
    End If
    Dst = FMemoryPtr + FPosition
    MoveMemory ByVal Dst, Buffer, BCount
    FPosition = Pos
    WriteB = BCount
    Exit Function
  End If
  WriteB = 0
End Function

'Read a Byte or Byte Array from the stream
Public Function ReadB(Buffer As Byte, ByVal BCount As Long) As Long
Dim ByteNum As Long
Dim Src As Long
  
  If BCount = 0 Then Exit Function
  ByteNum = FSize - FPosition
  If ByteNum > 0 Then
    If ByteNum > BCount Then ByteNum = BCount
    Src = FMemoryPtr + FPosition
    MoveMemory Buffer, ByVal Src, ByteNum
    FPosition = FPosition + ByteNum
    ReadB = ByteNum
    Exit Function
  End If
  ReadB = 0
End Function

'Write an Integer or Integer Array to the stream. Return number of Integer writed
Public Function WriteI(Buffer As Integer, ByVal LCount As Long) As Long
Dim BCount As Long
Dim Pos As Long
Dim Dst As Long

  If LCount = 0 Then Exit Function
  BCount = LCount * LenB(LCount) ' To Get Integer Size (2 Byte)
  Pos = FPosition + BCount
  If Pos > 0 Then
    If Pos > FSize Then
      If Pos > FCapacity Then Call SetCapacity(Pos)
      FSize = Pos
    End If
    Dst = FMemoryPtr + FPosition
    MoveMemory ByVal Dst, Buffer, BCount
    FPosition = Pos
    WriteI = LCount
    Exit Function
  End If
  WriteI = 0
End Function

'Read a Integer or Integer Array from the stream. Return number of Integer readed
Public Function ReadI(Buffer As Integer, ByVal LCount As Long) As Long
Dim BCount As Long
Dim ByteNum As Long
Dim Src As Long

  If LCount = 0 Then Exit Function
  BCount = LCount * LenB(LCount) ' To Get Integer Size (2 Byte)
  ByteNum = FSize - FPosition
  If ByteNum > 0 Then
    If ByteNum > BCount Then ByteNum = BCount
    Src = FMemoryPtr + FPosition
    MoveMemory Buffer, ByVal Src, ByteNum
    FPosition = FPosition + ByteNum
    ReadI = ByteNum \ LenB(LCount)
    Exit Function
  End If
  ReadI = 0
End Function

'Write a Long or Long Array to the stream. Return number of long writed
Public Function WriteL(Buffer As Long, ByVal LCount As Long) As Long
Dim BCount As Long
Dim Pos As Long
Dim Dst As Long

  If LCount = 0 Then Exit Function
  BCount = LCount * LenB(LCount) ' To Get Long Size (4 Byte)
  Pos = FPosition + BCount
  If Pos > 0 Then
    If Pos > FSize Then
      If Pos > FCapacity Then Call SetCapacity(Pos)
      FSize = Pos
    End If
    Dst = FMemoryPtr + FPosition
    MoveMemory ByVal Dst, Buffer, BCount
    FPosition = Pos
    WriteL = LCount
    Exit Function
  End If
  WriteL = 0
End Function

'Read a Long or Long Array from the stream. Return number of long readed
Public Function ReadL(Buffer As Long, ByVal LCount As Long) As Long
Dim BCount As Long
Dim ByteNum As Long
Dim Src As Long

  If LCount = 0 Then Exit Function
  BCount = LCount * LenB(LCount) ' To Get Long Size (4 Byte)
  ByteNum = FSize - FPosition
  If ByteNum > 0 Then
    If ByteNum > BCount Then ByteNum = BCount
    Src = FMemoryPtr + FPosition
    MoveMemory Buffer, ByVal Src, ByteNum
    FPosition = FPosition + ByteNum
    ReadL = ByteNum \ LenB(LCount)
    Exit Function
  End If
  ReadL = 0
End Function

'Write a string to the stream (Count is the number of char)
Public Function WriteS(Str As String, ByVal Count As Long, Optional Unicode As Boolean = False) As Long
Dim Pos As Long
Dim Dst As Long
Dim ChrBuff() As Byte
Dim BCount As Long
  
  If Count = 0 Then Exit Function
  If Unicode Then BCount = Count * 2 Else BCount = Count
  Pos = FPosition + BCount
  If Pos > 0 Then
    If Pos > FSize Then
      If Pos > FCapacity Then Call SetCapacity(Pos)
      FSize = Pos
    End If
    Dst = FMemoryPtr + FPosition
    If Unicode Then
      ChrBuff = Str
      MoveMemory ByVal Dst, ChrBuff(0), BCount
    Else
      MoveMemory ByVal Dst, ByVal Str, Count
    End If
    FPosition = Pos
    WriteS = Count 'Number of Chars not of Bytes
    Exit Function
  End If
  WriteS = 0
End Function

'Read a string from the stream (Count is the number of char)
Public Function ReadS(Str As String, ByVal Count As Long, Optional Unicode As Boolean = False) As Long
Dim ByteNum As Long
Dim Src As Long
Dim ChrBuff() As Byte
Dim BCount As Long
  
  If Count = 0 Then Exit Function
  If Unicode Then BCount = Count * 2 Else BCount = Count
  ByteNum = FSize - FPosition
  If ByteNum > 0 Then
    If ByteNum > BCount Then ByteNum = BCount
    Src = FMemoryPtr + FPosition
    If Unicode Then
      ReDim ChrBuff(0 To BCount - 1)
      MoveMemory ChrBuff(0), ByVal Src, ByteNum
      Str = ChrBuff
    Else
      Str = String(ByteNum, " ")
      MoveMemory ByVal Str, ByVal Src, ByteNum
    End If
    FPosition = FPosition + ByteNum
    ReadS = Len(Str)
    Exit Function
  End If
  ReadS = 0
End Function

' Write a Variant value from the Stream
Public Function WriteV(Data As Variant, DT As Byte, Count As Long) As Long
Dim Pos As Long
Dim Dst As Long

  If Count = 0 Then Exit Function
  Pos = FPosition + Count
  If Pos > 0 Then
    If Pos > FSize Then
      If Pos > FCapacity Then Call SetCapacity(Pos)
      FSize = Pos
    End If
    Dst = FMemoryPtr + FPosition
    Select Case DT
      Case vbLong:     AuxLng = Data: MoveMemory ByVal Dst, AuxLng, Count
      Case vbInteger:  AuxInt = Data: MoveMemory ByVal Dst, AuxInt, Count
      Case vbByte:     AuxByt = Data: MoveMemory ByVal Dst, AuxByt, Count
      Case vbDouble:   AuxDbl = Data: MoveMemory ByVal Dst, AuxDbl, Count
      Case vbSingle:   AuxSng = Data: MoveMemory ByVal Dst, AuxSng, Count
      Case vbDate:     AuxDat = Data: MoveMemory ByVal Dst, AuxDat, Count
      Case vbCurrency: AuxCur = Data: MoveMemory ByVal Dst, AuxCur, Count
      Case vbBoolean:  AuxBoo = Data: MoveMemory ByVal Dst, AuxBoo, Count
    End Select
    FPosition = Pos
    WriteV = Count
    Exit Function
  End If
  WriteV = 0
End Function
 
' Read a Variant value from the Stream
Public Function ReadV(Data As Variant, DT As Byte) As Long
Dim Pos As Long
Dim Src As Long
Dim Count As Long
  
  If FPosition < FSize Then
    Src = FMemoryPtr + FPosition
    Select Case DT
      Case vbLong:     Count = LenB(AuxLng): MoveMemory AuxLng, ByVal Src, Count: Data = AuxLng
      Case vbInteger:  Count = LenB(AuxInt): MoveMemory AuxInt, ByVal Src, Count: Data = AuxInt
      Case vbByte:     Count = LenB(AuxByt): MoveMemory AuxByt, ByVal Src, Count: Data = AuxByt
      Case vbDouble:   Count = LenB(AuxDbl): MoveMemory AuxDbl, ByVal Src, Count: Data = AuxDbl
      Case vbSingle:   Count = LenB(AuxSng): MoveMemory AuxSng, ByVal Src, Count: Data = AuxSng
      Case vbDate:     Count = LenB(AuxDat): MoveMemory AuxDat, ByVal Src, Count: Data = AuxDat
      Case vbCurrency: Count = LenB(AuxCur): MoveMemory AuxCur, ByVal Src, Count: Data = AuxCur
      Case vbBoolean:  Count = LenB(AuxBoo): MoveMemory AuxBoo, ByVal Src, Count: Data = AuxBoo
    End Select
    FPosition = FPosition + Count
    ReadV = Count
    Exit Function
  End If
  ReadV = 0
End Function

Public Function LoadFromFile(ByVal FileName As String) As Boolean
Dim FNum As Integer
Dim isOpen As Boolean
Dim BlockSize As Integer
Dim Buff() As Byte

On Error GoTo Error_Handler
  If Dir(FileName) = "" Then 'Test if file exists
    LoadFromFile = False
    Exit Function
  End If
  ReDim Buff(0 To FileBlocSize - 1)
  FNum = FreeFile()
  Open FileName For Binary Access Read As #FNum
  isOpen = True
  FSize = LOF(FNum)
  Call SetCapacity(FSize)
  FPosition = 0
  BlockSize = FileBlocSize
  Do Until FPosition = FSize
    If BlockSize > (FSize - FPosition) Then
      BlockSize = FSize - FPosition
      ReDim Buff(0 To FileBlocSize - 1)
    End If
    Get #FNum, , Buff
    If WriteB(Buff(0), BlockSize) <> BlockSize Then Exit Do
  Loop
  LoadFromFile = True
  
Error_Handler:
    If isOpen Then Close #FNum
    If Err Then
      LoadFromFile = False
      Err.Raise Err.Number, , Err.Description
    End If
End Function

Public Sub SaveToFile(ByVal FileName As String)
Dim FNum As Integer
Dim isOpen As Boolean
Dim BlockSize As Integer
Dim Buff() As Byte

On Error GoTo Error_Handler
  If Dir(FileName) <> "" Then 'Test if file exists
    If Len(FileName) Then
        Kill FileName
    End If
  End If
  ReDim Buff(0 To FileBlocSize - 1)
  FNum = FreeFile()
  Open FileName For Binary Access Write As #FNum
  isOpen = True
  FPosition = 0
  BlockSize = FileBlocSize
  If FSize > 0 Then
    Do
      If FSize - FPosition < FileBlocSize Then
        BlockSize = FSize - FPosition
        ReDim Buff(0 To BlockSize - 1)
      End If
      If ReadB(Buff(0), BlockSize) <> BlockSize Then Exit Do
      Put #FNum, , Buff
    Loop Until FPosition = FSize
  End If
  
Error_Handler:
    If isOpen Then Close #FNum
    If Err Then Err.Raise Err.Number, , Err.Description
End Sub


Public Property Let Size(ByVal vData As Long)
Dim OldPosition As Long
  If vData <= 0 Then
    Clear
  Else
    OldPosition = FPosition
    Call SetCapacity(vData)
    FSize = vData
    If OldPosition > vData Then StreamSeek 0, msSoEnd
  End If
End Property

Public Property Get Size() As Long
  Size = FSize
End Property

Public Property Let Position(ByVal vData As Long)
  If vData < FSize Then
    StreamSeek vData, msSoBegin
  Else
    StreamSeek 0, msSoEnd
  End If
End Property

Public Property Get Position() As Long
  Position = FPosition
End Property

Public Property Get Memory() As Long
  Memory = FMemoryPtr
End Property
Tutte le Utility