Menu
▾
▴
win32forth-cvs
|
From: Dirk B. <db...@us...> - 2005-11-01 12:21:48
|
Update of /cvsroot/win32forth/win32forth/src/gdi In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv13139/src/gdi Added Files: gdi.f gdiBase.f gdiBitmap.f gdiBrush.f gdiDC.f gdiFont.f gdiMetafile.f gdiMetafileDc.f gdiPen.f gdiStruct.f gdiWindowDc.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: gdiStruct.f --- \ gdiStruct.f \ \ Written by Dirk Busch \ Sonntag, Oktober 09 2005 \ Licence: Public Domain cr .( Loading GDI class library - Structs...) WinLibrary COMDLG32.DLL internal external \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Wrapper class for a POINT-Struct \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :class gdiPOINT <super object Record: &POINT int x int y ;RecordSize: sizeof(POINT) :M ClassInit: ( -- ) ClassInit: super 0 to x 0 to y ;M :M GetX: ( -- x ) x ;M :M GetY: ( -- y ) y ;M :M SetX: ( x -- ) to x ;M :M SetY: ( y -- ) to y ;M :M Addr: ( -- addr ) &POINT ;M :M Size: ( -- size ) sizeof(POINT) ;M ;class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Wrapper class for a COLOREF-Struct \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :class gdiCOLORREF <super object Record: &COLORREF byte r byte g byte b byte alpha ;RecordSize: sizeof(COLORREF) Record: &CHOOSECOLOR int lStructSize int hwndOwner int hInstance int rgbResult int lpCustColors int Flags int lCustData int lpfnHook int lpTemplateName ;RecordSize: sizeof(CHOOSECOLOR) 64 bytes CustomColors :M ClassInit: ( -- ) ClassInit: super \ init &COLOR record 0 to r 0 to g 0 to b 0 to alpha \ init &CHOOSECOLOR record sizeof(CHOOSECOLOR) to lStructSize CustomColors to lpCustColors [ CC_ANYCOLOR CC_FULLOPEN or CC_RGBINIT or ] literal to Flags null to hwndOwner null to hInstance 0 to rgbResult 0 to lCustData null to lpfnHook null to lpTemplateName \ init custom colors 0xE6FFFF CustomColors ! 0xFFE6FF CustomColors 0x04 + ! 0xFFFFE6 CustomColors 0x08 + ! 0xFFE6E6 CustomColors 0x0C + ! 0xE6FFE6 CustomColors 0x10 + ! 0xE6E6FF CustomColors 0x14 + ! 0xC8F0F0 CustomColors 0x18 + ! 0xF0C8F0 CustomColors 0x1C + ! 0xF0F0C8 CustomColors 0x20 + ! 0xF0C8C8 CustomColors 0x24 + ! 0xC8F0C8 CustomColors 0x28 + ! 0xC8C8F0 CustomColors 0x2C + ! 0xF0F0F0 CustomColors 0x30 + ! 0xE6E6E6 CustomColors 0x34 + ! 0xF4FFFF CustomColors 0x38 + ! 0xFFFFF4 CustomColors 0x3C + ! ;M :M SetAlpha: ( alpha -- ) to alpha ;M :M SetRValue: ( r -- ) to r ;M :M SetGValue: ( g -- ) to g ;M :M SetBValue: ( b -- ) to b ;M :M GetAlpha: ( alpha -- ) alpha ;M :M GetRValue: ( -- r ) r ;M :M GetGValue: ( -- g ) g ;M :M GetBValue: ( -- b ) b ;M :M SetColor: ( colorref -- ) 0x00ffffff and &COLORREF ! ;M :M SetSysColor: ( n -- ) call GetSysColor &COLORREF ! ;M :M GetColor: ( -- colorref ) &COLORREF @ 0x00ffffff and ;M :M SetRGB: ( r g b -- ) SetBValue: self SetGValue: self SetRValue: self ;M :M Addr: ( -- addr ) &COLORREF ;M :M Size: ( -- size ) sizeof(COLORREF) ;M :M Choose: ( hWnd -- f ) to hwndOwner GetColor: self to rgbResult &CHOOSECOLOR call ChooseColor IF rgbResult SetColor: self true else false then ;M ;class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Wrapper class for a RGBQUAD-Struct \ \ The RGBQUAD structure describes a color consisting of relative intensities \ of red, green, and blue. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :class gdiRGBQUAD <super gdiCOLORREF :M SetAlpha: ( alpha -- ) drop ;M :M GetAlpha: ( -- alpha ) 0 ;M ;class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Wrapper class for a SIZE-struct \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :class gdiSIZE <super object Record: &SIZE int cx int cy ;RecordSize: sizeof(SIZE) :M ClassInit: ( -- ) ClassInit: super 0 to cx 0 to cy ;M :M GetX: ( -- x ) cx ;M :M GetY: ( -- y ) cy ;M :M SetX: ( x -- ) to cx ;M :M SetY: ( y -- ) to cy ;M :M Addr: ( -- addr ) &SIZE ;M :M Size: ( -- size ) sizeof(SIZE) ;M ;class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Wrapper class for a TEXTMETRIC-struct \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :class gdiTEXTMETRIC <super object Record: &TEXTMETRIC int tmHeight int tmAscent int tmDescent int tmInternalLeading int tmExternalLeading int tmAveCharWidth int tmMaxCharWidth int tmWeight int tmOverhang int tmDigitizedAspectX int tmDigitizedAspectY byte tmFirstChar byte tmLastChar byte tmDefaultChar byte tmBreakChar byte tmItalic byte tmUnderlined byte tmStruckOut byte tmPitchAndFamily byte tmCharSet ;RecordSize: sizeof(TEXTMETRIC) :M ClassInit: ( -- ) ClassInit: super &TEXTMETRIC sizeof(TEXTMETRIC) erase ;M :M SetHeight: ( n -- ) to tmHeight ;M :M SetAscent: ( n -- ) to tmAscent ;M :M SetDescent: ( n -- ) to tmDescent ;M :M SetInternalLeading: ( n -- ) to tmInternalLeading ;M :M SetExternalLeading: ( n -- ) to tmExternalLeading ;M :M SetAveCharWidth: ( n -- ) to tmAveCharWidth ;M :M SetMaxCharWidth: ( n -- ) to tmMaxCharWidth ;M :M SetWeight: ( n -- ) to tmWeight ;M :M SetOverhang: ( n -- ) to tmOverhang ;M :M SetDigitizedAspectX: ( n -- ) to tmDigitizedAspectX ;M :M SetDigitizedAspectY: ( n -- ) to tmDigitizedAspectY ;M :M SetFirstChar: ( n -- ) to tmFirstChar ;M :M SetLastChar: ( n -- ) to tmLastChar ;M :M SetDefaultChar: ( n -- ) to tmDefaultChar ;M :M SetBreakChar: ( n -- ) to tmBreakChar ;M :M SetItalic: ( n -- ) to tmItalic ;M :M SetUnderlined: ( n -- ) to tmUnderlined ;M :M SetStruckOut: ( n -- ) to tmStruckOut ;M :M SetPitchAndFamily: ( n -- ) to tmPitchAndFamily ;M :M SetCharSet: ( n -- ) to tmCharSet ;M :M GetHeight: ( -- n ) tmHeight ;M :M GetAscent: ( -- n ) tmAscent ;M :M GetDescent: ( -- n ) tmDescent ;M :M GetInternalLeading: ( -- n ) tmInternalLeading ;M :M GetExternalLeading: ( -- n ) tmExternalLeading ;M :M GetAveCharWidth: ( -- n ) tmAveCharWidth ;M :M GetMaxCharWidth: ( -- n ) tmMaxCharWidth ;M :M GetWeight: ( -- n ) tmWeight ;M :M GetOverhang: ( -- n ) tmOverhang ;M :M GetDigitizedAspectX: ( -- n ) tmDigitizedAspectX ;M :M GetDigitizedAspectY: ( -- n ) tmDigitizedAspectY ;M :M GetFirstChar: ( -- n ) tmFirstChar ;M :M GetLastChar: ( -- n ) tmLastChar ;M :M GetDefaultChar: ( -- n ) tmDefaultChar ;M :M GetBreakChar: ( -- n ) tmBreakChar ;M :M GetItalic: ( -- n ) tmItalic ;M :M GetUnderlined: ( -- n ) tmUnderlined ;M :M GetStruckOut: ( -- n ) tmStruckOut ;M :M GetPitchAndFamily: ( -- n ) tmPitchAndFamily ;M :M GetCharSet: ( -- n ) tmCharSet ;M :M Addr: ( -- addr ) &TEXTMETRIC ;M :M Size: ( -- size ) sizeof(TEXTMETRIC) ;M ;class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ The LOGPEN structure defines the style, width, and color of a pen. \ The CreatePenIndirect function uses the LOGPEN structure. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ :struct LOGPEN \ UINT lopnStyle \ int lopnWidth \ int lopnReserved \ COLORREF lopnColor \ ;struct \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ The LOGBRUSH structure defines the style, color, and pattern of a physical \ brush. It is used by the CreateBrushIndirect and ExtCreatePen functions. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ :struct LOGBRUSH \ UINT lbStyle \ COLORREF lbColor \ LONG lbHatch \ ;struct \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ BITMAP struct \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ :struct BITMAP \ LONG bmType \ Specifies the bitmap type. This member must be zero. \ LONG bmWidth \ Specifies the width, in pixels, of the bitmap. \ \ The width must be greater than zero. \ LONG bmHeight \ Specifies the height, in pixels, of the bitmap. \ \ The height must be greater than zero. \ LONG bmWidthBytes \ Specifies the number of bytes in each scan line. \ \ This value must be divisible by 2, because the system \ \ assumes that the bit values of a bitmap form an array \ \ that is word aligned. \ WORD bmPlanes \ Specifies the count of color planes. \ WORD bmBitsPixel \ Specifies the number of bits required to indicate the \ \ color of a pixel. \ LPVOID bmBits \ Pointer to the location of the bit values for the bitmap. \ \ The bmBits member must be a long pointer to an array of \ \ character (1-byte) values. \ ;struct \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ BITMAPINFOHEADER struct \ \ The BITMAPINFOHEADER structure contains information about the dimensions \ and color format of a DIB. \ \ Applications developed for Windows NT 4.0 and Windows 95 may use the \ BITMAPV4HEADER structure. Applications developed for Windows 2000 and \ Windows 98 may use the BITMAPV5HEADER structure for increased functionality. \ However, these can be used only in the CreateDIBitmap function. \ \ NOTE: BITMAPV4HEADER and BITMAPV5HEADER are not supprted !!! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ :struct BITMAPINFOHEADER \ DWORD biSize \ LONG biWidth \ LONG biHeight \ WORD biPlanes \ WORD biBitCount \ DWORD biCompression \ DWORD biSizeImage \ LONG biXPelsPerMeter \ LONG biYPelsPerMeter \ DWORD biClrUsed \ DWORD biClrImportant \ ;struct \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ ENHMETAHEADER struct \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ :struct ENHMETAHEADER \ DWORD iType \ DWORD nSize \ RECTL rclBounds \ RECTL rclFrame \ DWORD dSignature \ DWORD nVersion \ DWORD nBytes \ DWORD nRecords \ WORD nHandles \ WORD sReserved \ DWORD nDescription \ DWORD offDescription \ DWORD nPalEntries \ SIZEL szlDevice \ SIZEL szlMillimeters \ DWORD cbPixelFormat \ DWORD offPixelFormat \ DWORD bOpenGL \ SIZEL szlMicrometers \ ;struct module --- NEW FILE: gdi.f --- \ gdi.f \ \ Written: Sonntag, Oktober 09 2005 by Dirk Busch \ Changed: Samstag, Oktober 29 2005 by Dirk Busch \ \ Licence: Public Domain \ \ Missing: Clipping support \ Colors (Pallette) support \ Region support \ Printing support cr .( Loading GDI class library...) needs gdi/gdiBase.f needs gdi/gdiPen.f needs gdi/gdiBrush.f needs gdi/gdiFont.f needs gdi/gdiBitmap.f needs gdi/gdiMetafile.f needs gdi/gdiDc.f needs gdi/gdiWindowDc.f needs gdi/gdiMetafileDC.f --- NEW FILE: gdiBitmap.f --- \ gdiBitmap.f \ \ Written by Dirk Busch \ Sonntag, Oktober 09 2005 \ Licence: Public Domain cr .( Loading GDI class library - Bitmap...) needs gdiBase.f internal external \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Bitmap class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :class gdiBitmap <super gdiObject gdiSize SIZE :M ClassInit: ( -- ) ClassInit: super ;M \ The CreateBitmap function creates a bitmap with the specified width, height, \ and color format (color planes and bits-per-pixel). \ \ Width Specifies the bitmap width, in pixels. \ Height Specifies the bitmap height, in pixels. \ Planes Specifies the number of color planes used by the device. \ BitsPerPel Specifies the number of bits required to identify the color of a \ single pixel. \ pBits Pointer to an array of color data used to set the colors in a rectangle \ of pixels. Each scan line in the rectangle must be word aligned (scan \ lines that are not word aligned must be padded with zeros). If this \ parameter is NULL, the contents of the new bitmap is undefined. \ \ After a bitmap is created, it can be selected into a device context by calling \ the SelectObject function. The CreateBitmap function can be used to create color \ bitmaps. However, for performance reasons applications should use CreateBitmap \ to create monochrome bitmaps and CreateCompatibleBitmap to create color bitmaps. \ When a color bitmap returned from CreateBitmap is selected into a device context, \ the system must ensure that the bitmap matches the format of the device context \ it is being selected into. Since CreateCompatibleBitmap takes a device context, \ it returns a bitmap that has the same format as the specified device context. \ Because of this, subsequent calls to SelectObject are faster than with a color \ bitmap returned from CreateBitmap. \ \ If the bitmap is monochrome, zeros represent the foreground color and ones represent \ the background color for the destination device context. \ \ If an application sets the nWidth or nHeight parameters to zero, CreateBitmap \ returns the handle to a 1-by-1 pixel, monochrome bitmap. \ \ When you no longer need the bitmap, call the Destroy: method to delete it. \ \ Windows 95/98: The created bitmap cannot exceed 16MB in size :M CreateBitmap: ( Width Height Planes BitsPerPel pBits -- f ) 5reverse call CreateBitmap SetHandle: super Valid?: super ;M \ The CreateBitmapIndirect function creates a bitmap with the specified width, \ height, and color format (color planes and bits-per-pixel). \ pBitmap Pointer to a BITMAP structure that contains information about the \ bitmap. If an application sets the bmWidth or bmHeight members to zero, \ CreateBitmapIndirect returns the handle to a 1-by-1 pixel, monochrome bitmap. :M CreateBitmapIndirect: ( pBitmap -- f ) call CreateBitmapIndirect SetHandle: super Valid?: super ;M \ The CreateCompatibleBitmap function creates a bitmap compatible with the device \ that is associated with the specified device context. \ \ The color format of the bitmap created by the CreateCompatibleBitmap function \ matches the color format of the device identified by the hdc parameter. This \ bitmap can be selected into any memory device context that is compatible with \ the original device. \ \ Because memory device contexts allow both color and monochrome bitmaps, the format \ of the bitmap returned by the CreateCompatibleBitmap function differs when the \ specified device context is a memory device context. However, a compatible bitmap \ that was created for a nonmemory device context always possesses the same color \ format and uses the same color palette as the specified device context. \ \ Note: When a memory device context is created, it initially has a 1-by-1 monochrome \ bitmap selected into it. If this memory device context is used in CreateCompatibleBitmap, \ the bitmap that is created is a monochrome bitmap. To create a color bitmap, use the \ hDC that was used to create the memory device context, as shown in the following code: \ \ HDC memDC = CreateCompatibleDC ( hDC ); \ HBITMAP memBM = CreateCompatibleBitmap ( hDC ); \ SelectObject ( memDC, memBM ); \ \ If an application sets the nWidth or nHeight parameters to zero, CreateCompatibleBitmap \ returns the handle to a 1-by-1 pixel, monochrome bitmap. \ \ If a DIB section, which is a bitmap created by the CreateDIBSection function, is selected \ into the device context identified by the hdc parameter, CreateCompatibleBitmap creates a \ DIB section. \ \ When you no longer need the bitmap, call the DeleteObject function to delete it. \ \ Windows 95/98: The created bitmap cannot exceed 16MB in size. :M CreateCompatibleBitmap: ( Width Height hDC -- f ) GetGdiObjectHandle >r swap r> call CreateCompatibleBitmap SetHandle: super Valid?: super ;M \ The CreateDIBitmap function creates a device-dependent bitmap (DDB) from a DIB and, \ optionally, sets the bitmap bits. \ \ lpbmih Pointer to a bitmap information header structure, which may be one of those \ shown in the following table. Operating system Bitmap information header \ Windows NT 3.51 and earlier BITMAPINFOHEADER \ Windows NT 4.0 and Windows 95 BITMAPV4HEADER NOT SUPPORTED !!! \ Windows 2000 and Windows 98 BITMAPV5HEADER NOT SUPPORTED !!! \ \ If fdwInit is CBM_INIT, the function uses the bitmap information header structure to \ obtain the desired width and height of the bitmap as well as other information. Note \ that a positive value for the height indicates a bottom-up DIB while a negative value \ for the height indicates a top-down DIB. Calling CreateDIBitmap with fdwInit as CBM_INIT \ is equivalent to calling the CreateCompatibleBitmap function to create a DDB in the format \ of the device and then calling the SetDIBits function to translate the DIB bits to the DDB. \ \ fdwInit Specifies how the system initializes the bitmap bits. The following values is defined. \ Value Meaning CBM_INIT If this flag is set, the system uses the data pointed to by the lpbInit \ and lpbmi parameters to initialize the bitmap's bits. If this flag is clear, the data pointed \ to by those parameters is not used. \ \ If fdwInit is zero, the system does not initialize the bitmap's bits. \ \ lpbInit Pointer to an array of bytes containing the initial bitmap data. The format of the data \ depends on the biBitCount member of the BITMAPINFO structure to which the lpbmi parameter points. \ \ lpbmi Pointer to a BITMAPINFO structure that describes the dimensions and color format of the \ array pointed to by the lpbInit parameter. \ \ fuUsage Specifies whether the bmiColors member of the BITMAPINFO structure was initialized and, \ if so, whether bmiColors contains explicit red, green, blue (RGB) values or palette indexes. \ The fuUsage parameter must be one of the following values. Value Meaning \ DIB_PAL_COLORS A color table is provided and consists of an array of 16-bit indexes into the \ logical palette of the device context into which the bitmap is to be selected. \ DIB_RGB_COLORS A color table is provided and contains literal RGB values. :M CreateDIBitmap: ( pbmih fdwInit pbInit pbmi fuUsage hdc -- f ) GetGdiObjectHandle >r 5reverse r> call CreateDIBitmap SetHandle: super Valid?: super ;M \ The CreateDIBSection function creates a DIB that applications can write to directly. The function \ gives you a pointer to the location of the bitmap's bit values. You can supply a handle to a \ file-mapping object that the function will use to create the bitmap, or you can let the system \ allocate the memory for the bitmap. \ \ hdc Handle to a device context. If the value of iUsage is DIB_PAL_COLORS, the function uses \ this device context's logical palette to initialize the DIB's colors. \ \ pbmi Pointer to a BITMAPINFO structure that specifies various attributes of the DIB, including \ the bitmap's dimensions and colors. \ \ iUsage Specifies the type of data contained in the bmiColors array member of the BITMAPINFO \ structure pointed to by pbmi (either logical palette indexes or literal RGB values). The \ following values are defined. Value Meaning \ DIB_PAL_COLORS The bmiColors member is an array of 16-bit indexes into the logical palette of \ the device context specified by hdc. \ DIB_RGB_COLORS The BITMAPINFO structure contains an array of literal RGB values. \ \ ppvBits Pointer to a variable that receives a pointer to the location of the DIB's bit values. \ \ hSection Handle to a file-mapping object that the function will use to create the DIB. This \ parameter can be NULL. If hSection is not NULL, it must be a handle to a file-mapping object \ created by calling the CreateFileMapping function with the PAGE_READWRITE or PAGE_WRITECOPY flag. \ Read-only DIB sections are not supported. Handles created by other means will cause CreateDIBSection \ to fail. If hSection is not NULL, the CreateDIBSection function locates the bitmap's bit values at \ offset dwOffset in the file-mapping object referred to by hSection. An application can later retrieve \ the hSection handle by calling the GetObject function with the HBITMAP returned by CreateDIBSection. \ If hSection is NULL, the system allocates memory for the DIB. In this case, the CreateDIBSection \ function ignores the dwOffset parameter. An application cannot later obtain a handle to this memory. \ The dshSection member of the DIBSECTION structure filled in by calling the GetObject function will \ be NULL. \ \ dwOffset Specifies the offset from the beginning of the file-mapping object referenced by hSection \ where storage for the bitmap's bit values is to begin. This value is ignored if hSection is NULL. \ The bitmap's bit values are aligned on doubleword boundaries, so dwOffset must be a multiple of the \ size of a DWORD. :M CreateDIBSection: ( pbmi iUsage ppvBits hSection dwOffset hdc -- f ) GetGdiObjectHandle >r 5reverse r> call CreateDIBSection SetHandle: super Valid?: super ;M \ The SetBitmapDimension function assigns preferred dimensions to a bitmap. These dimensions can be \ used by applications; however, they are not used by the system. \ Width Specifies the width, in 0.1-millimeter units, of the bitmap. \ Height Specifies the height, in 0.1-millimeter units, of the bitmap. \ An application can retrieve the dimensions assigned to a bitmap with the SetBitmapDimensionEx function \ by calling the GetBitmapDimension function. \ The bitmap identified by hBitmap cannot be a DIB section, which is a bitmap created by the \ CreateDIBSection function. If the bitmap is a DIB section, the SetBitmapDimension function fails. :M SetBitmapDimension: ( width height -- oldwidth oldheight ) Addr: SIZE 3reverse hObject call SetBitmapDimensionEx ?win-error GetX: SIZE GetY: SIZE ;M \ The GetBitmapDimension function retrieves the dimensions of a bitmap. The retrieved dimensions must \ have been set by the SetBitmapDimension function. \ The function returns the height and width of the bitmap, in .01-mm units. :M GetBitmapDimension: ( -- width height ) Addr: SIZE hObject call GetBitmapDimensionEx ?win-error GetX: SIZE GetY: SIZE ;M \ SetDIBits \ GetDIBits \ LoadBitmap \ MaskBlt \ PlgBlt ;class module --- NEW FILE: gdiBrush.f --- \ gdiBrush.f \ \ Written by Dirk Busch \ Sonntag, Oktober 09 2005 \ Licence: Public Domain cr .( Loading GDI class library - Brush...) needs gdiBase.f internal external \ ---------------------------------------------------------------------- \ Base class for all brush objects \ ---------------------------------------------------------------------- internal :class gdiBrush <super gdiObject gdiPoint origin :M ClassInit: ( -- ) ClassInit: super ;M :M SetOrigin: { xOrg yOrg hdc -- } NULL yOrg xOrg hdc GetGdiObjectHandle call SetBrushOrgEx ?win-error ;M :M GetOrigin: ( hdc -- xOrg yOrg ) Addr: origin call GetBrushOrgEx 0= if -1 -1 \ error else GetX: origin GetY: origin then ;M \ The Create function creates a logical brush that has the specified style, \ color, and pattern. \ lplb Pointer to a LOGBRUSH structure that contains information about the \ brush. :M Create: ( lplb -- f ) call CreateBrushIndirect SetHandle: super Valid?: super ;M ;class external \ ---------------------------------------------------------------------- \ Solid brush class \ ---------------------------------------------------------------------- :class gdiSolidBrush <super gdiBrush \ Color of the brush. gdiCOLORREF Color :M ClassInit: ( -- ) ClassInit: super ;M :M SetRValue: ( r -- ) SetRValue: Color ;M :M SetGValue: ( g -- ) SetGValue: Color ;M :M SetBValue: ( b -- ) SetBValue: Color ;M :M SetRGB: ( r g b -- ) SetRGB: Color ;M :M SetColor: ( colorref -- ) SetColor: Color ;M :M SetSysColor: ( n -- ) SetSysColor: Color ;M :M ChooseColor: ( hWnd -- f ) Choose: Color ;M :M GetRValue: ( -- r ) GetRValue: Color ;M :M GetGValue: ( -- g ) GetGValue: Color ;M :M GetBValue: ( -- b ) GetBValue: Color ;M :M GetColor: ( -- colorref ) GetColor: Color ;M :M Create: ( -- f ) GetColor: color call CreateSolidBrush SetHandle: super Valid?: super ;M ;class \ ---------------------------------------------------------------------- \ Hatch brush class \ ---------------------------------------------------------------------- :class gdiHatchBrush <super gdiSolidBrush \ Style of the brush. Possible values are: \ HS_BDIAGONAL 45-degree downward left-to-right hatch \ HS_CROSS Horizontal and vertical crosshatch \ HS_DIAGCROSS 45-degree crosshatch \ HS_FDIAGONAL 45-degree upward left-to-right hatch \ HS_HORIZONTAL Horizontal hatch \ HS_VERTICAL Vertical hatch int Style :M ClassInit: ( -- ) ClassInit: super HS_BDIAGONAL to style ;M :M SetStyle: ( style -- ) to style ;M :M GetStyle: ( -- style ) style ;M :M Create: ( -- f ) GetColor: color Style call CreateHatchBrush SetHandle: super Valid?: super ;M ;class \ ---------------------------------------------------------------------- \ Pattern brush class \ ---------------------------------------------------------------------- :class gdiPatternBrush <super gdiBrush \ Bitmap of the brush. int Bitmap :M ClassInit: ( -- ) ClassInit: super 0 to Bitmap ;M :M SetBitmap: ( Bitmap -- ) to Bitmap ;M :M GetBitmap: ( -- Bitmap ) Bitmap ;M :M Create: ( -- f ) Bitmap ?dup if call CreatePatternBrush SetHandle: super then Valid?: super ;M ;class \ ---------------------------------------------------------------------- \ DIBPattern brush class \ ---------------------------------------------------------------------- :class gdiDIBPatternBrush <super gdiBrush :M ClassInit: ( -- ) ClassInit: super ;M \ The Create function creates a logical brush that has the pattern specified \ by the device-independent bitmap (DIB). \ \ lpPackedDIB Pointer to a packed DIB consisting of a BITMAPINFO structure immediately \ followed by an array of bytes defining the pixels of the bitmap. \ Windows 95: Creating brushes from bitmaps or DIBs larger than 8 by 8 pixels \ is not supported. If a larger bitmap is specified, only a portion of the bitmap \ is used. \ Windows NT/ 2000 and Windows 98: Brushes can be created from bitmaps or DIBs \ larger than 8 by 8 pixels. \ \ iUsage Specifies whether the bmiColors member of the BITMAPINFO structure contains \ a valid color table and, if so, whether the entries in this color table contain \ explicit red, green, blue (RGB) values or palette indexes. The iUsage parameter \ must be one of the following values. \ DIB_PAL_COLORS A color table is provided and consists of an array of 16-bit indexes \ into the logical palette of the device context into which the brush \ is to be selected. \ DIB_RGB_COLORS A color table is provided and contains literal RGB values. :M Create: ( lpPackedDIB iUsage -- f ) call CreateDIBPatternBrushPt SetHandle: super Valid?: super ;M ;class module --- NEW FILE: gdiDC.f --- \ gdiDC.f \ \ Written by Dirk Busch \ Sonntag, Oktober 09 2005 \ Licence: Public Domain \ \ Missing: - WorldTransform support cr .( Loading GDI class library - Device context...) needs gdiBase.f internal 8 constant TAB-CHAR-WIDTH external \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ [...1244 lines suppressed...] \ StretchBlt \ StretchDIBits \ TransparentBlt W98 and w2k or later \ PatBlt \ AngleArc \ SetMiterLimit \ GetMiterLimit \ ---------------------------------------------------------------------- \ ---------------------------------------------------------------------- :M ClassInit: ( -- ) ClassInit: super 8 to tabwidth DefaultTabs: self ;M ;class module --- NEW FILE: gdiPen.f --- \ gdiPen.f \ \ Written by Dirk Busch \ Sonntag, Oktober 09 2005 \ Licence: Public Domain \ \ TODO: finish gdiGeometricPen class cr .( Loading GDI class library - Pen...) needs gdiBase.f internal external \ ---------------------------------------------------------------------- \ Pen class - for cosmetic pen's \ ---------------------------------------------------------------------- :class gdiPen <super gdiObject \ Syle of the pen. Possible values are: \ PS_SOLID The pen is solid. \ PS_DASH The pen is dashed. This style is valid only when the pen width \ is one or less in device units. \ PS_DOT The pen is dotted. This style is valid only when the pen width \ is one or less in device units. \ PS_DASHDOT The pen has alternating dashes and dots. This style is valid \ only when the pen width is one or less in device units. \ PS_DASHDOTDOT The pen has alternating dashes and double dots. This style is \ valid only when the pen width is one or less in device units. \ PS_NULL The pen is invisible. \ PS_INSIDEFRAME The pen is solid. When this pen is used in any GDI drawing \ function that takes a bounding rectangle, the dimensions of the figure are \ shrunk so that it fits entirely in the bounding rectangle, taking into account \ the width of the pen. This applies only to geometric pens. int Style \ Width of the pen, in logical units. If Width is zero, the pen is a single pixel \ wide, regardless of the current transformation. int Width \ Color of the pen. gdiCOLORREF Color :M ClassInit: ( -- ) ClassInit: super PS_SOLID to Style 1 to Width ;M :M SetStyle: ( style -- ) to style ;M :M SetWidth: ( width -- ) 0 max to width ;M :M SetRValue: ( r -- ) SetRValue: Color ;M :M SetGValue: ( g -- ) SetGValue: Color ;M :M SetBValue: ( b -- ) SetBValue: Color ;M :M SetRGB: ( r g b -- ) SetRGB: Color ;M :M SetColor: ( colorref -- ) SetColor: Color ;M :M SetSysColor: ( n -- ) SetSysColor: Color ;M :M ChooseColor: ( hWnd -- f ) Choose: Color ;M :M GetStyle: ( -- style ) style ;M :M GetWidth: ( -- width ) width ;M :M GetRValue: ( -- r ) GetRValue: Color ;M :M GetGValue: ( -- g ) GetGValue: Color ;M :M GetBValue: ( -- b ) GetBValue: Color ;M :M GetColor: ( -- colorref ) GetColor: Color ;M :M Create: ( -- f ) GetColor: color width style call CreatePen SetHandle: super Valid?: super ;M \ The CreateIndirect function creates a logical cosmetic pen that \ has the style, width, and color specified in a structure. :M CreateIndirect: ( pLogpen -- f ) dup @ SetStyle: self dup cell+ @ SetWidth: self dup 3 cells + @ SetColor: self call CreatePenIndirect SetHandle: super Valid?: super ;M ;class \ ---------------------------------------------------------------------- \ GeometricPen class - for geometric pen's \ ---------------------------------------------------------------------- :class gdiGeometricPen <super gdiObject \ ExtCreatePen ;class module --- NEW FILE: gdiWindowDc.f --- \ gdiWindowDc.f \ \ Written by Dirk Busch \ Sonntag, Oktober 09 2005 \ Licence: Public Domain cr .( Loading GDI class library - Window device context...) needs gdiDC.f internal external \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Window device context class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :class gdiWindowDC <super gdiDC int hWnd \ handle of the window in which this device context is used :M ClassInit: ( -- ) ClassInit: super 0 to hWnd ;M \ The ReleaseWndDC: function releases a device context (DC), freeing it \ for use by other applications. The effect of the ReleaseDC function depends \ on the type of DC. It frees only common and window DCs. It has no effect on \ class or private DCs. :M Release: ( -- ) hWnd ?dup if hObject swap call ReleaseDC ?win-error 0 to hWnd then ;M :M Destroy: ( -- ) Release: self Destroy: super ;M : SetWindow ( hWnd -- f ) Release: self dup to hWnd call IsWindow ; : SetHandle ( hDC -- f ) SetHandle: super Valid?: super ; \ The GetDC method retrieves a handle to a display device context \ (DC) for the client area of a specified window. :M GetDC: ( hWnd -- f ) SetWindow if hWnd call GetDC else NULL then SetHandle ;M \ The GetDCEx function retrieves a handle to a display device context \ (DC) for the client area of a specified window or for the entire screen. \ You can use the returned handle in subsequent GDI functions to draw in the DC. \ \ This function is an extension to the GetDC function, which gives an application \ more control over how and whether clipping occurs in the client area. \ \ hrgnClip Specifies a clipping region that may be combined with the visible region \ of the DC. If the value of flags is DCX_INTERSECTRGN or DCX_EXCLUDERGN, then the \ operating system assumes ownership of the region and will automatically delete it \ when it is no longer needed. In this case, applications should not use the region \ not even delete it after a successful call to GetDCEx. \ \ flags Specifies how the DC is created. This parameter can be one or more of the \ following values. \ DCX_WINDOW Returns a DC that corresponds to the window rectangle rather \ than the client rectangle. \ DCX_CACHE Returns a DC from the cache, rather than the OWNDC or CLASSDC \ window. Essentially overrides CS_OWNDC and CS_CLASSDC. \ DCX_PARENTCLIP Uses the visible region of the parent window. The parent's \ WS_CLIPCHILDREN and CS_PARENTDC style bits are ignored. The \ origin is set to the upper-left corner of the window identified \ by hWnd. \ DCX_CLIPSIBLINGS Excludes the visible regions of all sibling windows above the \ window identified by hWnd. \ DCX_CLIPCHILDREN Excludes the visible regions of all child windows below the \ window identified by hWnd. \ DCX_NORESETATTRS Does not reset the attributes of this DC to the default attributes \ when this DC is released. \ DCX_LOCKWINDOWUPDATE Allows drawing even if there is a LockWindowUpdate call in effect \ that would otherwise exclude this window. Used for drawing during \ tracking. \ DCX_EXCLUDERGN The clipping region identified by hrgnClip is excluded from the \ visible region of the returned DC. \ DCX_INTERSECTRGN The clipping region identified by hrgnClip is intersected with the \ visible region of the returned DC. \ DCX_VALIDATE When specified with DCX_INTERSECTUPDATE, causes the DC to be \ completely validated. Using this function with both DCX_INTERSECTUPDATE \ and DCX_VALIDATE is identical to using the BeginPaint function. :M GetDCEx: ( hrgnClip flags hWnd -- f ) SetWindow if swap hWnd call GetDCEx else NULL then SetHandle ;M \ The GetWindowDC method retrieves the device context (DC) for the entire \ window, including title bar, menus, and scroll bars. A window device \ context permits painting anywhere in a window, because the origin of \ the device context is the upper-left corner of the window instead of \ the client area. :M GetWindowDC: ( hWnd -- f ) SetWindow if hWnd call GetWindowDC else NULL then SetHandle ;M \ The GetDCOrgEx function retrieves the final translation origin for a specified device \ context (DC). The final translation origin specifies an offset that the system uses to \ translate device coordinates into client coordinates (for coordinates in an application's \ window). :M GetDCOrg: ( -- x y ) Addr: POINT hObject call GetDCOrgEx ?win-error GetX: POINT GetY: POINT ;M ;class module --- NEW FILE: gdiMetafile.f --- \ gdiMetafile.f \ \ Written by Dirk Busch \ Sonntag, Oktober 09 2005 \ Licence: Public Domain cr .( Loading GDI class library - Metafile...) needs gdiBase.f needs gdiDC.f internal external \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Metafile class - This class only support's enhanced metafiles (emf) ! \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :class gdiMetafile <super gdiObject :M ClassInit: ( -- ) ClassInit: super ;M \ The DeleteEnhMetaFile function deletes an enhanced-format metafile \ or an enhanced-format metafile handle. :M Destroy: ( -- ) hObject ?dup if call DeleteEnhMetaFile ?win-error 0 to hObject then ;M :M SetHandle: ( hMF -- ) Destroy: self to hObject ;M \ Create a copy of the metafile in memory :M Copy: ( -- hCopy ) hObject if 0 hObject call CopyEnhMetaFile else null then ;M : FileName ( addr len -- addr1 ) pad place pad +null pad 1+ ; \ Load a metafile from a file :M Load: ( addr len -- f ) FileName call GetEnhMetaFile SetHandle: self Valid?: super ;M \ Save the metafile in a file :M Save: ( addr len -- f ) hObject if FileName hObject call CopyEnhMetaFile dup if call DeleteEnhMetaFile ?win-error true else false then else 2drop false then ;M \ Play the metafile in a rectangle :M PlayInRect: ( left top right bottom hDestDC -- ) GetGdiObjectHandle >r SetRect: TempRect AddrOf: TempRect hObject r> call PlayEnhMetaFile ?win-error ;M \ Copy the metafile to the clipboard :M CopyToClipboard: ( -- ) hObject if null call OpenClipboard ?win-error call EmptyClipboard ?win-error null hObject call CopyEnhMetaFile CF_ENHMETAFILE call SetClipboardData ?win-error call CloseClipboard ?win-error then ;M \ Get a metafile from the clipboard :M GetFromClipboard: ( -- ) null call OpenClipboard ?win-error CF_ENHMETAFILE call GetClipboardData call CloseClipboard ?win-error ?dup if null swap call CopyEnhMetaFile SetHandle: self then ;M \ The GetMetaFileHeader function retrieves the record containing the header \ for the specified enhanced-format metafile. \ pemh Pointer to an ENHMETAHEADER structure that receives the header record. \ If this parameter is NULL, the function returns the size of the header record. \ size Specifies the size, in bytes, of the buffer to receive the data. Only this \ many bytes will be copied. :M GetFileHeader: ( pemh size -- n ) hObject call GetEnhMetaFileHeader ;M \ The GetPaletteEntries function retrieves optional palette entries from the \ specified enhanced metafile. \ cEntries Specifies the number of entries to be retrieved from the optional \ palette. \ lppe Pointer to an array of PALETTEENTRY structures that receives the palette \ colors. The array must contain at least as many structures as there are entries \ specified by the cEntries parameter. \ If the array pointer is NULL and the enhanced metafile contains an optional palette, \ the return value is the number of entries in the enhanced metafile's palette; if \ the array pointer is a valid pointer and the enhanced metafile contains an optional \ palette, the return value is the number of entries copied; if the metafile does not \ contain an optional palette, the return value is zero. Otherwise, the return value \ is GDI_ERROR. :M GetPaletteEntries: ( cEntries lppe -- n ) swap hObject call GetEnhMetaFilePaletteEntries ;M ;class module --- NEW FILE: gdiBase.f --- \ gdiBase.f \ \ Written by Dirk Busch \ Sonntag, Oktober 09 2005 \ Licence: Public Domain cr .( Loading GDI class library - Base...) needs gdiStruct.f internal external in-application [undefined] S-REVERSE [IF] \ from toolset.f \ Reverse n items on stack \ Usage: 1 2 3 4 5 5 S_REVERSE ==> 5 4 3 2 1 CODE S-REVERSE ( n[k]..2 1 0 k -- 0 1 2..n[k] ) lea ecx, -4 [esp] \ ecx points 4 under top of stack lea ebx, 4 [ecx] [ebx*4] \ ebx points 4 over stack \ bump pointers, if they overlap, stop @@1: sub ebx, # 4 \ adjust top add ecx, # 4 \ adjust bottom cmp ecx, ebx \ compare jae short @@2 \ ecx passing ebx, so exit \ rotate a pair \ xor a,b xor b,a xor a,b swaps a and b mov eax, 0 [ebx] \ bottom to eax xor 0 [ecx], eax \ exchange top and eax xor eax, 0 [ecx] xor 0 [ecx], eax mov 0 [ebx], eax \ eax to bottom jmp short @@1 \ next pair @@2: pop ebx \ tos next c; [then] [undefined] 3reverse [if] : 3reverse ( n1 n2 n3 -- n3 n2 n1 ) 3 S-REVERSE ; [then] [undefined] 4reverse [if] : 4reverse ( n1 n2 n3 n4 -- n4 n3 n2 n1 ) 4 S-REVERSE ; [then] [undefined] 5reverse [if] : 5reverse ( n1 n2 n3 n4 n5 -- n5 n4 n3 n2 n1 ) 5 S-REVERSE ; [then] [undefined] 6reverse [if] : 6reverse ( n1 n2 n3 n4 n5 n6 -- n6 n5 n4 n3 n2 n1 ) 6 S-REVERSE ; [then] [undefined] 8reverse [if] : 8reverse ( n1 n2 n3 n4 n5 n6 n7 n8 -- n8 n7 n6 n5 n4 n3 n2 n1 ) 8 S-REVERSE ; [then] \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Global linked list of gdi objects \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ internal VARIABLE gdi-object-link gdi-object-link OFF external \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Base class for all GDI Objects \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :class GdiObject <super object int hObject \ handle of the GDI object :M ZeroHandle: ( -- ) 0 to hObject ;M :M ClassInit: ( -- ) ClassInit: super ZeroHandle: self \ zero handle gdi-object-link link, \ link into list so we self , \ can send ourself messages ;M \ The GetType method retrieves the type of the specified object. \ Possible return values are: \ OBJ_BITMAP Bitmap \ OBJ_BRUSH Brush \ OBJ_COLORSPACE Color space \ OBJ_DC Device context \ OBJ_ENHMETADC Enhanced metafile DC \ OBJ_ENHMETAFILE Enhanced metafile \ OBJ_EXTPEN Extended pen \ OBJ_FONT Font \ OBJ_MEMDC Memory DC \ OBJ_METAFILE Metafile \ OBJ_METADC Metafile DC \ OBJ_PAL Palette \ OBJ_PEN Pen \ OBJ_REGION Region :M GetType: ( -- n ) hObject call GetObjectType ;M \ The GetObject function retrieves information for the specified graphics object. \ If the function succeeds, and lpvObject is a valid pointer, the return value is \ the number of bytes stored into the buffer. \ If the function succeeds, and lpvObject is NULL, the return value is the number \ of bytes required to hold the information the function would store into the buffer. \ If the function fails, the return value is zero. :M GetObject: ( cbBuffer lpvObject -- n ) hObject 3reverse call GetObject ;M \ check if it's save to destroy the object : Destroy? ( -- f ) GetType: self dup OBJ_PEN = swap dup OBJ_EXTPEN = swap dup OBJ_BRUSH = swap dup OBJ_FONT = swap dup OBJ_BITMAP = swap dup OBJ_REGION = swap OBJ_PAL = or or or or or or ; :M Destroy: ( -- ) Destroy? if hObject call DeleteObject ?win-error then 0 to hObject ;M :M GetHandle: ( -- hObject ) hObject ;M :M SetHandle: ( hObject -- ) Destroy: self to hObject ;M \ Check if this object is valid :M Valid?: ( -- f ) hObject 0<> ;M \ **************** INTERNAL SYSTEM FUNCTIONS FOLLOW **************** \ The following functions and methods make sure that any gdi objects \ created in your application get reset at system startup, and deleted \ when Win32Forth closes. in-system : trim-gdi-objects ( nfa -- nfa ) dup gdi-object-link full-trim ; forget-chain chain-add trim-gdi-objects in-application : do-objects { method -- } gdi-object-link @ begin dup while dup cell+ @ method execute @ repeat drop ; : init-gdi-objects ( -- ) \ clear all font handles [getmethod] ZeroHandle: GdiObject do-objects ; : destroy-gdi-objects ( -- ) \ destroy all font handles [getmethod] Destroy: GdiObject do-objects ; initialization-chain chain-add init-gdi-objects unload-chain chain-add destroy-gdi-objects ;class in-system \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Displays the current set of defined gdi objects \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : .gdi-objects ( -- ) gdi-object-link @ begin dup while dup cell+ @ cell - body> .NAME 12 #tab space 12 ?cr @ repeat drop ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ A utility word to check that an operation about to be performed is really \ being done on a gdi object, helps prevent horrible crashes \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ in-application : ?IsGdiObject ( a1 -- f ) >r gdi-object-link @ begin dup while dup cell+ @ r@ = \ match this gdi object? if drop r>drop true EXIT \ leave test, passed then @ repeat drop r>drop false ; \ Check if GdiObject is an valid GdiObject. If so return the handle of the object. : GetGdiObjectHandle { GdiObject -- handle } GdiObject ?IsGdiObject if GetHandle: GdiObject else GdiObject then ; in-system : (?GdiCheck) ( a1 -- a1 ) dup ?IsGdiObject 0= if forth-io .rstack true Abort" This is not a GDI Object!" then ; in-application : ?GdiCheck ( a1 -- a1 ) \ verify that a1 is a gdi object address TURNKEYED? ?win-error-enabled 0= or ?EXIT \ leave if error checking is not enabled \in-system-ok (?GdiCheck) ; module --- NEW FILE: gdiMetafileDc.f --- \ gdiMetafileDC.f \ \ Written by Dirk Busch \ Sonntag, Oktober 09 2005 \ Licence: Public Domain cr .( Loading GDI class library - Metafile device context...) needs gdiDC.f needs gdiMetafile.f internal external \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Metafile device context class \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ :class gdiMetafileDC <super gdiDC RECTANGLE MetaRect create MetaName maxstring allot gdiMetafile Metafile \ Specify the dimensions (in .01-millimeter units) of the picture to be \ stored in the enhanced metafile. :M SetRect: ( left top right bottom -- ) SetRect: MetaRect ;M :M ClassInit: ( -- ) ClassInit: super 0 MetaName ! 0 0 10000 10000 SetRect: self ;M \ Calc the dimensions (in .01-millimeter units) of the picture to be \ stored in the enhanced metafile. :M CalcMetaRect: { left top right bottom hDC \ iWidthMM iHeightMM iWidthPels iHeightPels -- } hDC GetGdiObjectHandle to hDC \ Determine the picture frame dimensions. \ iWidthMM is the display width in millimeters. \ iHeightMM is the display height in millimeters. \ iWidthPels is the display width in pixels. \ iHeightPels is the display height in pixels HORZSIZE hDC call GetDeviceCaps to iWidthMM HORZRES hDC call GetDeviceCaps to iWidthPels VERTSIZE hDC call GetDeviceCaps to iHeightMM VERTRES hDC call GetDeviceCaps to iHeightPels \ Convert client coordinates to .01-mm units. \ Use iWidthMM, iWidthPels, iHeightMM, and iHeightPels to \ determine the number of .01-millimeter units per pixel in \ the x- and y-directions. left iWidthMM * 100 * iWidthPels / top iHeightMM * 100 * iHeightPels / right iWidthMM * 100 * iWidthPels / bottom iHeightMM * 100 * iHeightPels / SetRect: MetaRect ;M \ Start recording of a Metafile :M StartRecording: ( hRefDC -- f ) GetGdiObjectHandle >r >r \ build description string \ s" Win32Forth" pad place \ pad count + dup 0 c! char + dup \ MetaName count dup >r place r> \ + char + 0 c! \ pad 1+ 0 \ lpDescription Addrof: MetaRect 0 \ lpstrFileName r> call CreateEnhMetaFile dup to hObject hObject 0<> ;M \ Stop recording of a Metafile :M StopRecording: ( -- f ) hObject ?dup if call CloseEnhMetaFile dup SetHandle: Metafile 0<> 0 to hObject else false then ;M \ Load a metafile from a file :M Load: ( addr len -- f ) StopRecording: self drop Load: Metafile ;M \ Save the metafile in a file :M Save: ( addr len -- f ) StopRecording: self drop Save: Metafile ;M \ The DeleteEnhMetaFile function deletes an enhanced-format metafile \ or an enhanced-format metafile handle. :M Destroy: ( -- ) StopRecording: self drop Destroy: Metafile ;M \ Play the metafile in a rectangle :M Draw: ( left top right bottom hDestDC -- ) PlayInRect: Metafile ;M \ Return the address of the metafile object used by this class :M GetMetafile: ( -- MetafileObject ) Metafile ;M ;class module --- NEW FILE: gdiFont.f --- \ gdiFont.f \ \ Written by Dirk Busch \ Sonntag, Oktober 09 2005 \ Licence: Public Domain cr .( Loading GDI class library - Font...) needs gdiBase.f internal external \ ---------------------------------------------------------------------- \ Font class \ ---------------------------------------------------------------------- :Class GdiFont <Super GdiObject Record: LOGFONT int lfHeight \ width in pixels, device specific int lfWidth \ height in pixels, device specific int lfEscapement int lfOrientation \ in 10ths of a degree int lfWeight byte lfItalic \ TRUE/FALSE byte lfUnderline \ TRUE/FALSE byte lfStrikeOut \ TRUE/FALSE byte lfCharSet byte lfOutPrecision byte lfClipPrecision byte lfQuality byte lfPitchAndFamily LF_FACESIZE bytes lfFaceName \ the font name ;RecordSize: sizeof(LOGFONT) Record: &CHOOSEFONT int lStructSize int hwndOwner int hDC int lpLogFont int iPointSize int Flags int rgbColors int lCustData int lpfnHook int lpTemplateName int hInstance int lpszStyle short nFontType short ___MISSING_ALIGNMENT__ int nSizeMin int nSizeMax ;RecordSize: sizeof(CHOOSEFONT) :M ClassInit: ( -- ) ClassInit: super \ init LOGFONT record 14 to lfHeight 9 to lfWidth 0 to lfEscapement 0 to lfOrientation \ in 10th degrees FW_DONTCARE to lfWeight FALSE to lfItalic FALSE to lfUnderline FALSE to lfStrikeOut ANSI_CHARSET to lfCharSet OUT_TT_PRECIS to lfOutPrecision CLIP_DEFAULT_PRECIS to lfClipPrecision PROOF_QUALITY to lfQuality FIXED_PITCH 0x04 or FF_SWISS or to lfPitchAndFamily \ font family lfFaceName LF_FACESIZE erase \ clear font name s" Courier New" lfFaceName swap move \ move in default name \ init &CHOOSEFONT record sizeof(CHOOSEFONT) to lStructSize LOGFONT to lpLogFont [ CF_SCREENFONTS CF_INITTOLOGFONTSTRUCT or ] literal to Flags null to hwndOwner null to hDC 0 to iPointSize 0 to rgbColors 0 to lCustData null to lpfnHook null to lpTemplateName null to hInstance 0 to lpszStyle 0 to nFontType 0 to nSizeMin 0 to nSizeMax ;M :M SetHeight: ( n1 -- ) to lfHeight ;M :M SetWidth: ( n1 -- ) to lfWidth ;M :M SetEscapement: ( n1 -- ) to lfEscapement ;M :M SetOrientation: ( n1 -- ) to lfOrientation ;M \ 10th/degree increments :M SetWeight: ( n1 -- ) to lfWeight ;M :M SetItalic: ( f1 -- ) to lfItalic ;M \ TRUE/FALSE :M SetUnderline: ( f1 -- ) to lfUnderline ;M \ TRUE/FALSE :M SetStrikeOut: ( f1 -- ) to lfStrikeOut ;M \ TRUE/FALSE :M SetCharSet: ( n1 -- ) to lfCharSet ;M :M SetOutPrecision: ( n1 -- ) to lfOutPrecision ;M :M SetClipPrecision: ( n1 -- ) to lfClipPrecision ;M :M SetQuality: ( n1 -- ) to lfQuality ;M :M SetPitchAndFamily: ( n1 -- ) to lfPitchAndFamily ;M :M SetFaceName: ( a1 n1 -- ) lfFaceName LF_FACESIZE erase LF_FACESIZE 1- min lfFaceName swap move ;M :M GetHeight: ( -- n1 ) lfHeight ;M :M GetWidth: ( -- n1 ) lfWidth ;M :M GetEscapement: ( -- n1 ) lfEscapement ;M :M GetOrientation: ( -- n1 ) lfOrientation ;M \ 10th/degree increments :M GetWeight: ( -- n1 ) lfWeight ;M :M GetItalic: ( -- f1 ) lfItalic ;M \ TRUE/FALSE :M GetUnderline: ( -- f1 ) lfUnderline ;M \ TRUE/FALSE :M GetStrikeOut: ( -- f1 ) lfStrikeOut ;M \ TRUE/FALSE :M GetCharSet: ( -- n1 ) lfCharSet ;M :M GetOutPrecision: ( -- n1 ) lfOutPrecision ;M :M GetClipPrecision: ( -- n1 ) lfClipPrecision ;M :M GetQuality: ( -- n1 ) lfQuality ;M :M GetPitchAndFamily: ( -- n1 ) lfPitchAndFamily ;M :M GetLogfont: ( -- n1 ) LOGFONT ;M :M GetFaceName: ( -- a1 n1 ) lfFaceName LF_FACESIZE 2dup 0 scan nip - ;M :M Create: ( -- f ) LOGFONT Call CreateFontIndirect SetHandle: super Valid?: super ;M : Choose ( hWnd -- f ) to hwndOwner &CHOOSEFONT call ChooseFont if Create: self else false then ; \ let the user choose a Screen font :M Choose: ( hWnd -- f ) [ CF_SCREENFONTS CF_INITTOLOGFONTSTRUCT or ] literal to Flags Choose ;M \ let the user choose a Printer font for the PrinterDC hDC :M ChoosePrinter: ( hWnd hDC -- f ) GetGdiObjectHandle to hDC [ CF_PRINTERFONTS CF_INITTOLOGFONTSTRUCT or ] literal to Flags Choose ;M ;Class module |
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X