paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-08 11:58:12 +02:00
Code Issues Packages Projects Releases Wiki Activity

cleanups; win32 fpimage support

Browse Source 
git-svn-id: trunk@4790 -
This commit is contained in:
micha 2003-11-10 16:15:32 +00:00
parent 27e1973d80
commit c8af4ddcf3
10 changed files with 473 additions and 252 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
lcl/include/interfacebase.inc
View File

@ -982,7 +982,7 @@ begin
Result:=false;
end;
function TInterfaceBase.GetRawImageFromBitmap(SrcBitmap, SrcMaskBitmap: HDC;
function TInterfaceBase.GetRawImageFromBitmap(SrcBitmap, SrcMaskBitmap: HBITMAP;
const SrcRect: TRect; var NewRawImage: TRawImage): boolean;
begin
Result:=false;
@ -1848,6 +1848,9 @@ end;
{ =============================================================================
$Log$
Revision 1.110 2003/11/10 16:15:31 micha
cleanups; win32 fpimage support
Revision 1.109 2003/11/07 22:50:44 mattias
fixed finding sysutilh.inc

7
lcl/include/winapi.inc
View File

@ -531,7 +531,7 @@ begin
Result := InterfaceObject.GetRawImageFromDevice(SrcDC,SrcRect,NewRawImage);
end;
function GetRawImageFromBitmap(SrcBitmap, SrcMaskBitmap: HDC;
function GetRawImageFromBitmap(SrcBitmap, SrcMaskBitmap: HBITMAP;
const SrcRect: TRect; var NewRawImage: TRawImage): boolean;
begin
Result := InterfaceObject.GetRawImageFromBitmap(SrcBitmap,SrcMaskBitmap,
@ -1261,7 +1261,7 @@ end;
------------------------------------------------------------------------------}
function CreateFont(Height, Width, Escapement, Orientation, Weight: Integer;
Italic, Underline, StrikeOut, CharSet, OutputPrecision, ClipPrecision,
Quality, PitchAndFamily: Cardinal; FaceName: PChar): HFONT;
Quality, PitchAndFamily: Byte; FaceName: PChar): HFONT;
var
LogFont: TLogFont;
begin
@ -1692,6 +1692,9 @@ end;
{ =============================================================================
$Log$
Revision 1.102 2003/11/10 16:15:31 micha
cleanups; win32 fpimage support
Revision 1.101 2003/11/07 18:48:52 micha
symmetry getdesignerdc, releasedesignerdc

7
lcl/include/winapih.inc
View File

@ -149,7 +149,7 @@ function GetPaletteEntries(Palette: HPALETTE; StartIndex, NumEntries: UINT;
Function GetParent(Handle : HWND): HWND; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
Function GetProp(Handle : hwnd; Str : PChar): Pointer;{$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function GetRawImageFromDevice(SrcDC: HDC; const SrcRect: TRect; var NewRawImage: TRawImage): boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function GetRawImageFromBitmap(SrcBitmap, SrcMaskBitmap: HDC; const SrcRect: TRect; var NewRawImage: TRawImage): boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function GetRawImageFromBitmap(SrcBitmap, SrcMaskBitmap: HBITMAP; const SrcRect: TRect; var NewRawImage: TRawImage): boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
Function GetRgnBox(RGN : HRGN; lpRect : PRect) : Longint; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function GetScrollBarSize(Handle: HWND; SBStyle: Integer): integer; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
function GetScrollbarVisible(Handle: HWND; SBStyle: Integer): boolean; {$IFDEF IF_BASE_MEMBER}virtual;{$ENDIF}
@ -347,7 +347,7 @@ function CopyRect(var DestRect: TRect; const SrcRect: TRect): Boolean;
function CreateEllipticRgnIndirect(const ARect: TRect): HRGN;
function CreateFont(Height, Width, Escapement, Orientation, Weight: Integer;
Italic, Underline, StrikeOut, CharSet, OutputPrecision, ClipPrecision,
Quality, PitchAndFamily: Cardinal; FaceName: PChar): HFONT;
Quality, PitchAndFamily: Byte; FaceName: PChar): HFONT;
function CreatePen(Style, Width: Integer; Color: TColorRef): HPEN;
function CreateRectRgnIndirect(const ARect: TRect): HRGN;
@ -400,6 +400,9 @@ procedure RaiseLastOSError;
{ =============================================================================
$Log$
Revision 1.92 2003/11/10 16:15:32 micha
cleanups; win32 fpimage support
Revision 1.91 2003/11/07 18:48:52 micha
symmetry getdesignerdc, releasedesignerdc

49
lcl/interfaces/gtk/gtkint.pp
View File

@ -1,13 +1,13 @@
{
/***************************************************************************
{
/***************************************************************************
GTKINT.pp - GTKInterface Object
-------------------
Initial Revision : Thu July 1st CST 1999
***************************************************************************/
-------------------
Initial Revision : Thu July 1st CST 1999
***************************************************************************/
*****************************************************************************
* *
* This file is part of the Lazarus Component Library (LCL) *
@ -21,10 +21,10 @@
* *
*****************************************************************************
}
unit GtkInt;
{$mode objfpc}
{$mode objfpc}
{$LONGSTRINGS ON}
interface
@ -103,11 +103,11 @@ type
FStockGrayBrush: HBRUSH;
FStockDkGrayBrush: HBRUSH;
FStockWhiteBrush: HBRUSH;
FStockNullPen: HPEN;
FStockBlackPen: HPEN;
FStockWhitePen: HPEN;
{$Ifdef GTK2}
FDefaultFontDesc : PPangoFontDescription;
{$Else}
@ -120,7 +120,7 @@ type
procedure InitStockItems; virtual;
procedure FreeStockItems; virtual;
procedure PassCmdLineOptions; override;
// styles
procedure FreeAllStyles; virtual;
Function GetCompStyle(Sender : TObject) : Longint; Virtual;
@ -146,14 +146,14 @@ type
// clipboard
procedure SetClipboardWidget(TargetWidget: PGtkWidget);virtual;
// device contexts
function IsValidDC(const DC: HDC): Boolean;virtual;
function NewDC: TDeviceContext;virtual;
procedure DisposeDC(aDC: TDeviceContext);virtual;
function CreateDCForWidget(TheWidget: PGtkWidget; TheWindow: PGdkWindow;
WithChildWindows: boolean): HDC;
// GDIObjects
function IsValidGDIObject(const GDIObject: HGDIOBJ): Boolean;virtual;
function IsValidGDIObjectType(const GDIObject: HGDIOBJ;
@ -215,7 +215,7 @@ type
// listview
procedure ListViewChangeItem(TheListView: TObject; Index: integer);
procedure ListViewAddItem(TheListView: TObject);
// listbox
function GetTopIndex(Sender: TObject): integer;virtual;
function SetTopIndex(Sender: TObject; NewTopIndex: integer): integer;virtual;
@ -279,7 +279,7 @@ type
Procedure FinishComponentCreate(Sender : TObject; Handle : Pointer;
SetupProps : Boolean); Virtual;
public
constructor Create;
constructor Create;
destructor Destroy; override;
function IntSendMessage3(LM_Message : Integer; Sender : TObject;
data : pointer) : integer; override;
@ -293,7 +293,7 @@ type
function DestroyTimer(TimerHandle: integer) : boolean; override;
{$I gtkwinapih.inc}
public
property RCFilename: string read FRCFilename write SetRCFilename;
end;
@ -321,7 +321,7 @@ begin
MouseCaptureWidget := nil;
MouseCapureByLCL := false;
LastLeft:=EmptyLastMouseClick;
LastMiddle:=EmptyLastMouseClick;
LastRight:=EmptyLastMouseClick;
@ -335,7 +335,7 @@ begin
ClipboardTargetEntries[c]:=nil;
ClipboardTargetEntryCnt[c]:=0;
end;
// mouse cursors
for cr:=Low(GDKMouseCursors) to High(GDKMouseCursors) do begin
GDKMouseCursors[cr]:=nil;
@ -379,7 +379,7 @@ begin
if ced^.Data.Data<>nil then FreeMem(ced^.Data.Data);
Dispose(ced);
end;
for c:=Low(TClipboardType) to High(TClipboardType) do
for c:=Low(TClipboardType) to High(TClipboardType) do
FreeClipboardTargetEntries(c);
ClipboardSelectionData.Free;
ClipboardSelectionData:=nil;
@ -399,6 +399,9 @@ end.
{ =============================================================================
$Log$
Revision 1.156 2003/11/10 16:15:32 micha
cleanups; win32 fpimage support
Revision 1.155 2003/11/03 22:37:41 mattias
fixed vert scrollbar, implemented GetDesignerDC

447
lcl/interfaces/gtk/gtkwinapi.inc
View File

File diff suppressed because it is too large Load Diff

5
lcl/interfaces/gtk/gtkwinapih.inc
View File

@ -112,7 +112,7 @@ function GetObject(GDIObj: HGDIOBJ; BufSize: Integer; Buf: Pointer): Integer; ov
Function GetParent(Handle : HWND): HWND; override;
Function GetProp(Handle : hwnd; Str : PChar): Pointer; override;
function GetRawImageFromDevice(SrcDC: HDC; const SrcRect: TRect; var NewRawImage: TRawImage): boolean; override;
function GetRawImageFromBitmap(SrcBitmap, SrcMaskBitmap: HDC; const SrcRect: TRect; var NewRawImage: TRawImage): boolean; override;
function GetRawImageFromBitmap(SrcBitmap, SrcMaskBitmap: HBITMAP; const SrcRect: TRect; var NewRawImage: TRawImage): boolean; override;
Function GetRgnBox(RGN : HRGN; lpRect : PRect) : Longint; override;
function GetScrollBarSize(Handle: HWND; BarKind: Integer): integer; override;
function GetScrollbarVisible(Handle: HWND; SBStyle: Integer): boolean; override;
@ -215,6 +215,9 @@ Function WindowFromPoint(Point : TPoint) : HWND; override;
{ =============================================================================
$Log$
Revision 1.80 2003/11/10 16:15:32 micha
cleanups; win32 fpimage support
Revision 1.79 2003/11/03 22:37:41 mattias
fixed vert scrollbar, implemented GetDesignerDC

7
lcl/interfaces/win32/win32int.pp
View File

@ -91,6 +91,10 @@ Type
Function SetProperties(Sender: TObject): Integer;
Procedure AttachMenu(Sender: TObject);
Procedure AllocAndCopy(const BitmapInfo: Windows.TBitmap; const SrcRect: TRect; var Data: PByte; var Size: Cardinal);
procedure FillRawImageDescription(const BitmapInfo: Windows.TBitmap;
Desc: PRawImageDescription);
Function WinRegister: Boolean;
Function ToolBtnWinRegister: Boolean;
Procedure SetOwner(Window: HWND; Owner: TObject);
@ -181,6 +185,9 @@ End.
{ =============================================================================
$Log$
Revision 1.50 2003/11/10 16:15:32 micha
cleanups; win32 fpimage support
Revision 1.49 2003/11/08 17:41:03 micha
compiler warning cleanups

184
lcl/interfaces/win32/win32winapi.inc
View File

@ -1324,6 +1324,187 @@ begin
Result := Windows.GetBitmapBits(Bitmap, Count, Bits);
end;
procedure TWin32Object.FillRawImageDescription(const BitmapInfo: Windows.TBitmap;
Desc: PRawImageDescription);
begin
Desc^.Format := ricfRGBA;
Desc^.HasPalette := BitmapInfo.bmBitsPixel <= 8; // if true, each pixel is an index in the palette
Desc^.Depth := BitmapInfo.bmBitsPixel; // used bits per pixel
Desc^.Width := BitmapInfo.bmWidth;
Desc^.Height := BitmapInfo.bmHeight;
Desc^.PaletteColorCount := 0; // TODO, also `ColorCount'
Desc^.ByteOrder := riboLSBFirst;
Desc^.LineOrder := riloTopToBottom;
Desc^.ColorCount := 0; // entries in color palette. Ignore when no palette.
Desc^.BitsPerPixel := Desc^.Depth; // bits per pixel. can be greater than Depth.
Desc^.LineEnd := rileWordBoundary;
Desc^.RedPrec := 8; // red precision. bits for red
Desc^.GreenPrec := 8;
Desc^.BluePrec := 8;
Desc^.AlphaPrec := 8;
Desc^.RedShift := 24;
Desc^.GreenShift := 16; // bitshift. Direction: from least to most signifikant
Desc^.BlueShift := 8;
Desc^.AlphaShift := 0;
Desc^.AlphaSeparate := false; // the alpha is stored as separate Mask
// The next values are only valid, if there is a separate alpha mask
Desc^.AlphaBitsPerPixel := 8; // bits per alpha mask pixel.
Desc^.AlphaLineEnd := rileWordBoundary;
end;
function TWin32Object.GetBitmapRawImageDescription(Bitmap: HBITMAP;
Desc: PRawImageDescription): Boolean;
var
BitmapInfo: Windows.TBitmap;
begin
Result := Windows.GetObject(Bitmap, SizeOf(BitmapInfo), @BitmapInfo) > 0;
if Result then
FillRawImageDescription(BitmapInfo, Desc);
end;
function TWin32Object.GetDeviceRawImageDescription(DC: HDC; Desc: PRawImageDescription): boolean;
begin
Result := true;
FillChar(Desc^, SizeOf(Desc^), 0);
Desc^.Format := ricfRGBA;
Desc^.HasPalette := (Windows.GetDeviceCaps(DC, RASTERCAPS) and RC_PALETTE) <> 0;
Desc^.Depth := Windows.GetDeviceCaps(DC, BITSPIXEL);
// Width and Height not relevant
Desc^.PaletteColorCount := Windows.GetDeviceCaps(DC, SIZEPALETTE);
Desc^.ByteOrder := riboLSBFirst;
Desc^.LineOrder := riloTopToBottom;
Desc^.ColorCount := Desc^.PaletteColorCount;
if Desc^.HasPalette then
Desc^.BitsPerPixel := Windows.GetDeviceCaps(DC, COLORRES)
else
Desc^.BitsPerPixel := Desc^.Depth;
Desc^.LineEnd := rileWordBoundary;
Desc^.RedPrec := 8; // red precision. bits for red
Desc^.GreenPrec := 8;
Desc^.BluePrec := 8;
Desc^.AlphaPrec := 8;
Desc^.RedShift := 24;
Desc^.GreenShift := 16; // bitshift. Direction: from least to most signifikant
Desc^.BlueShift := 8;
Desc^.AlphaShift := 0;
Desc^.AlphaSeparate := false; // the alpha is stored as separate Mask
// The next values are only valid, if there is a separate alpha mask
Desc^.AlphaBitsPerPixel := 8; // bits per alpha mask pixel.
Desc^.AlphaLineEnd := rileWordBoundary;
end;
function TWin32Object.GetRawImageFromDevice(SrcDC: HDC; const SrcRect: TRect; var NewRawImage: TRawImage): boolean;
var
SrcWidth, SrcHeight: Integer;
hMemDC: HDC;
hMemBitmap: HBITMAP;
hOldObject: HGDIOBJ;
begin
FillChar(NewRawImage, SizeOf(NewRawImage), 0);
// make bitmap compatible to src device
SrcWidth := SrcRect.Right - SrcRect.Left;
SrcHeight := SrcRect.Bottom - SrcRect.Top;
hMemBitmap := Windows.CreateCompatibleBitmap(SrcDC, SrcWidth, SrcHeight);
Result := hMemBitmap <> 0;
if not Result then exit;
// make memory device context compatible to device, to select bitmap in for copying
hMemDC := Windows.CreateCompatibleDC(SrcDC);
Result := hMemDC <> 0;
hOldObject := Windows.SelectObject(hMemDC, hMemBitmap);
// copy srcdc -> membitmap
Result := Result and Windows.BitBlt(hMemDC, 0, 0, SrcWidth, SrcHeight,
SrcDC, SrcRect.Left, SrcRect.Top, SRCCOPY);
// done copying, deselect bitmap from dc
Windows.SelectObject(hMemDC, hOldObject);
// copy membitmap -> rawimage
Result := Result and GetRawImageFromBitmap(hMemBitmap, 0,
Rect(0, 0, SrcWidth, SrcHeight), NewRawImage);
// free temporary stuff
Windows.DeleteDC(hMemDC);
Windows.DeleteObject(hMemBitmap);
end;
procedure TWin32Object.AllocAndCopy(const BitmapInfo: Windows.TBitmap; const SrcRect: TRect; var Data: PByte; var Size: Cardinal);
var
SrcLine, DestLine: PByte;
LineLen: Cardinal;
I: Integer;
begin
// allocate memory for pixel data, N scanlines
Size := (SrcRect.Bottom-SrcRect.Top)*BitmapInfo.bmWidthBytes;
GetMem(Data, Size);
// copy lines
SrcLine := BitmapInfo.bmBits + SrcRect.Top*BitmapInfo.bmWidthBytes + SrcRect.Left*BitmapInfo.bmBitsPixel;
DestLine := Data;
LineLen := (SrcRect.Right-SrcRect.Left)*BitmapInfo.bmBitsPixel;
for I := SrcRect.Top to SrcRect.Bottom - 1 do
begin
Move(SrcLine^, DestLine^, LineLen);
Inc(SrcLine, BitmapInfo.bmWidthBytes);
Inc(DestLine, LineLen);
end;
end;
function TWin32Object.GetRawImageFromBitmap(SrcBitmap, SrcMaskBitmap: HBITMAP; const SrcRect: TRect; var NewRawImage: TRawImage): boolean;
var
BitmapInfo: Windows.TBitmap;
ARect: TRect;
begin
FillChar(NewRawImage, SizeOf(NewRawImage), 0);
Result := Windows.GetObject(SrcBitmap, SizeOf(BitmapInfo), @BitmapInfo) > 0;
if not Result then exit;
FillRawImageDescription(BitmapInfo, @NewRawImage.Description);
ARect := SrcRect;
if ARect.Top > BitmapInfo.bmHeight then
ARect.Top := BitmapInfo.bmHeight;
if ARect.Bottom > BitmapInfo.bmHeight then
ARect.Bottom := BitmapInfo.bmHeight;
if ARect.Left > BitmapInfo.bmWidth then
ARect.Left := BitmapInfo.bmWidth;
if ARect.Right > BitmapInfo.bmWidth then
ARect.Right := BitmapInfo.bmWidth;
// copy bitmap
AllocAndCopy(BitmapInfo, ARect, NewRawImage.Data, NewRawImage.MaskSize);
// check mask
if SrcMaskBitmap <> 0 then
begin
Result := Windows.GetObject(SrcMaskBitmap, SizeOf(BitmapInfo), @BitmapInfo) > 0;
if not Result then exit;
AllocAndCopy(BitmapInfo, ARect, NewRawImage.Mask, NewRawImage.MaskSize);
NewRawImage.Description.AlphaSeparate := true;
end;
end;
function TWin32Object.CreateBitmapFromRawImage(const RawImage: TRawImage; var Bitmap, MaskBitmap: HBitmap): boolean;
begin
Bitmap := Windows.CreateBitmap(
RawImage.Description.Width, RawImage.Description.Height,
1, RawImage.Description.Depth,
RawImage.Data);
Result := Bitmap <> 0;
if not Result then exit;
if RawImage.Description.AlphaSeparate then
begin
MaskBitmap := Windows.CreateBitmap(
RawImage.Description.Width, RawImage.Description.Height,
1, RawImage.Description.AlphaBitsPerPixel,
RawImage.Mask);
Result := Result and (MaskBitmap <> 0);
end;
end;
function TWin32Object.CreateDIBSection(DC: HDC; const p2: tagBitmapInfo; p3: UINT;
var p4: Pointer; p5: THandle; p6: DWORD): HBITMAP;
begin
@ -2533,6 +2714,9 @@ end;
{ =============================================================================
$Log$
Revision 1.71 2003/11/10 16:15:32 micha
cleanups; win32 fpimage support
Revision 1.70 2003/11/09 10:35:19 mattias
started Menu icons for win32 intf from Martin Smat

9
lcl/interfaces/win32/win32winapih.inc
View File

@ -79,6 +79,12 @@ Function FillRect(DC: HDC; Const Rect: TRect; Brush: HBRUSH): Boolean; Override;
{ Draws a 3D border in GTK native style. }
Function Frame3D(DC: HDC; Var Rect: TRect; Const FrameWidth: Integer; Const Style: TBevelCut): Boolean; Override;
function GetBitmapRawImageDescription(Bitmap: HBITMAP; Desc: PRawImageDescription): Boolean; Override;
function GetDeviceRawImageDescription(DC: HDC; Desc: PRawImageDescription): boolean; Override;
function GetRawImageFromDevice(SrcDC: HDC; const SrcRect: TRect; var NewRawImage: TRawImage): boolean; Override;
function GetRawImageFromBitmap(SrcBitmap, SrcMaskBitmap: HBITMAP; const SrcRect: TRect; var NewRawImage: TRawImage): boolean; Override;
function CreateBitmapFromRawImage(const RawImage: TRawImage; var Bitmap, MaskBitmap: HBitmap): boolean; Override;
Function GetActiveWindow: HWND; Override;
Function GetCapture: HWND; Override;
Function GetCaretPos(Var LPPoint: TPoint): Boolean; Override;
@ -182,6 +188,9 @@ Procedure DeleteCriticalSection(var CritSection: TCriticalSection); Override;
{ =============================================================================
$Log$
Revision 1.38 2003/11/10 16:15:32 micha
cleanups; win32 fpimage support
Revision 1.37 2003/11/07 18:48:52 micha
symmetry getdesignerdc, releasedesignerdc

5
lcl/menus.pp
View File

@ -322,7 +322,7 @@ uses
var
CommandPool: TBits;
function UniqueCommand: Word;
function UniqueCommand: LongInt;
begin
if CommandPool=nil then
CommandPool:=TBits.Create(32);
@ -388,6 +388,9 @@ end.
{
$Log$
Revision 1.54 2003/11/10 16:15:31 micha
cleanups; win32 fpimage support
Revision 1.53 2003/10/26 17:34:41 micha
new interface method to attach a menu to window