Using EM_STREAMIN to Load a RichTextBox
| Loading an RTB with megabytes of text can easily freeze the control
for several seconds. EM_STREAMIN allows for responsiveness almost instantaneously
while the data is still being streamed into the control. |
 |
Download source code with a test app (7KB)
Option Explicit
'RTB StreamIn.vbp
'
'
'Copyright by Arthur A. Marks, ambytes@cox.net
'
'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