Menu
▾
▴
[Win32forth-cvs] win32forth/demos/GdiDemo BitBlt.f,NONE,1.1 Figfonts.f,NONE,1.1 Figraph.f,NONE,1.1 Metafile.emf,NONE,1.1 Metafile.f,NONE,1.1 SixEasyFonts.f,NONE,1.1 TextList.f,NONE,1.1 TxtAlign.f,NONE,1.1
Update of /cvsroot/win32forth/win32forth/demos/GdiDemo In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv13139/demos/GdiDemo Added Files: BitBlt.f Figfonts.f Figraph.f Metafile.emf Metafile.f SixEasyFonts.f TextList.f TxtAlign.f Log Message: - Added my GDI class library to the CVS - WinDC and Font classes rewritten to use the GDI class library - Added some demo's whitch are using the GDI class library --- NEW FILE: Metafile.f --- \ File: GdiDemo.f \ Purpose: Demo application fpr the GDI class library \ Written: Sonntag, Oktober 30 2005 by Dirk Busch \ Licence: Public Domain cr .( Loading GDI class library demo - Main...) anew -gdidemo.f needs gdi/gdi.f \ the GDI class library 0 value create-tunkey? \ ---------------------------------------------------------------------- \ the Main window \ ---------------------------------------------------------------------- :object GdiDemoWindow <super WINDOW gdiPen tPen gdiSolidBrush tSolidBrush gdiHatchBrush tHatchBrush gdiFont tFont gdiWindowDC tDC gdiMetafileDC tMetaDC \ Create a metafile and store it on disk. \ This metafile will be displayed during repaint create FileName ," Metafile.emf" create Text1 ," This is a Text" create Text2 ,"TEXT" "This is a Text with a\TTAB" : CreateIt ( -- ) hWnd GetDC: tDC if \ Start recording a metafile for this window 0 0 Width Height tDC CalcMetaRect: tMetaDC tDC StartRecording: tMetaDC if \ setup the MetafileDC MM_TEXT SetMapMode: tMetaDC 0 0 SetWindowOrg: tMetaDC \ draw something into the metafile tPen SelectObject: tMetaDC tHatchBrush SelectObject: tMetaDC 50 50 100 125 Rectangle: tMetaDC 125 125 150 175 Ellipse: tMetaDC AD_COUNTERCLOCKWISE SetArcDirection: tMetaDC 190 60 120 140 200 240 120 70 Pie: tMetaDC 290 160 120 140 200 240 120 70 Chord: tMetaDC SetArcDirection: tMetaDC drop SelectObject: tMetaDC drop \ tHatchBrush tSolidBrush SelectObject: tMetaDC AD_CLOCKWISE SetArcDirection: tMetaDC 190 60 120 140 200 240 120 70 Pie: tMetaDC 290 160 120 140 200 240 120 70 Chord: tMetaDC SetArcDirection: tMetaDC drop SelectObject: tMetaDC drop \ tSolidBrush SelectObject: tDC drop \ tPen 20 300 120 350 tHatchBrush FillRect: tMetaDC 120 300 220 350 tHatchBrush FrameRect: tMetaDC tFont SelectObject: tMetaDC 20 350 Text1 count TextOut: tMetaDC 20 SetTabSize: tMetaDC 20 400 Text2 count TabbedTextOut: tMetaDC 2drop SetTabSize: tMetaDC drop \ TabSize SelectObject: tMetaDC drop \ tFont \ cleanup the MetafileDC SetMapMode: tMetaDC drop SetWindowOrg: tMetaDC 2drop \ stop recording StopRecording: tMetaDC if \ save it FileName count Save: tMetaDC drop then Destroy: tMetaDC then Release: tDC then ; \ Load the Metafile and draw it : LoadAndDrawIt ( -- ) FileName count Load: tMetaDC \ load the metafile from disk if 0 0 Width Height tDC Draw: tMetaDC \ and draw it in our window Destroy: tMetaDC \ clean up then ; :M On_Paint: ( -- ) GetHandle: self GetDC: tDC if LoadAndDrawIt Release: tDC then ;M :M Start: ( -- ) \ create a Pen hWnd ChooseColor: tPen 0= if 255 SetRValue: tPen then PS_DASHDOTDOT SetStyle: tPen Create: tPen drop \ create a solid brush hWnd ChooseColor: tSolidBrush 0= if 255 SetGValue: tSolidBrush then Create: tSolidBrush drop \ create a hatch brush hWnd ChooseColor: tHatchBrush 0= if 255 SetBValue: tHatchBrush then HS_DIAGCROSS SetStyle: tHatchBrush Create: tHatchBrush drop \ let the user choose a font hWnd Choose: tFont 0= if \ create a font s" Times New Roman" SetFaceName: tFont true SetUnderline: tFont true SetItalic: tFont 20 SetHeight: tFont Create: tFont drop then Start: super \ display our window CreateIt \ create our metafile Paint: super \ and force a repaint ;M :M On_Done: ( -- ) TURNKEYED? 0= if Destroy: tPen Destroy: tSolidBrush Destroy: tHatchBrush Destroy: tDC Destroy: tMetaDC then On_Done: super ;M ;object \ ---------------------------------------------------------------------- \ Start the demo or create a turnkey application \ ---------------------------------------------------------------------- : GdiDemo ( -- ) Start: GdiDemoWindow ; create-tunkey? [if] ' GdiDemo turnkey GdiDemo.exe [else] GdiDemo [then] --- NEW FILE: SixEasyFonts.f --- \ SixEasyFonts.F \ Written by David R. Pochin \ Changed to use the GDI class library by Dirk Busch \ Using Windows Stock Fonts ANEW -SixEasyFonts.F needs gdi/gdi.f \ Define an Object that is a child object of the Class "Window". :OBJECT Fontdemo <SUPER WINDOW gdiWindowDC tDC :M WindowTitle: ( -- title ) \ Title for the window. z" Six Easy Fonts One example only" ;M :M StartSize: ( -- width height ) \ Set width and height of window 500 200 ;M :M StartPos: ( -- x y ) \ Set the screen origin. 100 100 ;M :M Close: ( -- ) \ Do anything the class needs. Destroy: tDC Close: SUPER ;M :M On_Paint: ( -- ) \ screen redraw procedure GetHandle: self GetDC: tDC if DEVICE_DEFAULT_FONT SelectStockObject: tDC 20 30 s" DEVICE_DEFAULT_FONT AaBbCc¹º1/41/23/4¿HhIiJjKkLl" TextOut: tDC SYSTEM_FONT SelectStockObject: tDC drop 20 50 s" SYSTEM_FONT AaBbCc¹º1/41/23/4¿HhIiJjKkLl" TextOut: tDC SYSTEM_FIXED_FONT SelectStockObject: tDC drop 20 70 s" SYSTEM_FIXED_FONT AaBbCc¹º1/41/23/4¿HhIiJjKkLl" TextOut: tDC OEM_FIXED_FONT SelectStockObject: tDC drop 20 90 s" OEM_FIXED_FONT AaBbCc¹º1/41/23/4¿HhIiJjKkLl" TextOut: tDC ANSI_FIXED_FONT SelectStockObject: tDC drop 20 110 s" ANSI_FIXED_FONT AaBbCc¹º1/41/23/4¿HhIiJjKkLl" TextOut: tDC ANSI_VAR_FONT SelectStockObject: tDC drop 20 130 s" ANSI_VAR_FONT AaBbCc¹º1/41/23/4¿HhIiJjKkLl" TextOut: tDC SelectObject: tDC drop \ clean up Release: tDC then ;M ;OBJECT \ Complete the definition of the new object. : FONTS ( -- ) Start: Fontdemo ; FONTS \ END OF LISTING. --- NEW FILE: Figraph.f --- \ FIGRAPH.F Example of Object Oriented Graphics \ Written by David R. Pochin \ Changed to use the GDI class library by Dirk Busch \ Examples of pens, brushes, lines, shapes and fills. anew -FigGraph.f needs gdi/gdi.f \ Define an Object that is a child of the Class Window :OBJECT Grafdemo <SUPER WINDOW ButtonControl Button_1 \ a button gdiWindowDC tDC \ Set Up handles for Pens and Brushes. gdiPen hPen1 gdiPen hPen2 gdiPen hPen3 gdiPen hPen4 gdiHatchBrush hBrush1 \ Set up Array of Data Points for use with Polyline. Create POLYDATA ( x1 , y1 , x2 , y2 , etc ) 140 , 70 , 180 , 100 , 200 , 50 , 230 , 90 , 250 , 80 , \ Things to do at the start of window creation :M ClassInit: ( -- ) ClassInit: super \ Do anything the super class needs. ;M :M WindowTitle: ( -- title ) z" Drawing Figures with Win32Forth " ;M :M StartSize: ( -- width height ) 550 230 ;M :M StartPos: ( -- x y ) 100 100 ;M \ Create five drawing methods. \ Follow these patterns for other Windows figures such as Arc. :M DrawRect: ( bottom right top left -- ) 4reverse Rectangle: tDC ;M :M DrawEllipse: ( bottom right top left -- ) 4reverse Ellipse: tDC ;M :M DrawPie: ( Drawn counter clockwise from xstart, ystart ) ( yfinish xfinish ystart xstart bottom right top left -- ) 8reverse Pie: tDC ;M :M DrawRoundRect: ( ycnr xcnr bottom right top left -- ) 6reverse RoundRect: tDC ;M :M DrawPolyLine: ( n addr -- ) swap Polyline: tDC ;M \ Remember to delete any objects you have made before closing. :M Close: ( -- ) Destroy: hPen1 Destroy: hPen2 Destroy: hPen3 Destroy: hPen4 Destroy: hBrush1 Destroy: tDC Close: super ;M :M On_Init: ( -- ) \ Set up a Button IDOK SetID: Button_1 self Start: Button_1 160 180 70 25 Move: Button_1 s" CLOSE" SetText: Button_1 GetStyle: Button_1 BS_DEFPUSHBUTTON OR SetStyle: Button_1 \ Create all non Stock Object Pens and Brushes required. \ ONLY PenWidth 1 allowed with PenStyles other than PS_SOLID 128 128 128 SetRGB: hPen1 12 SetWidth: hPen1 PS_SOLID SetStyle: hPen1 Create: hPen1 0 0 255 SetRGB: hPen2 1 SetWidth: hPen1 PS_DOT SetStyle: hPen2 Create: hPen2 255 0 0 SetRGB: hPen3 4 SetWidth: hPen1 PS_SOLID SetStyle: hPen3 Create: hPen3 0 255 0 SetRGB: hPen4 1 SetWidth: hPen1 PS_NULL SetStyle: hPen4 Create: hPen4 0 128 128 SetRGB: hBrush1 HS_DIAGCROSS SetStyle: hBrush1 Create: hBrush1 ;M :M On_Paint: ( -- ) \ screen redraw procedure GetHandle: self GetDC: tDC if \ Select pen hPen1 hPen1 SelectObject: tDC \ Set Brush to LTGREEN Brush: LTGREEN SelectObject: tDC \ draw a rectangle with solid fill hPen1 SelectObject: tDC 100 80 20 20 DrawRect: self \ change pen to hPen2 and \ draw a dotted line hPen2 SelectObject: tDC drop 100 20 MoveTo: tDC 230 20 LineTo: tDC \ Select pen hPen3 and draw an ellipse Brush: LTYELLOW SelectObject: tDC drop hPen3 SelectObject: tDC drop 100 485 40 340 DrawEllipse: self \ Select pen hPen3 and draw a pie Brush: LTCYAN SelectObject: tDC drop hPen4 SelectObject: tDC drop 190 60 120 140 200 240 120 70 DrawPie: self \ Select pen hPen2, change background color, \ brush and draw a rounded rectangle Color: LTRED SetBackgroundColor: tDC hBrush1 SelectObject: tDC drop hPen2 SelectObject: tDC drop 20 80 200 515 120 290 DrawRoundRect: self \ Change the pen colour and brush, draw an ellipse Color: WHITE SetBackgroundColor: tDC Pen: LTGREEN SelectObject: tDC drop NULL_BRUSH SelectStockObject: tDC drop \ this doesn't work... why? 150 520 20 280 DrawEllipse: self \ Change the pen colour and draw a polyline Pen: MAGENTA SelectObject: tDC drop 5 POLYDATA DrawPolyLine: self \ cleanup SelectObject: tDC drop \ bursh SelectObject: tDC drop \ pen Release: tDC then ;M :M WM_COMMAND ( hwnd msg wparam lparam -- res ) OVER LOWORD ( Id ) CASE IDOK OF Close: self ENDOF ENDCASE 0 ;M ;OBJECT : DEMO ( -- ) Start: Grafdemo ; DEMO \ END OF LISTING --- NEW FILE: Metafile.emf --- (This appears to be a binary file; contents omitted.) --- NEW FILE: Figfonts.f --- \ FigFonts.F Listing for 'Win32Forth Fonts'. \ Written by David R. Pochin \ Changed to use the GDI class library by Dirk Busch \ Examples of Fonts anew -FigFonts.f needs gdi/gdi.f \ Define an Object that is a child object of the Class "Window". :OBJECT Fontdemo <SUPER WINDOW ButtonControl Button_1 \ Declare a button gdiWindowDC tDC gdiFont aFont \ Create a object of the class font gdiFont bFont \ and another :M ClassInit: ( -- ) \ Things to do at the start of window creation. ClassInit: SUPER \ Do anything the class needs. \ set the default font type for printing s" Impact" SetFaceName: aFont 24 SetHeight: aFont true SetUnderline: aFont VARIABLE_PITCH 0x04 or FF_SWISS or SetPitchAndFamily: aFont s" CommonBullets" SetFaceName: bFont 2 SetCharSet: bfont 30 SetHeight: bFont 14 SetWidth: bFont FW_NORMAL SetWeight: bFont VARIABLE_PITCH 0x04 or FF_MODERN or FF_DECORATIVE or SetPitchAndFamily: bFont ;M :M WindowTitle: ( -- title ) \ Title for the window. z" Non Stock Fonts " ;M :M StartSize: ( -- width height ) \ Set width and height of window 600 180 ;M :M StartPos: ( -- x y ) \ Set the screen origin. 80 100 ;M :M Close: ( -- ) \ Do anything the class needs. Destroy: tDC \ delete the dc Destroy: aFont \ delete the fonts no longer needed Destroy: bFont Close: super ;M :M On_Init: ( -- ) \ Add a button. IDOK SetID: Button_1 self Start: Button_1 480 140 70 25 Move: Button_1 s" CLOSE" SetText: Button_1 GetStyle: Button_1 BS_DEFPUSHBUTTON OR SetStyle: Button_1 \ create the fonts Create: aFont Create: bFont ;M :M On_Paint: ( -- ) \ screen redraw procedure GetHandle: self GetDC: tDC if \ Output the first text string. \ Example of the Forth word s" and see the method TextOut: in dc.f \ Note TextOut: requires the length of the string. aFont SelectObject: tDC 20 30 s" aFont AaBbCcDdEeFfGgHhIiJjKkLl" TextOut: tDC bFont SelectObject: tDC drop 20 80 s" bFont AaBbCcDdEeFfGgHhIiJjKkLl" TextOut: tDC \ cleanup SelectObject: tDC drop Release: tDC then ;M :M WM_COMMAND ( hwnd msg wparam lparam -- res ) over LOWORD \ fetch the identity of the Ok button which is in wParam case \ case .. of .. endof .. endcase is a Forth defined \ switch construction IDOK of \ IDOK is the identity of Button_1 Close: self endof endcase 0 ;M ;OBJECT \ Complete the definition of the new object. : DEMO ( -- ) Start: Fontdemo ; demo \ END OF LISTING. --- NEW FILE: BitBlt.f --- \ BitBlt.F Examples of Raster Operations \ Written by David R. Pochin \ Changed to use the GDI class library by Dirk Busch \ Examples of FillRect and BitBlt. anew -BitBlt.f needs gdi/gdi.f \ Define an Object that is a child of the Class Window :OBJECT Bltdemo <SUPER WINDOW gdiWindowDC tDC gdiSolidBrush tBrushRED gdiSolidBrush tBrushGREEN gdiSolidBrush tBrushBLACK ButtonControl Button_1 \ a button :M WindowTitle: ( -- title ) z" BitBlt V.1.1 " ;M :M StartSize: ( -- width height ) 550 350 ;M :M StartPos: ( -- x y ) 100 100 ;M :M Close: ( -- ) Destroy: tDC Destroy: tBrushRED Destroy: tBrushGREEN Destroy: tBrushGREEN Close: super ;M \ Set up a Button and create Pens and Brushes. :M On_Init: ( -- ) \ init the brushes 255 SetRValue: tBrushRED 0 SetGValue: tBrushRED 0 SetBValue: tBrushRED Create: tBrushRED 0 SetRValue: tBrushGREEN 255 SetGValue: tBrushGREEN 0 SetBValue: tBrushGREEN Create: tBrushGREEN \ 0 SetRValue: tBrushBLACK \ Note that Black is the default \ 0 SetGValue: tBrushBLACK \ color, so we don't need to \ 0 SetBValue: tBrushBLACK \ set the color. Create: tBrushBLACK \ create a pushbutton to close the demo IDOK SetID: Button_1 self Start: Button_1 420 300 70 25 Move: Button_1 s" CLOSE" SetText: Button_1 GetStyle: Button_1 BS_DEFPUSHBUTTON OR SetStyle: Button_1 ;M \ Note: This demo was originaly written using the 'old' DC class. \ The BitBlt: method of the gdiDC class is unsig a different stack \ layout. So this method was added fpr compatiblity. :M BitBlt: ( blitmode sourcex,y sourcedc sizex,y destinationx,y -- ) 2>r 2>r >r swap r> 2r> swap 2r> swap 8reverse ( nXDest nYDest nWidth nHeight hdcSrc nXSrc nYSrc dwRop -- ) BitBlt: tDC ;M :M SetUps: { left top right bottom -- } \ draw frames for blocks 39 39 MoveTo: tDC 120 39 LineTo: tDC 120 120 LineTo: tDC 39 120 LineTo: tDC 39 39 LineTo: tDC 159 39 MoveTo: tDC 240 39 LineTo: tDC 240 120 LineTo: tDC 159 120 LineTo: tDC 159 39 LineTo: tDC 359 39 MoveTo: tDC 440 39 LineTo: tDC 440 120 LineTo: tDC 359 120 LineTo: tDC 359 39 LineTo: tDC 39 179 MoveTo: tDC 120 179 LineTo: tDC 120 260 LineTo: tDC 39 260 LineTo: tDC 39 179 LineTo: tDC 159 179 MoveTo: tDC 240 179 LineTo: tDC 240 260 LineTo: tDC 159 260 LineTo: tDC 159 179 LineTo: tDC 359 179 MoveTo: tDC 440 179 LineTo: tDC 440 260 LineTo: tDC 359 260 LineTo: tDC 359 179 LineTo: tDC \ Make the source, original destination and destination blocks 80 40 120 80 tBrushGREEN FillRect: tDC 40 80 80 120 tBrushBLACK FillRect: tDC NOTSRCCOPY 40 40 GetHandle: tDC 80 80 160 40 BitBlt: self SRCCOPY 160 40 GetHandle: tDC 80 80 360 40 BitBlt: self 40 220 120 260 tBrushBLACK FillRect: tDC 200 180 240 260 tBrushBLACK FillRect: tDC SRCCOPY 160 180 GetHandle: tDC 80 80 360 180 BitBlt: self \ Setup the text 55 16 s" Source" TextOut: tDC 160 16 s" Destination" TextOut: tDC 280 16 s" Blt" TextOut: tDC 375 16 s" Result" TextOut: tDC 260 50 s" PATPAINT" TextOut: tDC 255 210 s" MERGECOPY" TextOut: tDC ;M :M BitBlts: \ Top row of display. Alternatively use any of \ BLACKNESS WHITENESS NOTSRCCOPY SRCCOPY \ PATCOPY PATINVERT DSINVERT PATPAINT 40 40 GetHandle: tDC 80 80 360 40 BitBlt: self \ Bottom row of display. Aternatively use any of \ SRCERASE SRCINVERT SRCPAINT MERGEPAINT NOTSRCERASE \ SRCAND MERGECOPY 40 180 GetHandle: tDC 80 80 360 180 BitBlt: self ;M :M On_Paint: ( -- ) \ screen redraw procedure GetHandle: self GetDC: tDC if tBrushRED SelectObject: tDC \ Use this brush as the current pattern SetUps: self BitBlts: self \ cleanup SelectObject: tDC drop Release: tDC then ;M :M WM_COMMAND ( hwnd msg wparam lparam -- res ) OVER LOWORD ( Id ) CASE IDOK OF Close: self ENDOF ENDCASE 0 ;M ;OBJECT : DEMO ( -- ) Start: Bltdemo ; DEMO \ END OF LISTING --- NEW FILE: TxtAlign.f --- \ TextAlign.F \ Written by David R. Pochin \ Changed to use the GDI class library by Dirk Busch anew -TextAlign needs gdi/gdi.f :Object TextAlign <Super Window gdiFont tFont gdiWindowDC tDC ButtonControl Button_1 \ a button :M WindowTitle: ( -- title ) z" Text Alignment" ;M :M StartSize: ( -- w h ) \ the width and height of our window 230 200 ;M :M StartPos: ( -- x y ) \ the screen origin of our window 100 100 ;M :M SetLines: ( -- ) 80 10 MoveTo: tDC 80 110 LineTo: tDC 10 140 MoveTo: tDC 210 140 LineTo: tDC ;M :M PrintText: ( -- ) \ select out Font into the DC tFont SelectObject: tDC \ draw some Text TA_LEFT SetTextAlign: tDC 80 20 s" LEFT" TextOut: tDC TA_CENTER SetTextAlign: tDC drop 80 50 s" CENTRE" TextOut: tDC TA_RIGHT SetTextAlign: tDC drop 80 80 s" RIGHT" TextOut: tDC TA_TOP SetTextAlign: tDC drop 30 140 s" TOP" TextOut: tDC TA_BOTTOM SetTextAlign: tDC drop 70 140 s" BOTTOM" TextOut: tDC TA_BASELINE SetTextAlign: tDC drop 155 140 s" BASE" TextOut: tDC SetTextAlign: tDC drop \ reset Text alignment SelectObject: tDC drop \ reset Font ;M :M On_Paint: ( -- ) GetHandle: self GetDC: tDC if SetLines: self PrintText: self Release: tDC then ;M :M On_Init: ( -- ) \ things to do at the start of window creation On_Init: super \ do anything superclass needs \ init the pushbutton to close the application IDOK SetID: Button_1 self Start: Button_1 80 160 60 25 Move: Button_1 s" CLOSE" SetText: Button_1 BS_DEFPUSHBUTTON +Style: Button_1 \ create a font s" Arial" SetFaceName: tFont 10 SetHeight: tFont Create: tFont drop ;M :M WM_COMMAND ( hwnd msg wparam lparam -- res ) OVER LOWORD ( Id ) CASE IDOK OF Close: self ENDOF ENDCASE 0 ;M :M Close: ( -- ) \ Do anything the class needs. Destroy: tFont Destroy: tDC Close: SUPER ;M ;Object : DEMO ( -- ) \ start running the demo program Start: TextAlign ; \ Runs on load. demo \ End of Listing. --- NEW FILE: TextList.f --- \ TextList.F Example of Object Oriented Text Strings \ Written by David R. Pochin \ Changed to use the GDI class library by Dirk Busch \ Examples of text foreground, background and mode options. anew -TextList.f needs gdi/gdi.f \ Define an Object that is a super object of the Class "Window". :OBJECT Stringdemo <SUPER WINDOW gdiWindowDC tDC ButtonControl Button_1 \ Declare a button :M WindowTitle: ( -- title ) \ Title for the window. z" Text String Objects. Win32Forth " ;M :M StartSize: ( -- width height ) \ Set width and height of window 500 270 ;M :M StartPos: ( -- x y ) \ Set the screen origin. 200 100 ;M :M DrawRect: ( y2 x2 y1 x1 -- ) \ See method GetHandle: in dc.f 4reverse Rectangle: tDC ;M :M Close: ( -- ) \ Do anything the class needs. Destroy: tDC Close: super ;M :M On_Init: ( -- ) \ Add a button. IDOK SetID: Button_1 self Start: Button_1 190 220 70 25 Move: Button_1 s" CLOSE" SetText: Button_1 GetStyle: Button_1 BS_DEFPUSHBUTTON OR SetStyle: Button_1 ;M :M On_Paint: ( -- ) \ screen redraw procedure GetHandle: self GetDC: tDC if \ Output the first text string. \ Example of the Forth word s" and see the method TextOut: in dc.f \ Note TextOut: requires the length of the string. 90 20 s" COUNTED STRING. DEFAULT SETTINGS" TextOut: tDC \ Set TextColor and BkColor. \ See the methods in dc.f which call Windows functions. Color: LTBLUE SetTextColor: tDC Color: LTRED SetBackgroundColor: tDC \ Set up two rectangles to see Mode Effects. \ Again see the methods in dc.f Brush: LTYELLOW SelectObject: tDC 205 220 50 100 DrawRect: self Brush: LTGREEN SelectObject: tDC drop 205 340 50 220 DrawRect: self \ Output the second text string. \ Used the z" word this time, note the string count required '53' \ As expected TextOut: is a method in dc.f 20 60 z" LTBLUE Foreground and LTRED Background. BkMode OPAQUE" 53 TextOut: tDC \ Change background mode. TRANSPARENT SetBackgroundMode: tDC 15 90 s" LTBLUE Foreground and LTRED Background. BkMode TRANSPARENT" TextOut: tDC \ Change Text Color to White Color: LTGREEN SetTextColor: tDC drop 10 120 s" LTRED Background and LTGREEN Foreground. BkMode TRANSPARENT" TextOut: tDC \ Reset background mode to Opaque. OPAQUE SetBackgroundMode: tDC drop 10 150 s" LTRED Background and LTGREEN Foreground. BkMode OPAQUE" TextOut: tDC \ Back to Defaults. SetBackgroundMode: tDC drop SelectObject: tDC drop \ bursh SetBackgroundColor: tDC drop SetTextColor: tDC drop 120 180 s" Back to DEFAULT conditions." TextOut: tDC \ clean up Release: tDC then ;M :M WM_COMMAND ( hwnd msg wparam lparam -- res ) over LOWORD \ fetch the identity of the Ok button which is in wParam case \ case .. of .. endof .. endcase is a Forth defined \ switch construction IDOK of \ IDOK is the identity of Button_1 Close: self endof endcase 0 ;M ;OBJECT \ Complete the definition of the new object. : DEMO ( -- ) Start: Stringdemo ; demo \ END OF LISTING. |
