Using EM_STREAMIN to Quickly Load a RichTextBox

Option Explicit     
'RTB StreamIn.vbp
'
'
'Copyright by Arthur A. Marks, aamarks@ambytes.com
'
'Feel free to use and modify this for your applications.
'This code will allow you to replace the text, rtftext,
'seltext or selrtf of an RTB control with large amounts
'of text without "freezing" it. (It will behave similar
'to the way Wordpad does when loading large files.)
'I haven't cleaned up the code since I first got it working
'so excuse the mess and be aware that the code may still
'be buggy. Bad calls to CopyMemory can crash VB and your
'app. Use at your own risk, etc.
'WARNING: if rtb MaxTextLimit is exceeded the app will freeze
'Streaming------------------------------------------------------------
Public Type EditStream
    lCookie As Long
    dwError As Long
    pfnCallback As Long
End Type
'uncomment these if not declared elsewhere
Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
    (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
    lParam As Any) As Long
Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" _
    (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
    ByVal lParam As Long) As Long
Private Const WM_USER = &H400
Private Const EM_STREAMIN = (WM_USER + 73)
Private Const EM_STREAMOUT = (WM_USER + 74)
Private Const EM_SETMODIFY = &HB9
Public Enum eStreamFormats
    SF_TEXT = 1
    SF_RTF = 2
    SFo_RTFNOOBJS = 3        '/* outbound only */
    SFo_TEXTIZED = 4         '/* outbound only */
    'Rich Edit 2.0: Indicates Unicode text. You can combine this flag with the SF_TEXT flag.
    SF_UNICODE = &H10          '/* Unicode file of some kind */
    '/* Flag telling stream operations to operate on the selection only */
    '/* EM_STREAMIN will replace the current selection */
    '/* EM_STREAMOUT will stream out the current selection */
    SFF_SELECTION = &H8000& 'make it a long
    'Language-specific RTF keywords in the stream are ignored. Only keywords common
    'to all languages are streamed in. You can combine this flag with the SF_RTF flag.
    SFF_PLAINRTF = &H4000
End Enum
'APIs for File ---------------------------------------------------
Private Const OF_READ = &H0
Private Const OFS_MAXPATHNAME = 128
Private Type OFSTRUCT
        cBytes As Byte
        fFixedDisk As Byte
        nErrCode As Integer
        Reserved1 As Integer
        Reserved2 As Integer
        szPathName(OFS_MAXPATHNAME) As Byte
End Type
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Public Const OPEN_EXISTING = 3
'Private Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
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 CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
'Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
'----------------------------------------------------------------
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pTo As Any, pFrom As Any, ByVal lCount As Long)
'My Declarations-------------------------------------------------
Private Enum eStreamContentTypes
    sctFile
    sctByte
    sctString
    sctStringUnicode
End Enum
'Private Const STREAM_ID = 1000
Private m_B() As Byte
Private m_S As String
Private m_tEditStream As EditStream
Private m_StreamContentType As eStreamContentTypes
'Originally I thought pcbTransfered had to be zero to end callback succesfully,
'but that can also happen if the RTF code contains data specifying the end of an RTF block.
'Originally had pos as static in callback, but do to the multiple ways
'in which the callback may end it's better not to try to reset pos to
'zero within the callback based on the assumption that the callback is going
'to stop. If set to zero and the callback continues you have an endless loop.
'Better to set to zero at the StreamIn commands.
Private m_pos As Long
'cb is the size of the buffer provided by windows
'we have to set pcbtransfered so that Windows knows how much of the buffer was used
'cookie is defined by us as an extra id, in this case it's a file handle or zero
Public Function EditStreamCallback(ByVal lCookie As Long, ByVal pbBuffer As Long, ByVal cb As Long, ByVal pcbTransfered As Long) As Long
Dim s As String, res As Long, cbTransfered As Long
    Static bFirstByte(0) As Byte ', bDebug() As Byte ', m_pos As Long
    Select Case m_StreamContentType
        Case sctFile
            res = ReadFile(lCookie, ByVal pbBuffer, cb, cbTransfered, ByVal 0&)
            
            'debuging next 2 lines: shows that the pbbuffer does contain the file data
            'it's possible that this is overwriting memory, however windows probably
            'allocates the buffer to be cb is size. You return pcbtransfered so that
            'it knows how much of the possible buffer is used.
        '    ReDim m_B(pcbtransfered)
        '    CopyMemory m_B(0), ByVal pbBuffer, 10 ' pcbtransfered
            
            'prevent rtb freeze/crash if first byte of stream is zero
            If bFirstByte(0) = 0 Then 'first time though for this stream
                CopyMemory bFirstByte(0), ByVal pbBuffer, 1
                If bFirstByte(0) = 0 Then bFirstByte(0) = 32: CopyMemory ByVal pbBuffer, bFirstByte(0), 1
            End If
            
            If res = 0 Then Stop
        Case sctByte
            If m_pos + cb > UBound(m_B) Then cbTransfered = UBound(m_B) - m_pos + 1 Else cbTransfered = cb
            'write up to 4096 bytes to the buffer
            If cbTransfered Then CopyMemory ByVal pbBuffer, m_B(m_pos), cbTransfered
            m_pos = m_pos + cbTransfered
        Case sctString, sctStringUnicode
            If m_pos + cb > LenB(m_S) Then cbTransfered = LenB(m_S) - m_pos + 1 Else cbTransfered = cb
            If cbTransfered Then CopyMemory ByVal pbBuffer, ByVal StrPtr(m_S) + m_pos, cbTransfered
            m_pos = m_pos + cbTransfered
    End Select
    
    If m_tEditStream.dwError <> 0 Then  'probably an unnecessary test
        'returning non-zero stops callback w/o loading rtb
        EditStreamCallback = m_tEditStream.dwError
        bFirstByte(0) = 0 'reset for next stream
'        m_pos = 0
    Else 'tell how many bytes we set
        CopyMemory ByVal pcbTransfered, cbTransfered, 4
        If cbTransfered < cb Then '= 0 Then
            bFirstByte(0) = 0 'reset for next stream
'            m_pos = 0
        End If
    End If
    'invalid characters may cause callback to stop. check for error after
    'call to sendmessage with EM_STREAMIN
End Function
Public Function StreamInFile(hWnd As Long, sFile As String, fmt As eStreamFormats) As Long
    Dim of As OFSTRUCT
    If Len(sFile) = 0 Then Exit Function
    
    m_pos = 0 'not used for files but tidy up
    of.cBytes = LenB(of)
'    m_tEditStream.lCookie = OpenFile(sFile, of, OF_READ)
    m_tEditStream.lCookie = CreateFile(sFile, GENERIC_READ, 0, ByVal 0, OPEN_EXISTING, 0, 0)
     
    m_tEditStream.dwError = 0
    If m_tEditStream.lCookie = 0 Then Exit Function
    m_tEditStream.pfnCallback = PassAddressof(AddressOf EditStreamCallback)
    m_StreamContentType = sctFile
    
    'app will be blocked until we return non-zero value in the callback
    SendMessage hWnd, EM_STREAMIN, fmt, m_tEditStream
    'finished streaming though ctrl still loading text
    SendMessageLong hWnd, EM_SETMODIFY, 1, 0
    
    CloseHandle m_tEditStream.lCookie 'clean up
    
    StreamInFile = m_tEditStream.dwError
End Function
Public Function StreamInByte(hWnd As Long, b() As Byte, fmt As eStreamFormats) As Long
    m_B = b
    m_pos = 0
    
    m_tEditStream.dwError = 0
    m_tEditStream.pfnCallback = PassAddressof(AddressOf EditStreamCallback)
    m_StreamContentType = sctByte
    
    'app will be blocked until we return non-zero value in the callback
    SendMessage hWnd, EM_STREAMIN, fmt, m_tEditStream
    'finished streaming though ctrl still loading text
    SendMessageLong hWnd, EM_SETMODIFY, 1, 0
        
     ReDim m_B(0) 'free mem
    
    StreamInByte = m_tEditStream.dwError
End Function
Public Function StreamInStringAsByte(hWnd As Long, s As String, fmt As eStreamFormats) As Long
    Dim cRead As Long
    
    m_B = StrConv(s, vbFromUnicode)
    m_pos = 0
     
    m_tEditStream.dwError = 0
    m_tEditStream.pfnCallback = PassAddressof(AddressOf EditStreamCallback)
    
    m_StreamContentType = sctByte 'tell our callback what type of data we are sending
    
    'app will be blocked until we return non-zero value in the callback
    cRead = SendMessage(hWnd, EM_STREAMIN, fmt, m_tEditStream)
    'finished streaming though ctrl still loading text
    SendMessageLong hWnd, EM_SETMODIFY, 1, 0
        
     ReDim m_B(0) 'free mem
    
    StreamInStringAsByte = m_tEditStream.dwError
End Function
Private Function PassAddressof(ByVal pFunction As Long) As Long
    PassAddressof = pFunction
End Function