Tweet
' find and replace common dialog boxes in rich edit control
'
' if comments please post them in this link:
' http://www.powerbasic.com/support/pb...ad.php?t=11740
'
' this special version can be used in a rich edit control. the format of
' the text is preserved. thanks to bud meyer for the inspiration.
'
' many thanks also to borje hagsten and marty francom for highly inspiring code,
' which i have used in this program.
'
' best regards,
'
' erik christensen ------- april 19, 2005
'
' august 29, 2005: unimportant small change made.
[this message has been edited by erik christensen (edited august 29, 2005).]
'
' if comments please post them in this link:
' http://www.powerbasic.com/support/pb...ad.php?t=11740
'
' this special version can be used in a rich edit control. the format of
' the text is preserved. thanks to bud meyer for the inspiration.
'
' many thanks also to borje hagsten and marty francom for highly inspiring code,
' which i have used in this program.
'
' best regards,
'
' erik christensen ------- april 19, 2005
'
' august 29, 2005: unimportant small change made.
Code:
#compile exe
#register none
#dim all
'
#include "win32api.inc"
#include "comdlg32.inc"
#include "richedit.inc"
'
%textbox1 = 100
%buttonfind = 105
%buttonreplace = 110
%buttonexit = 115
'
global hform1&
global msgfindreplace as long
global hdlgmodeless as long
global gpos as long, gptr as long, gtxt as string
'
'
function openfindorreplacetextdialog (byval hwnd as long, byval ind as long, byval flgs as long) as long
static fr as findreplace, ztxt as asciiz * 256, ztxt2 as asciiz * 256
'
' the dialog remembers the find-string and replace-string between calls.
' there is no need to set them here.
'
fr.lstructsize = sizeof(fr)
fr.hwndowner = hwnd
fr.hinstance = %null
' first time set flags to downward search direction - else to previous values.
if istrue flgs then fr.flags = flgs else fr.flags = %fr_down or %fr_hideupdown ' this method only allows downward search
fr.lpstrfindwhat = varptr(ztxt)
fr.wfindwhatlen = sizeof(ztxt)
fr.lpstrreplacewith = varptr(ztxt2)
fr.wreplacewithlen = sizeof(ztxt2)
fr.lcustdata = 0
fr.lpfnhook = %null
fr.lptemplatename = %null
'
if ind = 1 then function = findtext(fr)
if ind = 2 then function = replacetext(fr)
'
end function
'
'
function dofindreplaceaction(byval llparam as long,byval hwnd as long, byval id as long, byref flgs as long) as long
static txt as string
static ipos as long
static match as long
static przt as string
static lppfr as findreplace ptr
static zt as asciiz ptr, zt2 as asciiz ptr
local cr as charrange
local tf as textrange
local buf as string
local textmax&, searchflag&, res& '
lppfr = llparam
if (@lppfr.flags and %fr_dialogterm) then ' find or replace dialog is closed
hdlgmodeless = %null : function = 0 : exit function
end if
'
flgs = @lppfr.flags ' save flags for next call
zt = @lppfr.lpstrfindwhat ' text to search for
zt2 = @lppfr.lpstrreplacewith ' replacing text if any
'
' determine flags for specification of search
searchflag& = 0
if (@lppfr.flags and %fr_matchcase) then searchflag& = searchflag& or %fr_matchcase
if (@lppfr.flags and %fr_wholeword) then searchflag& = searchflag& or %fr_wholeword
'
' find caret or selection, if any
control send hwnd, id,%em_exgetsel,0,varptr(cr)
'
if (@lppfr.flags and %fr_findnext) then ' find next
gosub positioncheck : gosub search
if isfalse match then msgbox "no match found",%mb_iconinformation, "find"
elseif (@lppfr.flags and %fr_replace) then ' replace
gosub search
if istrue match then
control send hwnd, id, %em_replacesel, %true, zt2
cr.cpmax = cr.cpmin + len(@zt2)
control send hwnd, id, %em_exsetsel,0,varptr(cr)
gosub search
if isfalse match then msgbox "no further match found",%mb_iconinformation, "find"
else
msgbox "no match found",%mb_iconinformation, "find"
end if
elseif (@lppfr.flags and %fr_replaceall) then ' replace all
gosub search
if istrue match then
do
control send hwnd, id, %em_replacesel, %true, zt2
cr.cpmax = cr.cpmin + len(@zt2)
control send hwnd, id, %em_exsetsel,0,varptr(cr)
gosub search
loop until isfalse match ' loop until no more matches
else
msgbox "no match found",%mb_iconinformation, "find"
end if
end if
function = 1 : exit function
'
positioncheck:
' get selected text for checking purposes
tf.chrg.cpmin = cr.cpmin
tf.chrg.cpmax = cr.cpmax
buf = space$(cr.cpmax - cr.cpmin + 1)
tf.lpstrtext = strptr(buf)
control send hwnd, id, %em_gettextrange, 0, varptr(tf)
'
' adjust start position of search if necessary - to avoid being stuck in the same place.
if (left$(ucase$(buf),len(buf)-1) = przt) and (cr.cpmin < cr.cpmax) then incr cr.cpmin
return
'
search:
' get upper limit of searching range
control send hwnd, id, %em_getlimittext,0,0 to textmax&
tf.chrg.cpmin = cr.cpmin
tf.chrg.cpmax = textmax&
tf.lpstrtext = zt
'
' do specified search for specified text
control send hwnd, id, %em_findtext, searchflag&, varptr(tf) to ipos
if ipos <> -1 then ' search is successful
cr.cpmin = ipos
cr.cpmax = cr.cpmin + len(@zt)
'
' select found text
control send hwnd, id, %em_exsetsel, 0, varptr(cr)
' save search string for checking purposes.
przt = ucase$(trim$(@zt))
' match found
match = %true
else
match = %false
end if
return
'
end function
'
'
callback function form1_dlgproc
static flgs as long ' saving find or replace flags between calls.
'
select case cbmsg
case msgfindreplace ' this is the message registered
' do actions in response to your input in the dialog box
function = dofindreplaceaction(cblparam, cbhndl, %textbox1, flgs)
'
case %wm_destroy
postquitmessage 0
'
case %wm_command
select case cbctlmsg
case %bn_clicked, 1 ' accelerator notification codes have cbctlmsg set to 1.
select case cbctl
case %buttonfind
hdlgmodeless = openfindorreplacetextdialog(cbhndl, 1, flgs)
function = 1
case %buttonreplace
hdlgmodeless = openfindorreplacetextdialog(cbhndl, 2, flgs)
function = 1
case %buttonexit
dialog end cbhndl, 0
function = 1
case else
end select
case else
end select
case else
end select
end function
'
'
' this wonderful function has been provided by martin francom. thanks a lot!
'
'*** this routine will allow you to 'programmatically' create
'*** rtf files that can be displayed/printed by wordpad or rtfprint.exe
'*** you could expand this function by adding code for 'tables' and 'graphics'
'*** if you make improvements, please post them to this forum so
'*** all pb'ers may benifit.
'*** this routine is released to public domain by martin framcom
'
function rtf (st$) as string
local fontsize&
if instr(ucase$(st$),"font") then ' ie "fontc24"
fontsize&= val(mid$(st$,6)): st$= mid$(st$,5,1)
end if
select case ucase$(st$)
case "start"
st$ = "{\rtf1\ansi\ansicpg1252\deff0\deflang1033\deflangfe1033"+ $crlf
st$ = st$ + "{\fonttbl{\f0\fmodern\fprq1\fcharset0 courier new;}"+ $crlf
st$ = st$ + "{\f1\fnil\fcharset0 times new roman;}"+ $crlf
st$ = st$ + "{\f2\fmodern\fprq1\fcharset0 andale mono;}"+ $crlf
st$ = st$ + "{\f3\fmodern\fprq1\fcharset0 lucida console;}"+ $crlf
st$ = st$ + "{\f4\froman\fprq2\fcharset0 georgia;}}" + $crlf
st$ = st$ + "{\colortbl "+ $crlf
st$ = st$ + ";\red128\green0\blue0"+ $crlf
st$ = st$ + ";\red0\green128\blue0"+ $crlf
st$ = st$ + ";\red128\green128\blue0"+ $crlf
st$ = st$ + ";\red0\green0\blue128"+ $crlf
st$ = st$ + ";\red128\green0\blue128"+ $crlf
st$ = st$ + ";\red0\green128\blue128"+ $crlf
st$ = st$ + ";\red128\green128\blue128"+ $crlf
st$ = st$ + ";\red192\green192\blue192"+ $crlf
st$ = st$ + ";\red255\green0\blue0"+ $crlf
st$ = st$ + ";\red0\green255\blue0"+ $crlf
st$ = st$ + ";\red255\green255\blue0"+ $crlf
st$ = st$ + ";\red0\green0\blue255"+ $crlf
st$ = st$ + ";\red255\green0\blue255"+ $crlf
st$ = st$ + ";\red0\green255\blue255"+ $crlf
st$ = st$ + ";\red255\green255\blue255;}"+ $crlf
st$ = st$ + "\cf1\f0\fs11 " + $crlf
case "c" 'courier new fixed size
if fontsize& > 10 and fontsize& < 72 then st$ = "\f0" else st$="
case "t" 'times new roman variable size
if fontsize& > 10 and fontsize& < 72 then st$ = "\f1" else st$="
case "a" 'andale mono fixed size
if fontsize& > 10 and fontsize& < 72 then st$ = "\f2" else st$="
case "l" 'lucidia console fixed size
if fontsize& > 10 and fontsize& < 72 then st$ = "\f3" else st$="
case "g" 'lucidia console fixed size
if fontsize& > 10 and fontsize& < 72 then st$ = "\f4" else st$="
case "end" 'end of rtf file
st$ = "} "
case "eol" 'end of line
st$ = "\line "
case "eop" 'end of paragraph
st$ = "\par "
case "newpage" 'end of page
st$ = "\page "
case "bold"
st$ = "\b "
case "unbold"
st$ = "\b0 "
case "italic"
st$ = "\i "
case "unitalic"
st$ = "\i0 "
case "underline"
st$ = "\ul "
case "ununderline"
st$ = "\ul0 "
case "center"
st$ = "\pard\qc "
case "right"
st$ = "\pard\qr "
case "left"
st$ = "\pard "
case "black" 'foreground color
st$ = "\cf0 "
case "maroon" 'foreground color
st$ = "\cf1 "
case "green" 'foreground color
st$ = "\cf2 "
case "olive" 'foreground color
st$ = "\cf3 "
case "navy" 'foreground color
st$ = "\cf4 "
case "purple" 'foreground color
st$ = "\cf5 "
case "teal" 'foreground color
st$ = "\cf6 "
case "grey" 'foreground color
st$ = "\cf7 "
case "silver" 'foreground color
st$ = "\cf8 "
case "red" 'foreground color
st$ = "\cf9 "
case "lime" 'foreground color
st$ = "\cf10 "
case "yellow" 'foreground color
st$ = "\cf11 "
case "blue" 'foreground color
st$ = "\cf12 "
case "fuchsia" 'foreground color
st$ = "\cf13 "
case "auqua" 'foreground color
st$ = "\cf14 "
case "white" 'foreground color
st$ = "\cf15 "
case else
st$="
end select
select case fontsize&
case 5
st$ = st$ + "\fs11 "
case 6
st$ = st$ + "\fs12 "
case 7
st$ = st$ + "\fs14 "
case 8
st$ = st$ + "\fs16 "
case 9
st$ = st$ + "\fs18 "
case 10
st$ = st$ + "\fs20 "
case 11
st$ = st$ + "\fs22 "
case 12
st$ = st$ + "\fs24 "
case 14
st$ = st$ + "\fs28 "
case 16
st$ = st$ + "\fs32 "
case 18
st$ = st$ + "\fs36 "
case 20
st$ = st$ + "\fs40 "
case 22
st$ = st$ + "\fs44 "
case 24
st$ = st$ + "\fs48 "
case 26
st$ = st$ + "\fs52 "
case 28
st$ = st$ + "\fs56 "
case 36
st$ = st$ + "\fs72 "
case 48
st$ = st$ + "\fs96 "
case 72
st$ = st$ + "\fs144 "
end select
rtf=st$
end function
'
' this fine function has been provided by borje hagsten. many thanks.
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
' rich edit stream in callback - for streaming in string contents
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
function richeditstreaminstring (byval dwcookie as dword, byval pbbuff as byte ptr, _
byval cb as long, pcb as long) as dword
pcb = cb 'number of bytes to copy
if pcb > 0 then 'copy block from global string directly into richedit's buffer.
copymemory pbbuff, (gptr + gpos - 1), pcb 'could use poke$ too, but this is a bit faster
gpos = gpos + pcb 'incr pos for next callback position.
end if
end function
'
'
function pbmain
local msg as tagmsg
local haccel as long
local rtfst$
local hlib as long
local ff as long, t as single, estream as editstream
dim ac(0 to 2) as accelapi
' register a message for the find or replace dialog.
msgfindreplace = registerwindowmessage ("commdlg_findreplace")
dialog new 0, "find and replace common dialogs in rich edit control", 0, 0, 357, 246, _
%ws_popup or %ds_modalframe or %ws_caption or %ws_minimizebox or %ws_sysmenu or %ds_center, 0 to hform1&
control add button, hform1&, %buttonfind, "find - ctrl+f", 32, 219, 80, 15, _
%ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop
control add button, hform1&, %buttonreplace, "replace - ctrl+r", 139, 219, 80, 15, _
%ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop
control add button, hform1&, %buttonexit, "exit - alt+x", 245, 219, 80, 15, _
%ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop
'
' rtf text originally provided by marty francom. many thanks.
rtfst$= rtf("start")+ rtf("fontc72")+ rtf("center")+rtf("maroon")+"sample file"+rtf("eop")
rtfst$=rtfst$ + rtf("left")+rtf("black")+ rtf("fonta12")
rtfst$=rtfst$ + "this routine built by marty francom, use it, modify it, share it with"+rtf("eol")
rtfst$=rtfst$ + "others as you see fit. if you make improvements or add features, please"+rtf("eol")
rtfst$=rtfst$ + "share them with the powerbasic forum." +rtf("eol")+rtf("eop")
rtfst$=rtfst$ + rtf("fontg14")+ rtf("green")
rtfst$=rtfst$ + "when building an rtf file with this routine always start"+rtf("eol")
rtfst$=rtfst$ + "the file with rtf('start') and end building the file"+rtf("eol")
rtfst$=rtfst$ + "with rtf('end')" + rtf("bold")+ rtf("fuchsia") +" everything else is optional."+ rtf("unbold")+rtf("eop")
rtfst$=rtfst$ + rtf("eol") 'rtf("newpage")
rtfst$=rtfst$ + rtf("left")+rtf("red")+ rtf("fontl16")+rtf("unbold") + rtf("italic")
rtfst$=rtfst$ + "some italic text in newtimesroman font 16 point in red." +rtf("eol")+rtf("eop")
rtfst$=rtfst$ + rtf("right")+rtf("red")+ rtf("fontc12")+rtf("unitalic") + rtf("bold")
rtfst$=rtfst$ + "some bold text in courier font 12 point in blue. right justified." + rtf("eol")+rtf("eol")
rtfst$=rtfst$ + rtf("left")+rtf("green")+ rtf("unbold")
rtfst$=rtfst$ + rtf("fontt10")+"some text"+ rtf("blue")+rtf("fontl22")+" in different" + rtf("fonta16")+ rtf("maroon")+" font sizes "+ rtf("fontn8")+ rtf("black")+rtf("bold")+ "and colors." +rtf("eol")+rtf("eop")
rtfst$=rtfst$ + rtf("fontt16")+ "the command line syntax is rtfprint filename.rtf action& numcopy&"+rtf("eol")
rtfst$=rtfst$ + rtf("center")+ rtf("fontt20")+ rtf("fuchsia") +"ie: rtfprint sample.rtf 0 2" + rtf("eol")
rtfst$=rtfst$ + rtf("end")
'
hlib = loadlibrary("riched32.dll")
if hlib = 0 then exit function
control add "richedit", hform1&, %textbox1, ", 32, 27, 293, 180, _
%ws_child or %ws_visible or %es_multiline or %es_nohidesel or %es_wantreturn or %es_left or %es_autovscroll or %ws_vscroll or %ws_tabstop, _
%ws_ex_clientedge
'
gtxt = rtfst$
' this code was provided by borje hagsten. thanks.
gpos = 1 'position in text to start from
gptr = strptr(gtxt) 'pointer to global text buffer
estream.pfncallback = codeptr(richeditstreaminstring) 'pointer to richedit callback procedure
control send hform1&, %textbox1, %em_streamin, %sf_rtf, varptr(estream) 'stream in text
'
' attach keyboard accelerators.
ac(0).fvirt = %fcontrol or %fvirtkey
ac(0).key = asc("f")
ac(0).cmd = %buttonfind
ac(1).fvirt = %fcontrol or %fvirtkey
ac(1).key = asc("r")
ac(1).cmd = %buttonreplace
ac(2).fvirt = %falt or %fvirtkey
ac(2).key = asc("x")
ac(2).cmd = %buttonexit
accel attach hform1&, ac() to haccel
'
dialog show modeless hform1& , call form1_dlgproc
'
' expanded sdk-style main message loop
' acquire and dispatch messages until a wm_quit message is received.
'
' this particular version was originally proposed by dominic mitchell - thanks!
while istrue getmessage(msg, byval %null, 0, 0)
' if isfalse translatemdisysaccel(ghwndclient, msg) then
if isfalse translateaccelerator(hform1, haccel, msg) then
if isfalse isdialogmessage(hdlgmodeless, msg) then
translatemessage msg
dispatchmessage msg
end if
end if
' end if
wend
end function
[this message has been edited by erik christensen (edited august 29, 2005).]