diff --git a/.gitattributes b/.gitattributes index 38f71e68a0..5388c5041e 100644 --- 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 diff --git a/examples/shapedcontrols/manifest.rc b/examples/shapedcontrols/manifest.rc new file mode 100644 index 0000000000..57c7c94ee8 --- /dev/null +++ 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 +{ + "" + "" + "" + "Your application description here." + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" + "" +} \ No newline at end of file diff --git a/examples/shapedcontrols/project1.lpi b/examples/shapedcontrols/project1.lpi new file mode 100644 index 0000000000..de2fb4e9e1 --- /dev/null +++ b/examples/shapedcontrols/project1.lpi @@ -0,0 +1,160 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/examples/shapedcontrols/project1.lpr b/examples/shapedcontrols/project1.lpr new file mode 100644 index 0000000000..b1c4e4040e --- /dev/null +++ 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. + diff --git a/examples/shapedcontrols/unit1.lfm b/examples/shapedcontrols/unit1.lfm new file mode 100644 index 0000000000..cb34f9a2d4 --- /dev/null +++ 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 diff --git a/examples/shapedcontrols/unit1.lrs b/examples/shapedcontrols/unit1.lrs new file mode 100644 index 0000000000..1aaa3a67eb --- /dev/null +++ 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 +]); diff --git a/examples/shapedcontrols/unit1.pas b/examples/shapedcontrols/unit1.pas new file mode 100644 index 0000000000..a9b94b640c --- /dev/null +++ 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. + diff --git a/lcl/controls.pp b/lcl/controls.pp index 29018a0b92..29ae9ff23c 100644 --- 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; diff --git a/lcl/include/wincontrol.inc b/lcl/include/wincontrol.inc index 500cc49afb..5b43e51e0f 100644 --- 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 diff --git a/lcl/interfaces/gtk/gtkwscontrols.pp b/lcl/interfaces/gtk/gtkwscontrols.pp index 53aa3d817b..720e6c2035 100644 --- 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. } diff --git a/lcl/interfaces/gtk/gtkwsforms.pp b/lcl/interfaces/gtk/gtkwsforms.pp index 6dbabfd12a..299c6f6771 100644 --- 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 diff --git a/lcl/interfaces/qt/qtobjects.pas b/lcl/interfaces/qt/qtobjects.pas index 247e9e22d7..82307057fa 100644 --- 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; diff --git a/lcl/interfaces/qt/qtwidgets.pas b/lcl/interfaces/qt/qtwidgets.pas index 60fe31ca6f..1a0e269c97 100644 --- 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); diff --git a/lcl/interfaces/qt/qtwscontrols.pp b/lcl/interfaces/qt/qtwscontrols.pp index b3ea09e3ec..996677a9a1 100644 --- 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 diff --git a/lcl/interfaces/qt/qtwsforms.pp b/lcl/interfaces/qt/qtwsforms.pp index c9c95a009a..04419faba4 100644 --- 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 diff --git a/lcl/interfaces/win32/win32proc.pp b/lcl/interfaces/win32/win32proc.pp index 6be12b4990..e9d768ba6b 100644 --- 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 diff --git a/lcl/interfaces/win32/win32wscontrols.pp b/lcl/interfaces/win32/win32wscontrols.pp index 5962f438d5..986937b5d1 100644 --- 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! diff --git a/lcl/interfaces/win32/win32wsforms.pp b/lcl/interfaces/win32/win32wsforms.pp index 469db66124..01970642c7 100644 --- 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 diff --git a/lcl/widgetset/wscontrols.pp b/lcl/widgetset/wscontrols.pp index 065b71957d..42c9453ec1 100644 --- 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;