Date: 02-16-2022
Return to Index
created by gbSnippets
'Compilable Example: (Jose Includes)
#Compiler PBWin 10
#Compile Exe
#Dim All
%Unicode=1
#Include "win32api.inc"
#Include "RichEdit.inc"
Global hDlg As Dword, hRichEdit As Dword
%IDC_RichEdit = 500
%MultiLineREStyle = %WS_Child Or %WS_ClipSiblings Or %WS_Visible Or %ES_MultiLine Or %ES_AutoVScroll Or %WS_VScroll Or %ES_AutoHScroll Or %ES_WantReturn Or %ES_NoHideSel Or %WS_TabStop Or %ES_SaveSel
Function PBMain() As Long
Dialog Default Font "Tahoma", 18, 1
Dialog New Pixels, 0, "Test Code",,,800,150, %WS_OverlappedWindow To hDlg
LoadLibrary("msftedit.dll")
Control Add "RichEdit50W", hDlg, %IDC_RichEdit, "",0,0,600,150, %MultilineREStyle, %WS_Ex_ClientEdge
Control Handle hDlg, %IDC_RichEdit To hRichEdit
SendMessage hRichEdit, %EM_SetEventMask, 0, %ENM_SelChange Or %ENM_Link
SendMessage hRichEdit, %EM_AUTOURLDETECT, %True, 0 'ShowActiveLinks, 0
SendMessage(hRichEdit, %EM_SETTARGETDEVICE, 0, 0) 'Enable wordwrap
Dialog Show Modal hDlg Call DlgProc
End Function
CallBack Function DlgProc() As Long
Local RTFText As String, wWidth,hHeight As Long
Local a,b,c,d,e,f,g,h,i,j,k As String
Select Case Cb.Msg
Case %WM_InitDialog
RtfText = "{\rtf1\ansi\deff0 "+"{\expndtw360\expnd72 "+"Stuff before http://www.google.com \par"+"{\colortbl;\red0\green0\blue255;}" _
+"{\field{\*\fldinst{HYPERLINK "+$Dq+"http://www.garybeene.com"+$Dq _
+"}}{\fldrslt{\ul "+"Friendly"+"}}}"+"\par Stuff after"+"\expnd0\expndtw0 "+"}"
'RtfText = "{\rtf1\ansi\deff0 "+"{\expndtw360\expnd72 "+"Stuff before "+"{\colortbl;\red0\green0\blue255;}"+ +"{\field{\*\fldinst{HYPERLINK "+$Dq+"http://www.garybeene.com"+$Dq +"}}{\fldrslt{\ul "+"Friendly"+"}}}"+" Stuff after"+"\expnd0\expndtw0 "+"}"
' +------------------+ +---------------------+ +-------------+ +----------------------------------+ +----------------------------------+ +------------------------+ +---------------------+ +--------+ +---+ +------------+ +-----------------+ +-+
' rtf prefix wide char content color of hyperlink pre-hyperlink hyperlink text post-hyperlink frText close content post wide char suffix
A = "{\rtf1\ansi\deff0 " 'rtf prefix
B = "{\expndtw360\expnd72 " 'wide char
C = "Stuff before \par http://www.google.com \par" 'misc content, including non-friendly links
D = " More stuff \par" 'misc content
E = "{\colortbl;\red0\green0\blue255;}" 'colors for hyperlink
F = "{\field{\*\fldinst{HYPERLINK "+$Dq 'pre-hyperlink
G = "http://www.garybeene.com" 'hidden hyperlink
H = $Dq + "}}{\fldrslt{\ul "+"Friendly"+"}}}" 'friendly hyperlink
I = "\par Stuff after" 'misc content
J = "\expnd0\expndtw0 " 'close wide char
K = "}" 'rtf suffix
RtfText = A + B + C + D + E + F + G + H + I + J
RESetRTF hRichedit,RTFText
Case %WM_Size
Dialog Get Size hDlg To wWidth,hHeight
Control Set Size hdlg, %IDC_RichEdit, wWidth,hHeight
Case %WM_Help
? REGetRtf(hRichEdit)
Case %WM_Notify
Select Case Cb.NmId
Case %IDC_Richedit
Select Case Cb.NmCode
Case %EN_Link
REOpenLink(Cb.LParam)
End Select
End Select
End Select
End Function
' + $CrLf + "http://www.garybeene.com" _
' + $CrLf + "next is hidden url" _
' + $CrLf + $RtfA + "http://www.google.com" + $RtfB + "FriendlyURL" + $RtfC _
Function REOpenLink(ByVal enLinkPtr As ENLINK Pointer) As Long
Local temp$, Extension$, EZPart$
If @enLinkPtr.Msg = %WM_LButtonUp Then
Control Get Text hDlg, %IDC_RichEdit To temp$
Replace $CrLf With $Lf In temp$
temp$ = Mid$(temp$,@enLinkPtr.chrg.cpMin + 1 To @enLinkPtr.chrg.cpMax)
ShellExecute(hDlg, "Open", (temp$), $Nul, $Nul, %SW_ShowNormal)
End If
End Function
Function RESetRTF_Callback(ByVal pDwordArray As Dword Pointer, ByVal pRichEditBuffer As Dword, ByVal cb As Long, ByRef pcb As Long) As Long
pcb = Min(@pDwordArray[1], cb)
If pcb > 0 Then
CopyMemory(pRichEditBuffer, @pDwordArray[0], pcb)
@pDwordArray[0] = @pDwordArray[0] + pcb
@pDwordArray[1] = @pDwordArray[1] - pcb
End If
End Function
Function RESetRTF(ByVal hWin As Dword, ByVal RtfText As String) As Long 'Send rtf String to a RichEdit
Local EditStreamInfo As EDITSTREAM
Dim dwArray(0 To 1) As Dword
dwArray(0) = StrPtr(RtfText)
dwArray(1) = Len(RtfText)
EditStreamInfo.dwCookie = VarPtr(dwArray(0))
EditStreamInfo.pfnCallback = CodePtr(RESetRTF_Callback)
Function = SendMessage(hWin, %EM_STREAMIN, %SF_RTF Or %SFF_PLAINRTF, VarPtr(EditStreamInfo))
End Function
Function REGetRTF( ByVal hWndRTF As Long ) As String
Local ES As EDITSTREAM
Local sBuffer As String
es.dwCookie = VarPtr( sBuffer )
es.pfnCallback = CodePtr( REGetRTFCallback )
SendMessage( hWndRTF, %EM_STREAMOUT, %SF_RTF, VarPtr( es ) )
Function = sBuffer
End Function
Function REGetRTFCallback( ByVal dwCookie As Dword, ByVal pbbuff As Byte Ptr, ByVal CB As Long, ByRef pcb As Long ) As Long
Local psBuffer As String Ptr
psBuffer = dwCookie
If CB < 1 Then Exit Function
@psBuffer = @psBuffer & Peek$( pbbuff, CB )
pcb = CB
End Function
http://www.garybeene.com/sw/gbsnippets.htm