cleanups; win32 fpimage support

git-svn-id: trunk@4790 -

lcl/include/interfacebase.inc

@@ -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
 

lcl/include/winapi.inc

@@ -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
 

lcl/include/winapih.inc

@@ -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
 

lcl/interfaces/gtk/gtkint.pp

@@ -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
 

lcl/interfaces/gtk/gtkwinapih.inc

@@ -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
 

lcl/interfaces/win32/win32int.pp

@@ -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
 

lcl/interfaces/win32/win32winapi.inc

@@ -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
 

lcl/interfaces/win32/win32winapih.inc

@@ -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
 

lcl/menus.pp

@@ -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