initial implementation of TWinControl.SetShape for gtk, qt, win32 + example

git-svn-id: trunk@13874 -
2025-04-06 22:18:15 +02:00 · 2008-01-25 06:56:57 +00:00 · 2008-01-25 06:56:57 +00:00 · f1d8f78b0c
commit f1d8f78b0c
parent 737152c95a
19 changed files with 628 additions and 7 deletions
--- a/.gitattributes
+++ b/.gitattributes
@ -1780,6 +1780,12 @@ examples/scrollbar.lpi svneol=native#text/plain
 examples/scrollbar.pp svneol=native#text/pascal
 examples/selection.pp svneol=native#text/pascal
 examples/selectionform.pp svneol=native#text/pascal
+examples/shapedcontrols/manifest.rc svneol=native#text/plain
+examples/shapedcontrols/project1.lpi svneol=native#text/plain
+examples/shapedcontrols/project1.lpr -text svneol=native#test/pascal
+examples/shapedcontrols/unit1.lfm svneol=native#text/plain
+examples/shapedcontrols/unit1.lrs -text svneol=native#test/pascal
+examples/shapedcontrols/unit1.pas -text svneol=native#test/pascal
 examples/speedtest.lpi svneol=native#text/plain
 examples/speedtest.pp svneol=native#text/pascal
 examples/sprites/playground.lfm svneol=native#text/plain
--- a/examples/shapedcontrols/manifest.rc
+++ b/examples/shapedcontrols/manifest.rc
@ -0,0 +1,25 @@
+#define RT_MANIFEST  24
+#define CREATEPROCESS_MANIFEST_RESOURCE_ID 1
+#define ISOLATIONAWARE_MANIFEST_RESOURCE_ID 2
+#define ISOLATIONAWARE_NOSTATICIMPORT_MANIFEST_RESOURCE_ID 3
+
+CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST MOVEABLE PURE
+{
+ "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>"
+ "<assembly xmlns=""urn:schemas-microsoft-com:asm.v1"" manifestVersion=""1.0"">"
+ "<assemblyIdentity version=""1.0.0.0"" processorArchitecture=""*"" name=""CompanyName.ProductName.YourApp"" type=""win32""/>"
+ "<description>Your application description here.</description>"
+ "<dependency>"
+ "<dependentAssembly>"
+ "<assemblyIdentity type=""win32"" name=""Microsoft.Windows.Common-Controls"" version=""6.0.0.0"" processorArchitecture=""*"" publicKeyToken=""6595b64144ccf1df"" language=""*""/>"
+ "</dependentAssembly>"
+ "</dependency>"
+ "<trustInfo xmlns=""urn:schemas-microsoft-com:asm.v3"">"
+ "<security>"
+ "<requestedPrivileges>"
+ "<requestedExecutionLevel level=""asInvoker"" uiAccess=""false""/>"
+ "</requestedPrivileges>"
+ "</security>"
+ "</trustInfo>"
+ "</assembly>"
+}
--- a/examples/shapedcontrols/project1.lpi
+++ b/examples/shapedcontrols/project1.lpi
@ -0,0 +1,160 @@
+<?xml version="1.0"?>
+<CONFIG>
+  <ProjectOptions>
+    <PathDelim Value="\"/>
+    <Version Value="6"/>
+    <General>
+      <MainUnit Value="0"/>
+      <TargetFileExt Value=".exe"/>
+      <UseXPManifest Value="True"/>
+      <ActiveEditorIndexAtStart Value="1"/>
+    </General>
+    <VersionInfo>
+      <ProjectVersion Value=""/>
+    </VersionInfo>
+    <PublishOptions>
+      <Version Value="2"/>
+      <IgnoreBinaries Value="False"/>
+      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+      <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+        <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+      </local>
+    </RunParams>
+    <RequiredPackages Count="1">
+      <Item1>
+        <PackageName Value="LCL"/>
+      </Item1>
+    </RequiredPackages>
+    <Units Count="3">
+      <Unit0>
+        <Filename Value="project1.lpr"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="project1"/>
+        <CursorPos X="21" Y="12"/>
+        <TopLine Value="1"/>
+        <EditorIndex Value="1"/>
+        <UsageCount Value="20"/>
+        <Loaded Value="True"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="unit1.pas"/>
+        <ComponentName Value="Form1"/>
+        <IsPartOfProject Value="True"/>
+        <ResourceFilename Value="unit1.lrs"/>
+        <UnitName Value="Unit1"/>
+        <CursorPos X="38" Y="54"/>
+        <TopLine Value="34"/>
+        <EditorIndex Value="0"/>
+        <UsageCount Value="20"/>
+        <Loaded Value="True"/>
+      </Unit1>
+      <Unit2>
+        <Filename Value="..\..\lcl\include\wincontrol.inc"/>
+        <CursorPos X="70" Y="4369"/>
+        <TopLine Value="4363"/>
+        <UsageCount Value="10"/>
+      </Unit2>
+    </Units>
+    <JumpHistory Count="17" HistoryIndex="16">
+      <Position1>
+        <Filename Value="unit1.pas"/>
+        <Caret Line="24" Column="16" TopLine="1"/>
+      </Position1>
+      <Position2>
+        <Filename Value="unit1.pas"/>
+        <Caret Line="16" Column="45" TopLine="1"/>
+      </Position2>
+      <Position3>
+        <Filename Value="unit1.pas"/>
+        <Caret Line="38" Column="5" TopLine="4"/>
+      </Position3>
+      <Position4>
+        <Filename Value="unit1.pas"/>
+        <Caret Line="17" Column="43" TopLine="9"/>
+      </Position4>
+      <Position5>
+        <Filename Value="unit1.pas"/>
+        <Caret Line="38" Column="1" TopLine="20"/>
+      </Position5>
+      <Position6>
+        <Filename Value="unit1.pas"/>
+        <Caret Line="45" Column="1" TopLine="27"/>
+      </Position6>
+      <Position7>
+        <Filename Value="unit1.pas"/>
+        <Caret Line="46" Column="1" TopLine="28"/>
+      </Position7>
+      <Position8>
+        <Filename Value="unit1.pas"/>
+        <Caret Line="47" Column="1" TopLine="28"/>
+      </Position8>
+      <Position9>
+        <Filename Value="unit1.pas"/>
+        <Caret Line="48" Column="1" TopLine="28"/>
+      </Position9>
+      <Position10>
+        <Filename Value="unit1.pas"/>
+        <Caret Line="50" Column="1" TopLine="28"/>
+      </Position10>
+      <Position11>
+        <Filename Value="unit1.pas"/>
+        <Caret Line="51" Column="1" TopLine="28"/>
+      </Position11>
+      <Position12>
+        <Filename Value="unit1.pas"/>
+        <Caret Line="52" Column="1" TopLine="28"/>
+      </Position12>
+      <Position13>
+        <Filename Value="unit1.pas"/>
+        <Caret Line="53" Column="1" TopLine="28"/>
+      </Position13>
+      <Position14>
+        <Filename Value="unit1.pas"/>
+        <Caret Line="55" Column="1" TopLine="28"/>
+      </Position14>
+      <Position15>
+        <Filename Value="unit1.pas"/>
+        <Caret Line="54" Column="13" TopLine="28"/>
+      </Position15>
+      <Position16>
+        <Filename Value="unit1.pas"/>
+        <Caret Line="17" Column="20" TopLine="8"/>
+      </Position16>
+      <Position17>
+        <Filename Value="unit1.pas"/>
+        <Caret Line="41" Column="40" TopLine="28"/>
+      </Position17>
+    </JumpHistory>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="5"/>
+    <PathDelim Value="\"/>
+    <CodeGeneration>
+      <Generate Value="Faster"/>
+    </CodeGeneration>
+    <Linking>
+      <Options>
+        <Win32>
+          <GraphicApplication Value="True"/>
+        </Win32>
+      </Options>
+    </Linking>
+    <Other>
+      <CompilerPath Value="$(CompPath)"/>
+    </Other>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="2">
+      <Item1>
+        <Name Value="ECodetoolError"/>
+      </Item1>
+      <Item2>
+        <Name Value="EFOpenError"/>
+      </Item2>
+    </Exceptions>
+  </Debugging>
+</CONFIG>
--- a/examples/shapedcontrols/project1.lpr
+++ b/examples/shapedcontrols/project1.lpr
@ -0,0 +1,20 @@
+program project1;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  Interfaces, // this includes the LCL widgetset
+  Forms
+  { you can add units after this }, Unit1;
+
+{$IFDEF WINDOWS}{$R manifest.rc}{$ENDIF}
+
+begin
+  Application.Initialize;
+  Application.CreateForm(TForm1, Form1);
+  Application.Run;
+end.
+
--- a/examples/shapedcontrols/unit1.lfm
+++ b/examples/shapedcontrols/unit1.lfm
@ -0,0 +1,23 @@
+object Form1: TForm1
+  Left = 460
+  Height = 146
+  Top = 327
+  Width = 300
+  HorzScrollBar.Page = 299
+  VertScrollBar.Page = 145
+  BorderIcons = [biSystemMenu, biMinimize]
+  BorderStyle = bsSingle
+  Caption = 'Form1'
+  ClientHeight = 146
+  ClientWidth = 300
+  OnCreate = FormCreate
+  object Button1: TButton
+    Left = 24
+    Height = 57
+    Top = 40
+    Width = 248
+    Caption = 'Shaped button. Press to make window shaped.'
+    OnClick = Button1Click
+    TabOrder = 0
+  end
+end
--- a/examples/shapedcontrols/unit1.lrs
+++ b/examples/shapedcontrols/unit1.lrs
@ -0,0 +1,11 @@
+{ Ýòî - ôàéë ðåñóðñîâ, àâòîìàòè÷åñêè ñîçäàííûé lazarus }
+
+LazarusResources.Add('TForm1','FORMDATA',[
+  'TPF0'#6'TForm1'#5'Form1'#4'Left'#3#204#1#6'Height'#3#146#0#3'Top'#3'G'#1#5'W'
+  +'idth'#3','#1#18'HorzScrollBar.Page'#3'+'#1#18'VertScrollBar.Page'#3#145#0#11
+  +'BorderIcons'#11#12'biSystemMenu'#10'biMinimize'#0#11'BorderStyle'#7#8'bsSin'
+  +'gle'#7'Caption'#6#5'Form1'#12'ClientHeight'#3#146#0#11'ClientWidth'#3','#1#8
+  +'OnCreate'#7#10'FormCreate'#0#7'TButton'#7'Button1'#4'Left'#2#24#6'Height'#2
+  +'9'#3'Top'#2'('#5'Width'#3#248#0#7'Caption'#6'+Shaped button. Press to make '
+  +'window shaped.'#7'OnClick'#7#12'Button1Click'#8'TabOrder'#2#0#0#0#0
+]);
--- a/examples/shapedcontrols/unit1.pas
+++ b/examples/shapedcontrols/unit1.pas
@ -0,0 +1,74 @@
+unit Unit1; 
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls,
+  ExtCtrls;
+
+type
+
+  { TForm1 }
+
+  TForm1 = class(TForm)
+    Button1: TButton;
+    procedure Button1Click(Sender: TObject);
+    procedure FormCreate(Sender: TObject);
+  private
+    { private declarations }
+  public
+    procedure ShapeControl(AControl: TWinControl);
+  end; 
+
+var
+  Form1: TForm1; 
+
+implementation
+
+{ TForm1 }
+
+procedure TForm1.Button1Click(Sender: TObject);
+begin
+  ShapeControl(Self);
+end;
+
+procedure TForm1.FormCreate(Sender: TObject);
+begin
+  Button1.Handle;
+  ShapeControl(Button1);
+end;
+
+procedure TForm1.ShapeControl(AControl: TWinControl);
+var
+  ABitmap: TBitmap;
+  Points: array of TPoint;
+begin
+  ABitmap := TBitmap.Create;
+  ABitmap.Monochrome := True;
+  ABitmap.Width := AControl.Width;
+  ABitmap.Height := AControl.Height;
+  SetLength(Points, 6);
+  Points[0] := Point(0, ABitmap.Height div 2);
+  Points[1] := Point(10, 0);
+  Points[2] := Point(ABitmap.Width - 10, 0);
+  Points[3] := Point(ABitmap.Width, ABitmap.Height div 2);
+  Points[4] := Point(ABitmap.Width - 10, ABitmap.Height);
+  Points[5] := Point(10, ABitmap.Height);
+  with ABitmap.Canvas do
+  begin
+    Brush.Color := clBlack; // transparent color
+    FillRect(0, 0, ABitmap.Width, ABitmap.Height);
+    Brush.Color := clWhite; // mask color
+    Polygon(Points);
+  end;
+  AControl.SetShape(ABitmap);
+  ABitmap.Free;
+end;
+
+initialization
+  {$I unit1.lrs}
+
+end.
+
--- a/lcl/controls.pp
+++ b/lcl/controls.pp
@ -1793,6 +1793,7 @@ type
                              RepeatCount: integer; SystemKey: boolean): boolean; dynamic;
    procedure PaintTo(DC: HDC; X, Y: Integer); virtual; overload;
    procedure PaintTo(ACanvas: TCanvas; X, Y: Integer); overload;
+    procedure SetShape(AShape: TBitmap);
  end;


--- a/lcl/include/wincontrol.inc
+++ b/lcl/include/wincontrol.inc
@ -4368,6 +4368,18 @@ begin
  PaintTo(ACanvas.Handle, X, Y);
 end;

+procedure TWinControl.SetShape(AShape: TBitmap);
+begin
+  if not HandleAllocated then
+    Exit;
+
+  if (AShape <> nil) and (AShape.Width = Width) and (AShape.Height = Height) then
+    TWSWinControlClass(WidgetSetClass).SetShape(Self, AShape.Handle)
+  else
+  if AShape = nil then
+    TWSWinControlClass(WidgetSetClass).SetShape(Self, 0)
+end;
+
 {------------------------------------------------------------------------------
  TWinControl ControlAtPos
  Params: const Pos : TPoint
--- a/lcl/interfaces/gtk/gtkwscontrols.pp
+++ b/lcl/interfaces/gtk/gtkwscontrols.pp
@ -94,6 +94,7 @@ type
    class procedure SetSize(const AWinControl: TWinControl; const AWidth, AHeight: Integer); override;
    class procedure SetPos(const AWinControl: TWinControl; const ALeft, ATop: Integer); override;
    class procedure SetText(const AWinControl: TWinControl; const AText: string); override;
+    class procedure SetShape(const AWinControl: TWinControl; const AShape: HBITMAP); override;
    class procedure PaintTo(const AWinControl: TWinControl; ADC: HDC; X, Y: Integer); override;

    class procedure ShowHide(const AWinControl: TWinControl); override;
@ -664,6 +665,30 @@ begin
  Assert(False, Format('trace:  [TGtkWidgetSet.SetLabel] %s --> END', [AWinControl.ClassName]));
 end;

+class procedure TGtkWSWinControl.SetShape(const AWinControl: TWinControl;
+  const AShape: HBITMAP);
+var
+  GtkWidget: PGtkWidget;
+  GdkBitmap: PGDKBitmap;
+begin
+  if not WSCheckHandleAllocated(AWinControl, 'SetShape') then
+    Exit;
+
+  GtkWidget := PGtkWidget(AWinControl.Handle);
+
+  if AShape <> 0 then
+  begin
+    if GtkWidgetset.IsValidGDIObjectType(AShape, gdiBitmap) then
+      GdkBitmap := PGdiObject(AShape)^.GDIBitmapObject
+    else
+      GdkBitmap := nil;
+  end
+  else
+    GdkBitmap := nil;
+    
+  gtk_widget_shape_combine_mask(GtkWidget, GdkBitmap, 0, 0);
+end;
+
 {
  Paint control to X, Y point of device context.
 }
--- a/lcl/interfaces/gtk/gtkwsforms.pp
+++ b/lcl/interfaces/gtk/gtkwsforms.pp
@ -35,7 +35,7 @@ uses
  SysUtils, Classes, LCLProc, LCLType, Controls, LMessages, InterfaceBase,
  Graphics, Dialogs,Forms, Math,
  WSDialogs, WSLCLClasses, WSControls, WSForms, WSProc,
-  gtkInt, gtkProc, gtkWSControls, gtkDef, gtkExtra, gtkGlobals, GtkWSPrivate;
+  GtkInt, GtkProc, GtkDef, GtkExtra, GtkGlobals, GtkWSControls, GtkWSPrivate;

 type

--- a/lcl/interfaces/qt/qtobjects.pas
+++ b/lcl/interfaces/qt/qtobjects.pas
@ -113,13 +113,15 @@ type
    constructor Create(Adata: PByte; width: Integer; height: Integer; format: QImageFormat; const ADataOwner: Boolean = False); overload;
    destructor Destroy; override;
    function AsIcon(AMode: QIconMode = QIconNormal; AState: QIconState = QIconOff): QIconH;
-    function AsPixmap: QPixmapH;
+    function AsPixmap(flags: QtImageConversionFlags = QtAutoColor): QPixmapH;
+    function AsBitmap(flags: QtImageConversionFlags = QtAutoColor): QBitmapH;
    procedure CopyFrom(AImage: QImageH; x, y, w, h: integer);
  public
    function height: Integer;
    function width: Integer;
    function bits: PByte;
    function numBytes: Integer;
+    procedure invertPixels(InvertMode: QImageInvertMode = QImageInvertRgb);
  end;

  { TQtFont }
@ -836,10 +838,16 @@ begin
  QPixmap_destroy(APixmap);
 end;

-function TQtImage.AsPixmap: QPixmapH;
+function TQtImage.AsPixmap(flags: QtImageConversionFlags = QtAutoColor): QPixmapH;
 begin
  Result := QPixmap_create();
-  QPixmap_fromImage(Result, Handle);
+  QPixmap_fromImage(Result, Handle, flags);
+end;
+
+function TQtImage.AsBitmap(flags: QtImageConversionFlags = QtAutoColor): QBitmapH;
+begin
+  Result := QBitmap_create();
+  QBitmap_fromImage(Result, Handle, flags);
 end;

 procedure TQtImage.CopyFrom(AImage: QImageH; x, y, w, h: integer);
@ -887,6 +895,11 @@ begin
  Result := QImage_numBytes(Handle);
 end;

+procedure TQtImage.invertPixels(InvertMode: QImageInvertMode = QImageInvertRgb);
+begin
+  QImage_invertPixels(Handle, InvertMode);
+end;
+
 { TQtFont }

 function TQtFont.GetMetrics: TQtFontMetrics;
--- a/lcl/interfaces/qt/qtwidgets.pas
+++ b/lcl/interfaces/qt/qtwidgets.pas
@ -139,6 +139,7 @@ type
  public
    procedure Activate;
    procedure BringToFront;
+    procedure clearMask;
    procedure OffsetMousePos(APoint: PQtPoint); virtual;
    procedure Update(ARect: PRect = nil); virtual;
    procedure Repaint(ARect: PRect = nil); virtual;
@ -179,6 +180,7 @@ type
    procedure setFont(AFont: QFontH);
    procedure setGeometry(ARect: TRect); overload;
    procedure setMaximumSize(AWidth, AHeight: Integer);
+    procedure setMask(AMask: QBitmapH);
    procedure setMinimumSize(AWidth, AHeight: Integer);
    procedure setParent(parent: QWidgetH); virtual;
    procedure setText(const W: WideString); virtual;
@ -2280,6 +2282,11 @@ begin
  raiseWidget;
 end;

+procedure TQtWidget.clearMask;
+begin
+  QWidget_clearMask(Widget);
+end;
+
 procedure TQtWidget.OffsetMousePos(APoint: PQtPoint);
 begin
  with getClientBounds do
@ -2560,6 +2567,11 @@ begin
  QWidget_setMaximumSize(Widget, AWidth, AHeight);
 end;

+procedure TQtWidget.setMask(AMask: QBitmapH);
+begin
+  QWidget_setMask(Widget, AMask);
+end;
+
 procedure TQtWidget.setMinimumSize(AWidth, AHeight: Integer);
 begin
  QWidget_setMinimumSize(Widget, AWidth, AHeight);
--- a/lcl/interfaces/qt/qtwscontrols.pp
+++ b/lcl/interfaces/qt/qtwscontrols.pp
@ -90,6 +90,7 @@ type
    class procedure SetColor(const AWinControl: TWinControl); override;
    class procedure SetCursor(const AWinControl: TWinControl; const ACursor: HCursor); override;
    class procedure SetFont(const AWinControl: TWinControl; const AFont: TFont); override;
+    class procedure SetShape(const AWinControl: TWinControl; const AShape: HBITMAP); override;

    class procedure GetPreferredSize(const AWinControl: TWinControl;
      var PreferredWidth, PreferredHeight: integer; WithThemeSpace: Boolean); override;
@ -562,6 +563,32 @@ begin
  TQtWidget(AWinControl.Handle).SetTextColor(@QColor);
 end;

+class procedure TQtWSWinControl.SetShape(const AWinControl: TWinControl;
+  const AShape: HBITMAP);
+var
+  Widget: TQtWidget;
+  Shape: TQtImage;
+  AMask: QBitmapH;
+begin
+  if not WSCheckHandleAllocated(AWinControl, 'SetShape') then
+    Exit;
+  Widget := TQtWidget(AWinControl.Handle);
+
+  if AShape <> 0 then
+  begin
+    Shape := TQtImage(AShape);
+    // invert white/black
+    Shape.invertPixels;
+    AMask := Shape.AsBitmap;
+    Widget.setMask(AMask);
+    QBitmap_destroy(AMask);
+    // invert back
+    Shape.invertPixels;
+  end
+  else
+    Widget.clearMask;
+end;
+
 class procedure TQtWSWinControl.SetBorderStyle(const AWinControl: TWinControl;
  const ABorderStyle: TBorderStyle);
 var
--- a/lcl/interfaces/qt/qtwsforms.pp
+++ b/lcl/interfaces/qt/qtwsforms.pp
@ -39,7 +39,7 @@ uses
  // LCL
  SysUtils, Classes, Controls, LCLType, Forms,
  // Widgetset
-  InterfaceBase, WSForms, WSLCLClasses;
+  InterfaceBase, WSForms, WSProc, WSLCLClasses;

 type

--- a/lcl/interfaces/win32/win32proc.pp
+++ b/lcl/interfaces/win32/win32proc.pp
@ -28,7 +28,7 @@ interface

 uses
  Windows, Win32Extra, Classes, SysUtils,
-  LMessages, LCLType, LCLProc, Controls, Forms, Menus, GraphType;
+  LMessages, LCLType, LCLProc, Controls, Forms, Menus, GraphType, IntfGraphics;

 Type
  TEventType = (etNotify, etKey, etKeyPress, etMouseWheel, etMouseUpDown);
@ -122,6 +122,7 @@ function GetBitmapBytes(AWinBmp: Windows.TBitmap; ABitmap: HBITMAP; const ARect:

 procedure BlendRect(ADC: HDC; const ARect: TRect; Color: ColorRef);
 function GetLastErrorText(AErrorCode: Cardinal): String;
+function BitmapToRegion(hBmp: HBITMAP; cTransparentColor: COLORREF = 0; cTolerance: COLORREF  = $101010): HRGN;

 type
  PDisableWindowsInfo = ^TDisableWindowsInfo;
@ -1582,6 +1583,193 @@ begin
  then LocalFree(HLOCAL(tmp));
 end;

+(*
+   BitmapToRegion :	Create a region from the "non-transparent" pixels of a bitma
+   Author :		Jean-Edouard Lachand-Robert (http://www.geocities.com/Paris/LeftBank/1160/resume.htm), June 1998
+
+   hBmp :               Source bitmap
+   cTransparentColor :	Color base for the "transparent" pixels (default is black)
+   cTolerance :		Color tolerance for the "transparent" pixels
+
+   A pixel is assumed to be transparent if the value of each of its 3 components (blue, green and red) is
+   greater or equal to the corresponding value in cTransparentColor and is lower or equal to the
+   corresponding value in cTransparentColor + cTolerance
+*)
+
+function BitmapToRegion(hBmp: HBITMAP; cTransparentColor: COLORREF = 0; cTolerance: COLORREF  = $101010): HRGN;
+
+const
+  ALLOC_UNIT = 100;
+
+var
+  AWidth, AHeight: Integer;
+
+  maxRects: DWORD;
+  hData: THANDLE;
+  pData: PRGNDATA;
+  lr, lg, lb, hr, hg, hb: Byte;
+  x, y, x0: Integer;
+  pr: PRect;
+  h: HRGN;
+
+  WinBmp: Windows.TBitmap;
+  P, Data: PRGBAQuad;
+  RS: PtrUInt;
+  ARawImage, DstRawImage: TRawImage;
+  SourceImage, DestImage: TLazIntfImage;
+
+  procedure FillDescription(out ADesc: TRawImageDescription);
+  begin
+    ADesc.Init;
+    ADesc.Format := ricfRGBA;
+    ADesc.PaletteColorCount := 0;
+    ADesc.MaskBitsPerPixel := 0;
+    ADesc.Depth := 32;
+    ADesc.Width := AWidth;
+    ADesc.Height := AHeight;
+    ADesc.BitOrder := riboBitsInOrder;
+    ADesc.ByteOrder := riboMSBFirst;
+    ADesc.LineOrder := riloTopToBottom;
+    ADesc.BitsPerPixel := 32;
+    ADesc.LineEnd := rileDWordBoundary;
+    ADesc.RedPrec := 8; // red precision. bits for red
+    ADesc.RedShift := 8;
+    ADesc.GreenPrec := 8;
+    ADesc.GreenShift := 16;
+    ADesc.BluePrec := 8;
+    ADesc.BlueShift := 24;
+    ADesc.AlphaPrec := 8;
+    ADesc.AlphaShift := 0;
+  end;
+begin
+  Result := 0;
+  
+  if Windows.GetObject(hBmp, sizeof(WinBmp), @WinBmp) = 0 then
+    Exit;
+    
+  AWidth := WinBmp.bmWidth;
+  AHeight := Abs(WinBmp.bmHeight);
+
+  if not RawImage_FromBitmap(ARawImage, hBmp, 0, Rect(0, 0, AWidth, AHeight)) then
+    Exit;
+
+  SourceImage := TLazIntfImage.Create(ARawImage, True);
+
+  DstRawImage.Init;
+  FillDescription(DstRawImage.Description);
+  DstRawImage.DataSize := AWidth * AHeight * SizeOf(TRGBAQuad);
+  Data := AllocMem(DstRawImage.DataSize);
+  DstRawImage.Data := PByte(Data);
+
+  DestImage := TLazIntfImage.Create(DstRawImage, False);
+  DestImage.CopyPixels(SourceImage);
+  SourceImage.Free;
+  DestImage.Free;
+
+  RS := GetBytesPerLine(AWidth, 32, rileDWordBoundary);
+
+  // For better performances, we will use the ExtCreateRegion() function to create the
+  // region. This function take a RGNDATA structure on entry. We will add rectangles by
+  // amount of ALLOC_UNIT number in this structure
+  maxRects := ALLOC_UNIT;
+  hData := GlobalAlloc(GMEM_MOVEABLE, sizeof(RGNDATAHEADER) + (sizeof(TRECT) * maxRects));
+  pData := GlobalLock(hData);
+  pData^.rdh.dwSize := sizeof(RGNDATAHEADER);
+  pData^.rdh.iType := RDH_RECTANGLES;
+  pData^.rdh.nCount := 0;
+  pData^.rdh.nRgnSize := 0;
+  Windows.SetRect(pData^.rdh.rcBound, MAXLONG, MAXLONG, 0, 0);
+
+  // Keep on hand highest and lowest values for the "transparent" pixel
+  lr := GetRValue(cTransparentColor);
+  lg := GetGValue(cTransparentColor);
+  lb := GetBValue(cTransparentColor);
+  hr := min($ff, lr + GetRValue(cTolerance));
+  hg := min($ff, lg + GetGValue(cTolerance));
+  hb := min($ff, lb + GetBValue(cTolerance));
+  
+  P := Data;
+
+  // Scan each bitmap row from bottom to top (the bitmap is inverted vertically)
+  for y := 0 to AHeight - 1 do
+  begin
+    // Scan each bitmap pixel from left to righ
+    x := 0;
+    while (x < AWidth) do
+    begin
+      // Search for a continuous range of "non transparent pixels"
+      x0 := x;
+      while (x < AWidth) do
+      begin
+        with P[x] do
+          if (Red >= lr) and (Red <= hr) then
+          begin
+            if (Green >= lg) and (Green <= hg) then
+            begin
+              if (Blue >= lb) and (Blue <= hb) then
+                break; //This pixel is "transparent"
+            end;
+          end;
+        inc(x);
+      end;
+      
+      if (x > x0) then
+      begin
+        // Add the pixels (x0, y) to (x, y+1) as a new rectangle in the region
+        if (pData^.rdh.nCount >= maxRects) then
+        begin
+          GlobalUnlock(hData);
+          maxRects := maxRects + ALLOC_UNIT;
+          hData := GlobalReAlloc(hData, sizeof(RGNDATAHEADER) + (sizeof(TRECT) * maxRects), GMEM_MOVEABLE);
+          pData := GlobalLock(hData);
+        end;
+        pr := PRect(PChar(pData^.Buffer));
+        SetRect(pr[pData^.rdh.nCount], x0, y, x, y+1);
+        if (x0 < pData^.rdh.rcBound.left) then
+          pData^.rdh.rcBound.left := x0;
+        if (y < pData^.rdh.rcBound.top) then
+          pData^.rdh.rcBound.top := y;
+        if (x > pData^.rdh.rcBound.right) then
+          pData^.rdh.rcBound.right := x;
+        if (y+1 > pData^.rdh.rcBound.bottom) then
+        pData^.rdh.rcBound.bottom := y+1;
+        inc(pData^.rdh.nCount);
+
+        // On Windows98, ExtCreateRegion() may fail if the number of rectangles is to
+        // large (ie: > 4000). Therefore, we have to create the region by multiple steps
+        if (pData^.rdh.nCount = 2000) then
+        begin
+          h := Windows.ExtCreateRegion(nil, sizeof(RGNDATAHEADER) + (sizeof(TRECT) * maxRects), pData^);
+          if (Result <> 0) then
+          begin
+            Windows.CombineRgn(Result, Result, h, RGN_OR);
+            Windows.DeleteObject(h);
+          end
+          else
+            Result := h;
+
+          pData^.rdh.nCount := 0;
+          Windows.SetRect(pData^.rdh.rcBound, MAXLONG, MAXLONG, 0, 0);
+        end;
+      end;
+      inc(x);
+    end;
+    // Go to next row (remember, the bitmap is inverted vertically
+    P := PRGBAQuad(PByte(P) + RS);
+  end;
+  // Create or extend the region with the remaining rectangle
+  h := Windows.ExtCreateRegion(nil, sizeof(RGNDATAHEADER) + (sizeof(TRECT) * maxRects), pData^);
+  if (Result <> 0) then
+  begin
+    Windows.CombineRgn(Result, Result, h, RGN_OR);
+    Windows.DeleteObject(h);
+  end
+  else
+    Result := h;
+
+  FreeMem(Data);
+end;
+

 procedure DoInitialization;
 begin
--- a/lcl/interfaces/win32/win32wscontrols.pp
+++ b/lcl/interfaces/win32/win32wscontrols.pp
@ -84,6 +84,7 @@ type
    class procedure SetFont(const AWinControl: TWinControl; const AFont: TFont); override;
    class procedure SetText(const AWinControl: TWinControl; const AText: string); override;
    class procedure SetCursor(const AWinControl: TWinControl; const ACursor: HCursor); override;
+    class procedure SetShape(const AWinControl: TWinControl; const AShape: HBITMAP); override;

    class procedure ConstraintsChange(const AWinControl: TWinControl); override;
    class function  CreateHandle(const AWinControl: TWinControl;
@ -492,6 +493,23 @@ begin
    Windows.SetCursor(ACursor);
 end;

+class procedure TWin32WSWinControl.SetShape(const AWinControl: TWinControl;
+  const AShape: HBITMAP);
+var
+  Rgn: HRGN;
+begin
+  if not WSCheckHandleAllocated(AWinControl, 'SetShape') then
+    Exit;
+
+  if AShape <> 0 then
+    Rgn := BitmapToRegion(AShape)
+  else
+    Rgn := 0;
+  SetWindowRgn(AWinControl.Handle, Rgn, True);
+  if Rgn <> 0 then
+    DeleteObject(Rgn);
+end;
+
 class procedure TWin32WSWinControl.ConstraintsChange(const AWinControl: TWinControl);
 begin
  // TODO: implement me!
--- a/lcl/interfaces/win32/win32wsforms.pp
+++ b/lcl/interfaces/win32/win32wsforms.pp
@ -35,7 +35,7 @@ uses
 ////////////////////////////////////////////////////
  Forms, Controls, LCLType, Classes,
 ////////////////////////////////////////////////////
-  WSForms, WSLCLClasses, Windows, SysUtils, Win32Extra,
+  WSForms, WSProc, WSLCLClasses, Windows, SysUtils, Win32Extra,
  InterfaceBase, Win32Int, Win32Proc, Win32WSControls;

 type
--- a/lcl/widgetset/wscontrols.pp
+++ b/lcl/widgetset/wscontrols.pp
@ -101,6 +101,7 @@ type
    class procedure SetSize(const AWinControl: TWinControl; const AWidth, AHeight: Integer); virtual;
    class procedure SetText(const AWinControl: TWinControl; const AText: String); virtual;
    class procedure SetCursor(const AWinControl: TWinControl; const ACursor: HCursor); virtual;
+    class procedure SetShape(const AWinControl: TWinControl; const AShape: HBITMAP); virtual;

    { TODO: move AdaptBounds: it is only used in winapi interfaces }
    class procedure AdaptBounds(const AWinControl: TWinControl;
@ -257,6 +258,11 @@ class procedure TWSWinControl.SetCursor(const AWinControl: TWinControl; const AC
 begin
 end;

+class procedure TWSWinControl.SetShape(const AWinControl: TWinControl;
+  const AShape: HBITMAP);
+begin
+end;
+
 class procedure TWSWinControl.SetFont(const AWinControl: TWinControl; const AFont: TFont);
 begin
 end;