File "RTF.inc"
Path: /ShuffleGUI/inc/RTF.inc
File size: 17.17 KB
MIME-type:
Charset: 8 bit
'##############################################################################
'#
'# This is one of the include files for << RFO-BASIC! Quick APK >>
'#
'# "rtf.inc" contains functions to display Rich Text Format
'#
'##############################################################################
'
' Syntax to specify Fonts
' ===============================================================
' [font:X,size] where 7 <= size <= 72 and X is a 1-letter code:
' C = Courier New Fixed Size
' T = Times New Roman Variable Size
' A = Andale Mono Fixed Size
' L = Lucida Console Fixed Size
' G = Georgia Console Fixed Size
' O = Open Sans Variable Size
'
' Syntax to specify (foreground) RTF_Col
' ===============================================================
' [col] where col is a color name among:
' Black, Maroon, Green, Olive, Navy, Purple, Teal, Grey,
' Silver, Red, Lime, Yellow, Blue, Fuschia, Aqua, White
'
' Use RTF_ADDCOL "CustomBlue", 80, 80, 120 to add a RGB color
'
' Syntax to specify Format
' ===============================================================
' [b][/b] = bold
' [i][/i] = italic
' [u][/u] = underline
' [h:col][/h] = highlight with color "col" (specified above)
'
' Syntax to specify Alignment
' ===============================================================
' [c] = centered
' [r] = right-aligned
' [l] = left-aligned
' [j] = justified
'
' Syntax to specify Delimiters
' ===============================================================
' [eol] = End Of Line
' [eo] = [eop] = End Of Paragraph
' [np] = New Page
'
' IN ORDER TO PROCESS URLs IN YOUR CALLBACK:
' ===============================================================
' SELECT CASE CB.MSG
' CASE %WM_NOTIFY
' IF CB.NMID = RichEditCtl AND CB.NMCODE = %EN_LINK THEN RTF_hyperlink (CB.HNDL, RichEditCtl, CB.LPARAM)
#INCLUDE ONCE "RICHEDIT.INC"
GLOBAL RTF_ColNam() AS STRING
GLOBAL RTF_ColVal() AS STRING
'-----------------------------------------------------------------------------------------------------------------
FUNCTION StrReplace(mainstring AS STRING, look4 AS STRING, replacement AS STRING) AS STRING
LOCAL e AS STRING
e = mainstring
REPLACE look4 WITH replacement IN e
FUNCTION = e
END FUNCTION
'-----------------------------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------------------------
FUNCTION RTF_ExampleOfDialog AS DWORD ' Returns handle to the newly created dialog
LOCAL richtext AS STRING
LOCAL hDlg AS DWORD
LoadLibrary("RICHED32.DLL")
DIALOG NEW PIXELS, 0, "RichEdit Dialog", , , 800, 600, %WS_SYSMENU TO hDlg
DIALOG SET COLOR hDlg, -1, %WHITE
CONTROL ADD "RichEdit", hDlg, 1001, "Test2", 7, 7, 785, 585, %WS_CHILD OR _
%WS_VISIBLE OR %ES_MULTILINE OR %ES_READONLY OR %WS_VSCROLL
richtext = "[font:c,72][c][maroon]Sample File[eop]"
richtext += "[l][black][font:a,12]This routine built by [h:aqua]Marty Francom[/h], "
richtext += "use it, modify it, share it with[eol]"
richtext += "others as you see fit. If you make improvements or add features, please[eol]"
richtext += "share them with the http://powerbasic.com Forum.[eol][eop]"
richtext += "[font:g,14][green]When building an RTF file with this routine alway start[eol]"
richtext += "the file with RTF('Start') and end building the file[eol]"
richtext += "with RTF('End')[b][fuchsia] Everything ELSE is optional.[/b][eop]"
richtext += "[eol]" '+ "[np]"
richtext += "[l][red][font:l,16][i]Some Italic Text in NewTimesRoman Font [/i]16 Point in Red.[eol][eop]"
richtext += "[r][blue][font:c,12][b]Some BOLD Text in Courier Font 12 Point in Blue. Right Justified.[eol][eol]"
richtext += "[l][green][/b][font:t,10]Some Text[blue][font:l,22] in different[font:a,16][maroon] font sizes "
richtext += "[font:n,8][black][b]and RTF_Col.[/b][eol][eop]"
richtext += "[font:t,16]The Command Line Syntax is RTFPRINT Filename.RTF Action& NumCopy&[eol]"
richtext += "[c][font:t,20][fuchsia]ie: RTFPRINT Sample.Rtf 0 2[eol][eop]"
RTF_SET hDlg, 1001, richtext
FUNCTION = hDlg
END FUNCTION
'-----------------------------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------------------------
SUB RTF_SET (hWnd AS DWORD, hCtl AS DWORD, rt AS STRING)
SUBCLASS (hWnd, hCtl, RTF_SUBCLASS) ' Comment that if you want to be able to edit the text (and see a caret)
CONTROL SEND hWnd, hCtl, %EM_SETBKGNDCOLOR, 0, GETSYSCOLOR(%COLOR_BTNFACE)
SendMessage GetDlgItem(hWnd, hCtl), %EM_SETEVENTMASK, 0, %ENM_SELCHANGE OR %ENM_CHANGE OR %ENM_LINK
CONTROL SEND hWnd, hCtl, %EM_AUTOURLDETECT, %True, 0
CONTROL SET TEXT hWnd, hCtl, RTF(rt)
CONTROL POST hWnd, hCtl, %WM_KILLFOCUS, 0, 0 ' Comment that if you want to be able to edit the text (and see a caret)
END SUB
'-----------------------------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------------------------
SUB RTF_ADDCOL (colnam AS STRING, red AS LONG, green AS LONG, blue AS LONG)
IF UBOUND(RTF_ColNam) < 0 THEN
DIM RTF_ColNam(15)
DIM RTF_ColVal(15)
ARRAY ASSIGN RTF_ColNam() = _
"Black", "Maroon", "Green", "Olive", _
"Navy", "Purple", "Teal", "Grey", _
"Silver", "Red", "Lime", "Yellow", _
"Blue", "Fuschia", "Aqua", "White"
ARRAY ASSIGN RTF_ColVal() = _
";\red0\green0\blue0", _
";\red128\green0\blue0", _
";\red0\green128\blue0", _
";\red128\green128\blue0", _
";\red0\green0\blue128", _
";\red128\green0\blue128", _
";\red0\green128\blue128", _
";\red128\green128\blue128", _
";\red192\green192\blue192", _
";\red255\green0\blue0", _
";\red0\green255\blue0", _
";\red255\green255\blue0", _
";\red0\green0\blue255", _
";\red255\green0\blue255", _
";\red0\green255\blue255", _
";\red255\green255\blue255"
END IF
IF colnam <> "" THEN
REDIM PRESERVE RTF_ColNam(UBOUND(RTF_ColNam) + 1)
REDIM PRESERVE RTF_ColVal(UBOUND(RTF_ColNam))
RTF_ColNam(UBOUND(RTF_ColNam)) = colnam
RTF_ColVal(UBOUND(RTF_ColNam)) = ";\red" + TRIM$(STR$(red)) _
+ "\green" + TRIM$(STR$(green)) _
+ "\blue" + TRIM$(STR$(blue))
END IF
END SUB
'-----------------------------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------------------------
FUNCTION RTF (st AS STRING) AS STRING
LOCAL fs, hl, i, j AS LONG
LOCAL rt, bef, p, aft AS STRING
IF UBOUND(RTF_ColNam) < 0 THEN RTF_AddCol ("",0,0,0)
rt = "{\rtf1\ansi\ansicpg1252\deff0\deflang1033\deflangfe1033"+ $CRLF
rt += "{\fonttbl"
rt += "{\f0\fmodern\fprq1\fcharset0 Courier New;}"+ $CRLF
rt += "{\f1\fnil\fcharset0 Times New Roman;}"+ $CRLF
rt += "{\f2\fmodern\fprq1\fcharset0 Andale Mono;}"+ $CRLF
rt += "{\f3\fmodern\fprq1\fcharset0 Lucida CONSOLE;}"+ $CRLF
rt += "{\f4\froman\fprq2\fcharset0 Georgia;}" + $CRLF
rt += "{\f5\fnil\fcharset0 Open Sans;}}"+ $CRLF
rt += "{\colortbl "+ $CRLF ' cf0 = black
FOR i = 1 TO UBOUND(RTF_ColNam)
rt += RTF_ColVal(i) + IIF$(i=UBOUND(RTF_ColNam), ";}", "") + $CRLF
NEXT
rt += "\cf1\f0\fs11 " + $CRLF
rt += StrReplace(st,"\","\\") + "} " ' End of RTF File
' [*] for bullet lists
'===============================================================
REPLACE "[*]" WITH CHR$(7) + $SPC IN rt
' [font:X,size] where 7 <= size <= 72 and X is a 1-letter code
'===============================================================
i = INSTR(UCASE$(rt), "[FONT:")
DO WHILE i
j = INSTR(i, rt, "]")
bef = MID$(rt, i, j-i+1)
fs = VAL(MID$(bef, 9)) ' File Size
IF fs >= 7 AND fs <= 72 THEN
p = MID$(bef, 7, 1)
SELECT CASE UCASE$(p)
CASE "C" : aft = "\f0 " ' Courier New Fixed Size
CASE "T" : aft = "\f1 " ' Times New Roman Variable Size
CASE "A" : aft = "\f2 " ' Andale Mono Fixed Size
CASE "L" : aft = "\f3 " ' Lucida Console Fixed Size
CASE "G" : aft = "\f4 " ' Georgia Console Fixed Size
CASE "O" : aft = "\f5 " ' Open Sans Variable Size
CASE ELSE : aft = "\f1 " ' Times New Roman Variable Size
END SELECT
aft += "\fs" + TRIM$(STR$(2 * fs)) + $SPC
REPLACE bef WITH aft IN rt
ELSE
REPLACE bef WITH "" IN rt
END IF
i = INSTR(UCASE$(rt), "[FONT:")
LOOP
' [col] where col is a color name belonging to RTF_Col()
'===============================================================
FOR j = 0 TO UBOUND(RTF_ColNam)
i = INSTR(UCASE$(rt), "[" + UCASE$(RTF_ColNam(j)) + "]")
DO WHILE i
bef = MID$(rt, i, LEN("[" + RTF_ColNam(j) + "]"))
p = TRIM$(bef, ANY "[]")
aft = "\cf" + TRIM$(STR$(j)) + $SPC
REPLACE bef WITH aft IN rt
i = INSTR(UCASE$(rt), "[" + UCASE$(RTF_ColNam(j)) + "]")
LOOP
NEXT
' [b][/b] = bold
'===============================================================
i = INSTR(UCASE$(rt), "[B]")
DO WHILE i
bef = MID$(rt, i, 3)
aft = "\b "
REPLACE bef WITH aft IN rt
i = INSTR(UCASE$(rt), "[B]")
LOOP
i = INSTR(UCASE$(rt), "[/B]")
DO WHILE i
bef = MID$(rt, i, 4)
aft = "\b0 "
REPLACE bef WITH aft IN rt
i = INSTR(UCASE$(rt), "[/B]")
LOOP
' [i][/i] = italic
'===============================================================
i = INSTR(UCASE$(rt), "[I]")
DO WHILE i
bef = MID$(rt, i, 3)
aft = "\i "
REPLACE bef WITH aft IN rt
i = INSTR(UCASE$(rt), "[I]")
LOOP
i = INSTR(UCASE$(rt), "[/I]")
DO WHILE i
bef = MID$(rt, i, 4)
aft = "\i0 "
REPLACE bef WITH aft IN rt
i = INSTR(UCASE$(rt), "[/I]")
LOOP
' [u][/u] = underline
'===============================================================
i = INSTR(UCASE$(rt), "[U]")
DO WHILE i
bef = MID$(rt, i, 3)
aft = "\ul "
REPLACE bef WITH aft IN rt
i = INSTR(UCASE$(rt), "[U]")
LOOP
i = INSTR(UCASE$(rt), "[/U]")
DO WHILE i
bef = MID$(rt, i, 4)
aft = "\ul0 "
REPLACE bef WITH aft IN rt
i = INSTR(UCASE$(rt), "[/U]")
LOOP
' [h:col][/h] = highlight with color "col" (specified above)
'===============================================================
i = INSTR(UCASE$(rt), "[H:")
DO WHILE i
j = INSTR(i, rt, "]")
bef = MID$(rt, i, j-i+1)
p = MID$(bef, 4) : p = RTRIM$(p, "]")
fs = -1
FOR j = 0 TO UBOUND(RTF_ColNam)
IF UCASE$(p) = UCASE$(RTF_ColNam(j)) THEN
fs = j
EXIT FOR
END IF
NEXT
IF fs >= 0 THEN
aft = "{\highlight" + TRIM$(STR$(fs))
REPLACE bef WITH aft IN rt
ELSE
REPLACE bef WITH "" IN rt
END IF
i = INSTR(UCASE$(rt), "[H:")
LOOP
i = INSTR(UCASE$(rt), "[/H]")
DO WHILE i
bef = MID$(rt, i, 4)
aft = "}"
REPLACE bef WITH aft IN rt
i = INSTR(UCASE$(rt), "[/H]")
LOOP
' [c] = centered
'===============================================================
i = INSTR(UCASE$(rt), "[C]")
DO WHILE i
bef = MID$(rt, i, 3)
aft = "\pard\qc "
REPLACE bef WITH aft IN rt
i = INSTR(UCASE$(rt), "[C]")
LOOP
' [r] = right-aligned
'===============================================================
i = INSTR(UCASE$(rt), "[R]")
DO WHILE i
bef = MID$(rt, i, 3)
aft = "\pard\qr "
REPLACE bef WITH aft IN rt
i = INSTR(UCASE$(rt), "[R]")
LOOP
' [l] = left-aligned
'===============================================================
i = INSTR(UCASE$(rt), "[L]")
DO WHILE i
bef = MID$(rt, i, 3)
aft = "\pard "
REPLACE bef WITH aft IN rt
i = INSTR(UCASE$(rt), "[L]")
LOOP
' [j] = justified
'===============================================================
i = INSTR(UCASE$(rt), "[J]")
DO WHILE i
bef = MID$(rt, i, 3)
aft = "\pard\qj "
REPLACE bef WITH aft IN rt
i = INSTR(UCASE$(rt), "[J]")
LOOP
' [eol] = End Of Line
'===============================================================
i = INSTR(UCASE$(rt), "[EOL]")
DO WHILE i
bef = MID$(rt, i, 5)
aft = "\line "
REPLACE bef WITH aft IN rt
i = INSTR(UCASE$(rt), "[EOL]")
LOOP
' [eo] = End Of Paragraph
'===============================================================
i = INSTR(UCASE$(rt), "[EOP]")
DO WHILE i
bef = MID$(rt, i, 5)
aft = "\par "
REPLACE bef WITH aft IN rt
i = INSTR(UCASE$(rt), "[EOP]")
LOOP
i = INSTR(UCASE$(rt), "[EO]")
DO WHILE i
bef = MID$(rt, i, 5)
aft = "\par "
REPLACE bef WITH aft IN rt
i = INSTR(UCASE$(rt), "[EO]")
LOOP
' [np] = New Page
'===============================================================
i = INSTR(UCASE$(rt), "[NP]")
DO WHILE i
bef = MID$(rt, i, 4)
aft = "\page "
REPLACE bef WITH aft IN rt
i = INSTR(UCASE$(rt), "[NP]")
LOOP
FUNCTION = rt
END FUNCTION
'-----------------------------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------------------------
FUNCTION RTF_hyperlink(BYVAL hWnd AS DWORD, BYVAL hCtl AS DWORD, BYVAL lpLink AS DWORD) AS LONG
LOCAL enlinkPtr AS ENLINK PTR
LOCAL linkText AS STRING
LOCAL tr AS TEXTRANGE
enlinkPtr = lpLink
tr.chrg = @enLinkPtr.chrg
linkText = SPACE$(tr.chrg.cpMax - tr.chrg.cpMin + 2)
tr.lpstrText = STRPTR(linkText)
CONTROL SEND hWnd, hCtl, %EM_GETTEXTRANGE, 0, VARPTR(tr)
SELECT CASE @enLinkPtr.Msg
CASE %WM_LBUTTONDOWN
ShellExecute(%NULL, "open", BYCOPY linkText, "", "", %SW_SHOW)
FUNCTION = %True ' Signal that we processed this
CASE %WM_MOUSEMOVE
END SELECT
END FUNCTION
'-----------------------------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------------------------
MACRO SUBCLASS(hWnd, hCtl, Fn) = _
SetProp GetDlgItem(hWnd, hCtl), "OldProc", SetWindowLong(GetDlgItem(hWnd, hCtl), %GWL_WNDPROC, CODEPTR(Fn))
'-----------------------------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------------------------
FUNCTION RTF_SUBCLASS(BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG
LOCAL tcr AS CHARRANGE
LOCAL OldProc AS LONG
LOCAL lRetVal AS LONG
OldProc=GetProp(hWnd, "OldProc")
SELECT CASE wMsg
CASE %WM_SETFOCUS
FUNCTION=CallWindowProc(OldProc, hWnd, wMsg, wParam, lParam)
DestroyCaret
EXIT FUNCTION
CASE %WM_KILLFOCUS
' The control destroys the caret
CASE %WM_PAINT
' Remove caret the first time the control is painted
IF GetFocus() = hWnd THEN
IF GetProp(hWnd, "Initial_Paint") = 0 THEN
SetProp hWnd, "Initial_Paint", 1
CallWindowProc(OldProc, hWnd, wMsg, wParam, lParam)
DestroyCaret
EXIT FUNCTION
END IF
END IF
CASE %WM_LBUTTONDOWN
CallWindowProc(OldProc, hWnd, wMsg, wParam, lParam)
SendMessage hWnd, %EM_EXGETSEL, 0, BYVAL VARPTR(tcr)
IF tcr.cpMin = tcr.cpMax THEN
DestroyCaret
END IF
EXIT FUNCTION
CASE %WM_KEYDOWN
IF GetFocus() = hWnd THEN
lRetVal = CallWindowProc(OldProc, hWnd, wMsg, wParam, lParam)
SendMessage hWnd, %EM_EXGETSEL, 0, BYVAL VARPTR(tcr)
IF tcr.cpMin = tcr.cpMax THEN
DestroyCaret
END IF
FUNCTION = lRetVal
EXIT FUNCTION
END IF
CASE %WM_DESTROY
RemoveProp hWnd, "Initial_Paint"
RemoveProp hWnd, "OldProc"
SetWindowLong hWnd, %GWL_WNDPROC, OldProc
END SELECT
FUNCTION=CallWindowProc(OldProc, hWnd, wMsg, wParam, lParam)
END FUNCTION
'-----------------------------------------------------------------------------------------------------------------