Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

RTF made easy for RichEdit

Collapse
X
Collapse
 
  • Page of 1
  • Filter
  • Time
  • Show
Clear All
new posts
Previous template Next
    #1

    RTF made easy for RichEdit

    Below is my wrapper for making RTF commands easier to understand and use in a RichEdit.

    According to http://www.biblioscape.com/rtf15_spec.htm#Heading52
    there is a TON of stuff to the RTF and I am only scratching the surface, but this will give users a leg up on learning RTF.

    Discussion on the concept can be found at http://www.powerbasic.com/support/pb...ad.php?t=39482

    The RichEdit window shows the resulting code, and the textbox shows how the code would appear if it were all text (with RTF commands)

    Now for the fun stuff

    StringAsRichTextFormat.inc
    Code:
    '*************************************************************************************************************
'*** Project:
'***      StringAsRichTextFormat
'*** Description:
'***      Wrapper for formatting text to Rich Text Format to color and fonts
'*** Programmer:
'***      Cliff Nichols
'*** Based from:
'***      www.w3schools.com
'*** Post Date:
'***      01-02-09
'*** Last Update:
'***      01-05-09
'*** Changes, Updates, Patches, etc....
'***
'*** OS Versions:
'***      Should work on 95/98/ME, NT/2000/XP/VISTA
'*** Tested On:
'***      XP/VISTA
'*** PB Versions:
'***      7, 8, 9
'*** Based From:
'***      RTF Specifications (See http://www.biblioscape.com/rtf15_spec.htm#Heading52 for details)
'*************************************************************************************************************

#IF NOT %DEF(%STRINGASRICHTEXTFORMAT)
     %STRINGASRICHTEXTFORMAT = 1
     GLOBAL gPos AS LONG, gPtr AS LONG, gTxt AS STRING
'*** SET TEXT
     DECLARE FUNCTION RichEditStreamInString (BYVAL dwCookie AS DWORD, BYVAL pbBuff AS BYTE PTR, _
                                 BYVAL cb AS LONG, pcb AS LONG) AS DWORD
     DECLARE FUNCTION RichEditAddTextStreamIn(HwndDialog AS LONG, HwndRichEdit AS LONG, FontType AS STRING, FontColor AS STRING, FontSize AS LONG, FontBold AS LONG, FontItalic AS LONG, FontUnderline AS LONG, TextToAdd AS STRING) AS STRING
     DECLARE FUNCTION TextBoxAddRtfText(HwndDialog AS LONG, HwndTextBox AS LONG, TextToAdd AS STRING) AS STRING

     DECLARE FUNCTION RtfHeader() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareVersionLanguage() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareFontBlock() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareFontCourierNew() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareFontTimesNewRoman() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareFontAndale() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareFontLucida() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareFontGeorgia() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareColors() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareColorBlock() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareColorMaroon() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareColorTeal() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareColorGreen() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareColorNavy() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareColorPurple() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareColorTealSwatch() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareColorGrey() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareColorSilver() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareColorRed() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareColorLime() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareColorYellow() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareColorBlue() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareColorPink() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareColorAuqua() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareColorWhite() AS STRING
     DECLARE FUNCTION RtfHeaderDeclareColorBlack() AS STRING

     DECLARE FUNCTION RtfCommandsEndOfLine() AS STRING
     DECLARE FUNCTION RtfReplaceCr(CommandString AS STRING) AS STRING
'*** FONTS
     DECLARE FUNCTION RtfFontCourier() AS STRING
     DECLARE FUNCTION RtfFontTimesNewRoman() AS STRING
     DECLARE FUNCTION RtfFontAndale() AS STRING
     DECLARE FUNCTION RtfFontLucidia() AS STRING
     DECLARE FUNCTION RtfFontGeorgia() AS STRING
'*** FONT TYPES
     DECLARE FUNCTION RtfFontBold() AS STRING
     DECLARE FUNCTION RtfFontUnBold() AS STRING
     DECLARE FUNCTION RtfFontItalic() AS STRING
     DECLARE FUNCTION RtfFontUnItalic() AS STRING
     DECLARE FUNCTION RtfFontUnderline() AS STRING
     DECLARE FUNCTION RtfFontUnUnderline() AS STRING
'*** SIZES
     DECLARE FUNCTION RtfFontSize(SizeForFont AS LONG) AS STRING
'*** COLORS
     DECLARE FUNCTION RtfFontMaroon() AS STRING
     DECLARE FUNCTION RtfFontGreen() AS STRING
     DECLARE FUNCTION RtfFontOlive() AS STRING
     DECLARE FUNCTION RtfFontNavy() AS STRING
     DECLARE FUNCTION RtfFontPurple() AS STRING
     DECLARE FUNCTION RtfFontTeal() AS STRING
     DECLARE FUNCTION RtfFontGrey() AS STRING
     DECLARE FUNCTION RtfFontSilver() AS STRING
     DECLARE FUNCTION RtfFontRed() AS STRING
     DECLARE FUNCTION RtfFontLime() AS STRING
     DECLARE FUNCTION RtfFontYellow() AS STRING
     DECLARE FUNCTION RtfFontBlue() AS STRING
     DECLARE FUNCTION RtfFontFuchsia() AS STRING
     DECLARE FUNCTION RtfFontAqua() AS STRING
     DECLARE FUNCTION RtfFontWhite() AS STRING
     DECLARE FUNCTION RtfFontBlack() AS STRING
'*** Rtf commands that should be treated as actual text
     DECLARE FUNCTION RtfTextOpenParenthesis() AS STRING
     DECLARE FUNCTION RtfTextCloseParenthesis() AS STRING
     DECLARE FUNCTION RtfTextOpenCurlyBrace() AS STRING
     DECLARE FUNCTION RtfTextCloseCurlyBrace() AS STRING
     DECLARE FUNCTION RtfTextOpenBracket() AS STRING
     DECLARE FUNCTION RtfTextCloseBracket() AS STRING
     DECLARE FUNCTION RtfTextBackSlash() AS STRING

     DECLARE FUNCTION RichEditSetBackGroundColor(HwndDialog AS LONG, HwndRichEdit AS LONG, RedColor AS LONG, GreenColor AS LONG, BlueColor AS LONG) AS LONG

'*************************************************************************************************************
'*** CONTENTS OF AN RTF FILE
'***      An RTF file has the following syntax:
'***           <File>
'***           '{'
'***                <header>
'***                <document>
'***           '}'
'***
'*** Note: skip over destinations marked with the \* control symbol.
'*************************************************************************************************************

'*************************************************************************************************************
'*** Header has the following syntax:
'***      <header>
'***           \rtf <charset>
'***           \deff?                                                 '<--- Must precede any text without an explicit reference to a font
'***           <fonttbl>                                              '<--- The font table must precede any reference to a font.
'***           <filetbl>?                                             '<--- File Table
'***           <colortbl>?                                            '<--- Color Table
'***           <stylesheet>?                                          '<--- Style Sheet
'***           <listtables>?                                          '<--- List Table
'***           <revtbl>?                                              '<--- Revision Table
'*************************************************************************************************************
     FUNCTION RtfHeader() AS STRING
          LOCAL st$
          st$ = st$ + "{"                                             '<--- No characters allowed betwen openRTF and 1st command or RTF will NOT work
'*** Start RTF Header
          st$ = st$ + RtfHeaderDeclareVersionLanguage
'*** Start Font Selections
          st$ = st$ + RtfHeaderDeclareFontBlock
'*** Courier New
          st$ = st$ + RtfHeaderDeclareFontCourierNew
'*** Times New Roman
          st$ = st$ + RtfHeaderDeclareFontTimesNewRoman
'*** Andale
          st$ = st$ + RtfHeaderDeclareFontAndale
'*** Lucida
          st$ = st$ + RtfHeaderDeclareFontLucida
'*** Georgia
          st$ = st$ + RtfHeaderDeclareFontGeorgia
          st$ = st$ + "}"
'*** End Font Block
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareVersionLanguage() AS STRING
          LOCAL st$
          st$ = st$ + "\rtf1"                                    'RTF version 1                '<--- \rtfN control word must follow the opening brace, N = major version of the RTF Specification
          st$ = st$ + "\ansi"                                    'Ansi language                '<--- Character Set (\ansi, \mac, \pc, or \pca)
          st$ = st$ + "\ansicpg1252"                             '\ansicpg1252 = U.S. Windows  '<--- ANSI code page
          st$ = st$ + "\deff0"                                   'Default Font = Font 0
          st$ = st$ + "\deflang1033"                             'Default Language = English
          st$ = st$ + "\deflangfe1033"                           'Default Language English
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareFontBlock() AS STRING
          LOCAL st$
          st$ = st$ + "{"
          st$ = st$ + "\fonttbl"                                 'Declare Font Block
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareFontCourierNew() AS STRING
          LOCAL st$
          st$ = st$ + "{"
               st$ = st$ + "\f0"                                 'Font 0
               st$ = st$ + "\fmodern"
               st$ = st$ + "\fprq1"
               st$ = st$ + "\fcharset0 Courier New;"
          st$ = st$ + "}"
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareFontTimesNewRoman() AS STRING
          LOCAL st$
          st$ = st$ + "{"
               st$ = st$ + "\f1"                                 'Font 1
               st$ = st$ + "\fnil
               st$ = st$ + "\fcharset0 Times New Roman;"
          st$ = st$ + "}"
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareFontAndale() AS STRING
          LOCAL st$
          st$ = st$ + "{"
               st$ = st$ + "\f2"                                 'Font 2
               st$ = st$ + "\fmodern"
               st$ = st$ + "\fprq1"
               st$ = st$ + "\fcharset0 Andale Mono;"
          st$ = st$ + "}"
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareFontLucida() AS STRING
          LOCAL st$
          st$ = st$ + "{"
               st$ = st$ + "\f3"                                 'Font 3
               st$ = st$ + "\fmodern"
               st$ = st$ + "\fprq1"
               st$ = st$ + "\fcharset0 Lucida CONSOLE;
          st$ = st$ + "}"
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareFontGeorgia() AS STRING
          LOCAL st$
          st$ = st$ + "{"
               st$ = st$ + "\f4"                                 'Font 4
               st$ = st$ + "\froman"
               st$ = st$ + "\fprq2\fcharset0 Georgia;"
          st$ = st$ + "}"
          FUNCTION = st$
     END FUNCTION

'*************************************************************************************************************
'***
'*************************************************************************************************************
     FUNCTION RtfHeaderDeclareColors() AS STRING
          LOCAL st$
          st$ = st$ + RtfHeaderDeclareColorBlock                 'Declare Color Block
          st$ = st$ + RtfHeaderDeclareColorMaroon                'cf1 = MAROON Brownish Red = ";\red128\green0\blue0"
          st$ = st$ + RtfHeaderDeclareColorTeal                  'cf2 = TEAL Dark Green = ";\red0\green128\blue0"
          st$ = st$ + RtfHeaderDeclareColorGreen                 'cf3 = GREEN Cammo Green = ";\red128\green128\blue0"
          st$ = st$ + RtfHeaderDeclareColorNavy                  'cf4 = NAVY Dark Purple = ";\red0\green0\blue128"
          st$ = st$ + RtfHeaderDeclareColorPurple                'cf5 = PURPLE Purple = ";\red128\green0\blue128"
          st$ = st$ + RtfHeaderDeclareColorTealSwatch            'cf6 = TEAL Swatch Green = ";\red0\green128\blue128"
          st$ = st$ + RtfHeaderDeclareColorGrey                  'cf7 = GREY Dark Grey = ";\red128\green128\blue128"
          st$ = st$ + RtfHeaderDeclareColorSilver                'cf8 = SILVER Light Grey = ";\red192\green192\blue192"
          st$ = st$ + RtfHeaderDeclareColorRed                   'cf9 = RED Bright Red = ";\red255\green0\blue0"
          st$ = st$ + RtfHeaderDeclareColorLime                  'cf10 = LIME Bright Green = ";\red0\green255\blue0"
          st$ = st$ + RtfHeaderDeclareColorYellow                'cf11 = YELLOW Bright Yellow = ";\red255\green255\blue0"
          st$ = st$ + RtfHeaderDeclareColorBlue                  'cf12 = BLUE Bright Blue = ";\red0\green0\blue255"
          st$ = st$ + RtfHeaderDeclareColorPink                  'cf13 = PINK Bright Pink = ";\red255\green0\blue255"
          st$ = st$ + RtfHeaderDeclareColorAuqua                 'cf14 = AQUA Blue Green = ";\red0\green255\blue255"
          st$ = st$ + RtfHeaderDeclareColorWhite                 'cf15 = WHITE White = ";\red255\green255\blue255"
          st$ = st$ + RtfHeaderDeclareColorBlack                 'cf16 = BLACK Black = ";\red0\green0\blue0"
          st$ = st$ + "}"                                        'End Declare Colors
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareColorBlock() AS STRING
          LOCAL st$
          st$ = st$ + "{"
          st$ = st$ + "\colortbl "                               'Start Declare Colors
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareColorMaroon() AS STRING
          LOCAL st$
          st$ = st$ + ";\red128\green0\blue0"                    'MAROON Brownish Red
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareColorTeal() AS STRING
          LOCAL st$
          st$ = st$ + ";\red0\green128\blue0"                    'TEAL Dark Green
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareColorGreen() AS STRING
          LOCAL st$
          st$ = st$ + ";\red128\green128\blue0"                  'GREEN Cammo Green
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareColorNavy() AS STRING
          LOCAL st$
          st$ = st$ + ";\red0\green0\blue128"                    'NAVY Dark Purple
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareColorPurple() AS STRING
          LOCAL st$
          st$ = st$ + ";\red128\green0\blue128"                  'PURPLE Purple
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareColorTealSwatch() AS STRING
          LOCAL st$
          st$ = st$ + ";\red0\green128\blue128"                  'TEAL Swatch Green
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareColorGrey() AS STRING
          LOCAL st$
          st$ = st$ + ";\red128\green128\blue128"                'GREY Dark Grey
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareColorSilver() AS STRING
          LOCAL st$
          st$ = st$ + ";\red192\green192\blue192"                'SILVER Light Grey
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareColorRed() AS STRING
          LOCAL st$
          st$ = st$ + ";\red255\green0\blue0"                    'RED Bright Red
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareColorLime() AS STRING
          LOCAL st$
          st$ = st$ + ";\red0\green255\blue0"                    'LIME Bright Green
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareColorYellow() AS STRING
          LOCAL st$
          st$ = st$ + ";\red255\green255\blue0"                  'YELLOW Bright Yellow
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareColorBlue() AS STRING
          LOCAL st$
          st$ = st$ + ";\red0\green0\blue255"                    'BLUE Bright Blue
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareColorPink() AS STRING
          LOCAL st$
          st$ = st$ + ";\red255\green0\blue255"                  'PINK Bright Pink
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareColorAuqua() AS STRING
          LOCAL st$
          st$ = st$ + ";\red0\green255\blue255"                  'AQUA Blue Green
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareColorWhite() AS STRING
          LOCAL st$
          st$ = st$ + ";\red255\green255\blue255"                'WHITE White
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfHeaderDeclareColorBlack() AS STRING
          LOCAL st$
          st$ = st$ + ";\red0\green0\blue0"                      'BLACK Black
          FUNCTION = st$
     END FUNCTION


     FUNCTION RtfDefaults() AS STRING
          LOCAL st$
          st$ = st$ + "\cf16"                                    'Default Color 16 = Black
          st$ = st$ + "\f0"                                      'Default Font 0
          st$ = st$ + "\fs11 "                                   'Default Font Size 11
          FUNCTION = st$
     END FUNCTION

     FUNCTION RtfCommandsEndOfLine() AS STRING
         FUNCTION = "\line "                                     'RTF does not wrap on $CR or $LF, but does on \line
     END FUNCTION

     FUNCTION RtfReplaceCr(CommandString AS STRING) AS STRING    'Replace $CR with a printable character that is non-ansii
         REPLACE $CR WITH CHR$(174) IN CommandString
         FUNCTION = CommandString
     END FUNCTION

     FUNCTION RtfFontCourier() AS STRING
         FUNCTION = "\f0"
     END FUNCTION

     FUNCTION RtfFontTimesNewRoman() AS STRING
         FUNCTION = "\f1"
     END FUNCTION

     FUNCTION RtfFontAndale() AS STRING
         FUNCTION = "\f2"
     END FUNCTION

     FUNCTION RtfFontLucidia() AS STRING
         FUNCTION = "\f3"
     END FUNCTION

     FUNCTION RtfFontGeorgia() AS STRING
         FUNCTION = "\f4"
     END FUNCTION

     FUNCTION RtfFontBold() AS STRING
         FUNCTION = "\b "
     END FUNCTION

     FUNCTION RtfFontUnBold() AS STRING
         FUNCTION = "\b0 "
     END FUNCTION

     FUNCTION RtfFontItalic() AS STRING
         FUNCTION = "\i "
     END FUNCTION

     FUNCTION RtfFontUnItalic() AS STRING
         FUNCTION = "\i0 "
     END FUNCTION

     FUNCTION RtfFontUnderline() AS STRING
         FUNCTION = "\ul "
     END FUNCTION

     FUNCTION RtfFontUnUnderline() AS STRING
         FUNCTION = "\ul0 "
     END FUNCTION

     FUNCTION RtfFontSize(SizeForFont AS LONG) AS STRING
         FUNCTION = "\fs" + TRIM$(STR$(SizeForFont*2)) + " "
     END FUNCTION

     FUNCTION RtfFontMaroon() AS STRING
         FUNCTION = "\cf1 "
     END FUNCTION

     FUNCTION RtfFontGreen() AS STRING
         FUNCTION = "\cf2 "
     END FUNCTION

     FUNCTION RtfFontOlive() AS STRING
         FUNCTION = "\cf3 "
     END FUNCTION

     FUNCTION RtfFontNavy() AS STRING
         FUNCTION = "\cf4 "
     END FUNCTION

     FUNCTION RtfFontPurple() AS STRING
         FUNCTION = "\cf5 "
     END FUNCTION

     FUNCTION RtfFontTeal() AS STRING
         FUNCTION = "\cf6 "
     END FUNCTION

     FUNCTION RtfFontGrey() AS STRING
         FUNCTION = "\cf7 "
     END FUNCTION

     FUNCTION RtfFontSilver() AS STRING
         FUNCTION = "\cf8 "
     END FUNCTION

     FUNCTION RtfFontRed() AS STRING
         FUNCTION = "\cf9 "
     END FUNCTION

     FUNCTION RtfFontLime() AS STRING
         FUNCTION = "\cf10 "
     END FUNCTION

     FUNCTION RtfFontYellow() AS STRING
         FUNCTION = "\cf11 "
     END FUNCTION

     FUNCTION RtfFontBlue() AS STRING
         FUNCTION = "\cf12 "
     END FUNCTION

     FUNCTION RtfFontFuchsia() AS STRING
         FUNCTION = "\cf13 "
     END FUNCTION

     FUNCTION RtfFontAqua() AS STRING
         FUNCTION = "\cf14 "
     END FUNCTION

     FUNCTION RtfFontWhite() AS STRING
         FUNCTION = "\cf15 "
     END FUNCTION

     FUNCTION RtfFontBlack() AS STRING
         FUNCTION = "\cf16 "
     END FUNCTION

     FUNCTION RtfTextOpenParenthesis() AS STRING
         FUNCTION = "\("
     END FUNCTION

     FUNCTION RtfTextCloseParenthesis() AS STRING
         FUNCTION = "\)"
     END FUNCTION

     FUNCTION RtfTextOpenCurlyBrace() AS STRING
         FUNCTION = "\{"
     END FUNCTION

     FUNCTION RtfTextCloseCurlyBrace() AS STRING
         FUNCTION = "\}"
     END FUNCTION

     FUNCTION RtfTextOpenBracket() AS STRING
         FUNCTION = "\["
     END FUNCTION

     FUNCTION RtfTextCloseBracket() AS STRING
         FUNCTION = "\]"
     END FUNCTION

     FUNCTION RtfTextBackSlash() AS STRING
         FUNCTION = "\\"
     END FUNCTION

     FUNCTION RichEditSetBackGroundColor(HwndDialog AS LONG, HwndRichEdit AS LONG, RedColor AS LONG, GreenColor AS LONG, BlueColor AS LONG) AS LONG
          CONTROL SEND HwndDialog, HwndRichEdit, %EM_SETBKGNDCOLOR, 0, RGB(RedColor, GreenColor, BlueColor)        'RGB(255,254,209) = Post-it Note Color
          FUNCTION = RGB(RedColor, GreenColor, BlueColor)
     END FUNCTION

     '¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤
     ' 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 = MIN&(cb, LEN(gTxt) - (gPos - 1))                 '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.
          ELSE
               FUNCTION = %True                                  'Break the action
          END IF
     END FUNCTION

     FUNCTION RichEditSetText(HwndDialog AS LONG, HwndRichEdit AS LONG, TextToSet AS STRING) AS LONG
          CONTROL SET TEXT HwndDialog, HwndRichEdit, TextToSet
     END FUNCTION

     FUNCTION RichEditAddTextStreamIn(HwndDialog AS LONG, HwndRichEdit AS LONG, FontType AS STRING, FontColor AS STRING, FontSize AS LONG, FontBold AS LONG, FontItalic AS LONG, FontUnderline AS LONG, TextToAdd AS STRING) AS STRING
          STATIC CurrentText AS STRING
          LOCAL NewText AS STRING
          LOCAL NewFontType AS STRING
          LOCAL NewFontColor AS STRING
          LOCAL NewFontSize AS STRING
          LOCAL NewFontBold AS STRING
          LOCAL NewFontUnBold AS STRING
          LOCAL NewFontItalic AS STRING
          LOCAL NewFontUnItalic AS STRING
          LOCAL NewFontUnderline AS STRING
          LOCAL NewFontUnUnderline AS STRING
          LOCAL eStream AS EDITSTREAM
          LOCAL ret AS LONG
          REPLACE $CRLF WITH RtfCommandsEndOfLine IN TextToAdd
          REPLACE $CR WITH RtfCommandsEndOfLine IN TextToAdd
          REPLACE $LF WITH "" IN TextToAdd
          REPLACE RtfHeader WITH "" IN CurrentText
          REPLACE RtfHeaderDeclareColors WITH "" IN CurrentText
          REPLACE RtfDefaults WITH "" IN CurrentText
          CurrentText = MID$(CurrentText, 1, LEN(CurrentText) - 2)    'Strip the closing $CR and curly bracket
          SELECT CASE UCASE$(FontType)
               CASE "COURIER"
                    NewFontType = RtfFontCourier()
               CASE "TIMESNEWROMAN"
                    NewFontType = RtfFontTimesNewRoman()
               CASE "ANDALE"
                    NewFontType = RtfFontAndale()
               CASE "LUCIDIA"
                    NewFontType = RtfFontLucidia()
               CASE "GEORGIA"
                    NewFontType = RtfFontGeorgia()
               CASE ""
                    NewFontType = RtfFontCourier()
          END SELECT
          SELECT CASE UCASE$(FontColor)
               CASE "MAROON"
                    NewFontColor = RtfFontMaroon
               CASE "GREEN"
                    NewFontColor = RtfFontGreen
               CASE "OLIVE"
                    NewFontColor = RtfFontOlive
               CASE "NAVY"
                    NewFontColor = RtfFontNavy
               CASE "PURPLE"
                    NewFontColor = RtfFontPurple
               CASE "TEAL"
                    NewFontColor = RtfFontTeal
               CASE "GREY"
                    NewFontColor = RtfFontGrey
               CASE "SILVER"
                    NewFontColor = RtfFontSilver
               CASE "RED"
                    NewFontColor = RtfFontRed
               CASE "LIME"
                    NewFontColor = RtfFontLime
               CASE "YELLOW"
                    NewFontColor = RtfFontYellow
               CASE "BLUE"
                    NewFontColor = RtfFontBlue
               CASE "FUCHSIA"
                    NewFontColor = RtfFontFuchsia
               CASE "AUQUA", "AQUA"                              'In the case of typo's in code
                    NewFontColor = RtfFontAqua
               CASE "WHITE"
                    NewFontColor = RtfFontWhite
               CASE "BLACK"
                    NewFontColor = RtfFontBlack
               CASE ""
                    NewFontColor = RtfFontBlack
               CASE ELSE
                    NewFontColor = RtfFontBlack
          END SELECT
          NewFontSize = RtfFontSize(FontSize)
          SELECT CASE FontBold
               CASE %FALSE
                    NewFontBold = ""
                    NewFontUnBold = ""
               CASE %TRUE
                    NewFontBold = RtfFontBold
                    NewFontUnBold = RtfFontUnBold
          END SELECT
          SELECT CASE FontItalic
               CASE %FALSE
                    NewFontItalic = ""
                    NewFontUnItalic = ""
               CASE %TRUE
                    NewFontItalic = RtfFontItalic
                    NewFontUnItalic = RtfFontUnItalic
          END SELECT
          SELECT CASE FontUnderline
               CASE %FALSE
                    NewFontUnderline = ""
                    NewFontUnUnderline = ""
               CASE %TRUE
                    NewFontUnderline = RtfFontUnderline
                    NewFontUnUnderline = RtfFontUnUnderline
          END SELECT
          NewText = NewText + RtfHeader
          NewText = NewText + RtfHeaderDeclareColors
          NewText = NewText + RtfDefaults
          SELECT CASE ASC(CurrentText)                           '<--- Somehow a -1(Null) is in the text so do not add it to CurrentText
               CASE -1
               CASE ELSE
                    NewText = NewText + CurrentText
          END SELECT
          NewText = NewText + NewFontType
          NewText = NewText + NewFontColor
          NewText = NewText + NewFontSize
          NewText = NewText + NewFontBold
          NewText = NewText + NewFontItalic
          NewText = NewText + NewFontUnderline
          NewText = NewText + TextToAdd
          NewText = NewText + NewFontUnBold
          NewText = NewText + NewFontUnItalic
          NewText = NewText + NewFontUnUnderline
          NewText = NewText + $CRLF
          NewText = NewText + "}"
          CurrentText = NewText

          eStream.pfnCallback = CODEPTR(RichEditStreamInString)  'pointer to RichEdit callback procedure
          gPos = 1
          gTxt = NewText
          gPtr = STRPTR(gTxt)
          ret = SendMessage(GetDlgItem(HwndDialog, HwndRichEdit), %EM_STREAMIN, %SF_RTF, VARPTR(eStream)) 'stream in text

          FUNCTION = NewText
     END FUNCTION

     FUNCTION TextBoxAddRtfText(HwndDialog AS LONG, HwndTextBox AS LONG, TextToAdd AS STRING) AS STRING
'*** Formatting for readability ONLY
          REPLACE "\line" WITH $CRLF IN TextToAdd
'          REPLACE RtfHeaderDeclareVersionLanguage WITH $CRLF + $TAB + RtfHeaderDeclareVersionLanguage IN TextToAdd      '<--- Real Code space not allowed between open curly brace and RTF Header
          REPLACE RtfHeaderDeclareFontBlock WITH $CRLF + $TAB + RtfHeaderDeclareFontBlock IN TextToAdd      '<--- Not needed, but left for clarity
          REPLACE RtfHeaderDeclareFontCourierNew WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareFontCourierNew IN TextToAdd
          REPLACE RtfHeaderDeclareFontTimesNewRoman WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareFontTimesNewRoman IN TextToAdd
          REPLACE RtfHeaderDeclareFontAndale WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareFontAndale IN TextToAdd
          REPLACE RtfHeaderDeclareFontLucida WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareFontLucida IN TextToAdd
          REPLACE RtfHeaderDeclareFontGeorgia WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareFontGeorgia + $CRLF + $TAB IN TextToAdd

          REPLACE RtfHeaderDeclareColorBlock WITH $CRLF + $TAB + RtfHeaderDeclareColorBlock IN TextToAdd
          REPLACE RtfHeaderDeclareColorMaroon WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareColorMaroon IN TextToAdd
          REPLACE RtfHeaderDeclareColorTeal WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareColorTeal IN TextToAdd
          REPLACE RtfHeaderDeclareColorGreen WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareColorGreen IN TextToAdd
          REPLACE RtfHeaderDeclareColorNavy WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareColorNavy IN TextToAdd
          REPLACE RtfHeaderDeclareColorPurple WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareColorPurple IN TextToAdd
          REPLACE RtfHeaderDeclareColorTealSwatch WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareColorTealSwatch IN TextToAdd
          REPLACE RtfHeaderDeclareColorGrey WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareColorGrey IN TextToAdd
          REPLACE RtfHeaderDeclareColorSilver WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareColorSilver IN TextToAdd
          REPLACE RtfHeaderDeclareColorRed WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareColorRed IN TextToAdd
          REPLACE RtfHeaderDeclareColorLime WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareColorLime IN TextToAdd
          REPLACE RtfHeaderDeclareColorYellow WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareColorYellow IN TextToAdd
          REPLACE RtfHeaderDeclareColorBlue WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareColorBlue IN TextToAdd
          REPLACE RtfHeaderDeclareColorPink WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareColorPink IN TextToAdd
          REPLACE RtfHeaderDeclareColorAuqua WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareColorAuqua IN TextToAdd
          REPLACE RtfHeaderDeclareColorWhite WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareColorWhite IN TextToAdd
          REPLACE RtfHeaderDeclareColorBlack WITH $CRLF + $TAB + $TAB + RtfHeaderDeclareColorBlack + $CRLF + $TAB IN TextToAdd

          REPLACE RtfDefaults WITH $CRLF + $TAB + RtfDefaults + $CRLF IN TextToAdd

          CONTROL SET TEXT HwndDialog, HwndTextBox, TextToAdd
          FUNCTION = TextToAdd
     END FUNCTION
#ENDIF
    RichEditDemo.bas
    Code:
    #PBFORMS CREATED V1.51
'------------------------------------------------------------------------------
' The first line in this file is a PB/Forms metastatement.
' It should ALWAYS be the first line of the file. Other
' PB/Forms metastatements are placed at the beginning and
' end of "Named Blocks" of code that should be edited
' with PBForms only. Do not manually edit or delete these
' metastatements or PB/Forms will not be able to reread
' the file correctly.  See the PB/Forms documentation for
' more information.
' Named blocks begin like this:    #PBFORMS BEGIN ...
' Named blocks end like this:      #PBFORMS END ...
' Other PB/Forms metastatements such as:
'     #PBFORMS DECLARATIONS
' are used by PB/Forms to insert additional code.
' Feel free to make changes anywhere else in the file.
'------------------------------------------------------------------------------

#COMPILE EXE
#DIM ALL

GLOBAL hDlg  AS DWORD
'------------------------------------------------------------------------------
'   ** Includes **
'------------------------------------------------------------------------------
#PBFORMS BEGIN INCLUDES
#IF NOT %DEF(%WINAPI)
    #INCLUDE "WIN32API.INC"
#ENDIF
#IF NOT %DEF(%RICHEDIT_INC)
    #INCLUDE "RICHEDIT.INC"
#ENDIF
#INCLUDE "PBForms.INC"
#PBFORMS END INCLUDES
'------------------------------------------------------------------------------

'------------------------------------------------------------------------------
'   ** Constants **
'------------------------------------------------------------------------------
#PBFORMS BEGIN CONSTANTS
%IDD_DIALOG1   =  101
%IDC_RICHEDIT1 = 1001
%IDC_TEXT = 1002
#PBFORMS END CONSTANTS
'------------------------------------------------------------------------------
#IF NOT %DEF(%STRINGASRICHTEXTFORMAT)
    #INCLUDE "STRINGASRICHTEXTFORMAT.INC"
#ENDIF

'------------------------------------------------------------------------------
'   ** Declarations **
'------------------------------------------------------------------------------
DECLARE CALLBACK FUNCTION ShowDIALOG1Proc()
DECLARE FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
#PBFORMS DECLARATIONS
'------------------------------------------------------------------------------

'------------------------------------------------------------------------------
'   ** Main Application Entry Point **
'------------------------------------------------------------------------------
FUNCTION PBMAIN()
    PBFormsRichEdit ()      ' Load RichEdit

    ShowDIALOG1 %HWND_DESKTOP

    PBFormsRichEdit (%TRUE) ' Unload RichEdit
END FUNCTION
'------------------------------------------------------------------------------

'------------------------------------------------------------------------------
'   ** CallBacks **
'------------------------------------------------------------------------------
CALLBACK FUNCTION ShowDIALOG1Proc()

    SELECT CASE AS LONG CBMSG
        CASE %WM_INITDIALOG
            ' Initialization handler

        CASE %WM_NCACTIVATE
            STATIC hWndSaveFocus AS DWORD
            IF ISFALSE CBWPARAM THEN
                ' Save control focus
                hWndSaveFocus = GetFocus()
            ELSEIF hWndSaveFocus THEN
                ' Restore control focus
                SetFocus(hWndSaveFocus)
                hWndSaveFocus = 0
            END IF

        CASE %WM_COMMAND
            ' Process control notifications
            SELECT CASE AS LONG CBCTL
                CASE %IDC_RICHEDIT1

            END SELECT
    END SELECT
END FUNCTION
'------------------------------------------------------------------------------

'------------------------------------------------------------------------------
'   ** Dialogs **
'------------------------------------------------------------------------------
FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
    LOCAL lRslt AS LONG

#PBFORMS BEGIN DIALOG %IDD_DIALOG1->->

    DIALOG NEW hParent, "Dialog1", 70, 70, 500, 121, %WS_POPUP OR %WS_BORDER _
        OR %WS_DLGFRAME OR %WS_THICKFRAME OR %WS_CAPTION OR %WS_SYSMENU OR _
        %WS_MINIMIZEBOX OR %WS_MAXIMIZEBOX OR %WS_CLIPSIBLINGS OR _
        %WS_VISIBLE OR %DS_MODALFRAME OR %DS_3DLOOK OR %DS_NOFAILCREATE OR _
        %DS_SETFONT, %WS_EX_CONTROLPARENT OR %WS_EX_LEFT OR _
        %WS_EX_LTRREADING OR %WS_EX_RIGHTSCROLLBAR, TO hDlg
    CONTROL ADD PBFormsRichEdit(), hDlg, %IDC_RICHEDIT1, "RichEdit1", 5, 5, _
        190, 110, %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR %WS_VSCROLL OR _
        %WS_HSCROLL OR %ES_LEFT OR %ES_MULTILINE OR %ES_AUTOVSCROLL OR _
        %ES_AUTOHSCROLL OR %ES_WANTRETURN, %WS_EX_CLIENTEDGE OR %WS_EX_LEFT _
        OR %WS_EX_LTRREADING OR %WS_EX_RIGHTSCROLLBAR
    CONTROL ADD TEXTBOX, hDlg, %IDC_TEXT, "", 200, 5, _
        300, 110, %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP OR %WS_VSCROLL OR _
        %WS_HSCROLL OR %ES_LEFT OR %ES_MULTILINE OR %ES_AUTOVSCROLL OR _
        %ES_AUTOHSCROLL OR %ES_WANTRETURN, %WS_EX_CLIENTEDGE OR %WS_EX_LEFT _
        OR %WS_EX_LTRREADING OR %WS_EX_RIGHTSCROLLBAR
#PBFORMS END DIALOG
'*** Demo Colors
     RichEditAddTextStreamIn(hDlg, %IDC_RICHEDIT1, "Courier", "Blue", 10, %TRUE, %FALSE, %FALSE, "Hello" + $CRLF)
     RichEditAddTextStreamIn(hDlg, %IDC_RICHEDIT1, "TimesNewRoman", "Red", 12, %TRUE, %TRUE, %FALSE, "Hello" + $CRLF)
     RichEditAddTextStreamIn(hDlg, %IDC_RICHEDIT1, "GEORGIA", "Green", 14, %TRUE, %TRUE, %TRUE, "Hello" + $CRLF)
     RichEditAddTextStreamIn(hDlg, %IDC_RICHEDIT1, "", "", 14, %FALSE, %FALSE, %FALSE, $TAB + "Normal Text" + $CRLF)
     RichEditAddTextStreamIn(hDlg, %IDC_RICHEDIT1, "GEORGIA", "Blue", 14, %FALSE, %FALSE, %FALSE, $TAB + "Goodbye" + $CRLF)
     RichEditAddTextStreamIn(hDlg, %IDC_RICHEDIT1, "TimesNewRoman", "Red", 12, %FALSE, %TRUE, %FALSE, $TAB + "Goodbye" + $CRLF)
     RichEditAddTextStreamIn(hDlg, %IDC_RICHEDIT1, "Courier", "Green", 10, %FALSE, %TRUE, %TRUE, $TAB + "Goodbye" + $CRLF)
'*** Show single characters as colors
     RichEditAddTextStreamIn(hDlg, %IDC_RICHEDIT1, "", "", 14, %FALSE, %FALSE, %FALSE, "" + $CRLF)
     RichEditAddTextStreamIn(hDlg, %IDC_RICHEDIT1, "", "", 14, %FALSE, %FALSE, %FALSE, "A")
     RichEditAddTextStreamIn(hDlg, %IDC_RICHEDIT1, "Courier", "Blue", 10, %TRUE, %FALSE, %FALSE, "B")
     RichEditAddTextStreamIn(hDlg, %IDC_RICHEDIT1, "TimesNewRoman", "Red", 10, %TRUE, %FALSE, %FALSE, "C")
     RichEditAddTextStreamIn(hDlg, %IDC_RICHEDIT1, "GEORGIA", "Green", 10, %TRUE, %FALSE, %FALSE, "D")
     RichEditAddTextStreamIn(hDlg, %IDC_RICHEDIT1, "", "", 12, %FALSE, %FALSE, %FALSE, $TAB + "1")
     RichEditAddTextStreamIn(hDlg, %IDC_RICHEDIT1, "Courier", "Green", 14, %TRUE, %FALSE, %FALSE, $TAB + "2")
     RichEditAddTextStreamIn(hDlg, %IDC_RICHEDIT1, "TimesNewRoman", "Red", 12, %TRUE, %FALSE, %FALSE, $TAB + "3")
     RichEditAddTextStreamIn(hDlg, %IDC_RICHEDIT1, "GEORGIA", "Blue", 10, %TRUE, %FALSE, %FALSE, $TAB + "4")
'*** (){} and \ are RTF commands so if needing them as text use the following
     RichEditAddTextStreamIn(hDlg, %IDC_RICHEDIT1, "", "", 14, %FALSE, %FALSE, %FALSE, "" + $CRLF)
     LOCAL RtfCommandText AS STRING
     RtfCommandText = RtfCommandText + RtfTextOpenParenthesis
     RtfCommandText = RtfCommandText + RtfTextCloseParenthesis
     RtfCommandText = RtfCommandText + RtfTextOpenCurlyBrace
     RtfCommandText = RtfCommandText + RtfTextCloseCurlyBrace
     RtfCommandText = RtfCommandText + " and "
     RtfCommandText = RtfCommandText + RtfTextBackSlash
     RtfCommandText = RtfCommandText + " are RTF commands so if needing them as text use the following " + $CRLF
     RichEditAddTextStreamIn(hDlg, %IDC_RICHEDIT1, "", "", 14, %FALSE, %FALSE, %FALSE, "" + $CRLF)
     RtfCommandText = RtfCommandText + "RtfTextOpenParenthesis" + $CRLF
     RtfCommandText = RtfCommandText + "RtfTextCloseParenthesis" + $CRLF
     RtfCommandText = RtfCommandText + "RtfTextOpenCurlyBrace" + $CRLF
     RtfCommandText = RtfCommandText + "RtfTextCloseCurlyBrace" + $CRLF
     RtfCommandText = RichEditAddTextStreamIn(hDlg, %IDC_RICHEDIT1, "TimesNewRoman", "Red", 18, %TRUE, %FALSE, %FALSE, RtfCommandText)
     TextBoxAddRtfText(hDlg, %IDC_TEXT, RtfCommandText)
'*** Change Background Color
     RichEditSetBackGroundColor hDlg, %IDC_RICHEDIT1, 255, 254, 209      'RGB(255,254,209) = Post-it Note Color
'     RichEditSetBackGroundColor hDlg, %IDC_RICHEDIT1, 0, 0, 0      'RGB(255,254,209) = Post-it Note Color
    DIALOG SHOW MODAL hDlg, CALL ShowDIALOG1Proc TO lRslt

#PBFORMS BEGIN CLEANUP %IDD_DIALOG1
#PBFORMS END CLEANUP

    FUNCTION = lRslt
END FUNCTION
'------------------------------------------------------------------------------
    Engineer's Motto: If it aint broke take it apart and fix it

    "If at 1st you don't succeed... call it version 1.0"

    "Half of Programming is coding"....."The other 90% is DEBUGGING"

    "Document my code????" .... "WHYYY??? do you think they call it CODE? "
    Tags: None
Previous template Next
Working...
X
😀
🥰
🤢
😎
😡
👍
👎

We process personal data about users of our site, through the use of cookies and other technologies, to deliver our services, and to analyze site activity. For additional details, refer to our Privacy Policy.

By clicking "I AGREE" below, you agree to our Privacy Policy and our personal data processing and cookie practices as described therein. You also acknowledge that this forum may be hosted outside your country and you consent to the collection, storage, and processing of your data in the country where this forum is hosted.

I Agree