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. |
Option Explicit 'RTB StreamIn.vbp ' ' 'Copyright by Arthur A. Marks, arthurruhtra@netscape.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