{%MainUnit qtint.pp} {****************************************************************************** All Qt6 Winapi implementations. This are the implementations of the overrides of the Qt6 Interface for the methods defined in the lcl/include/winapi.inc !! Keep alphabetical !! ****************************************************************************** Implementation ****************************************************************************** ***************************************************************************** This file is part of the Lazarus Component Library (LCL) See the file COPYING.modifiedLGPL.txt, included in this distribution, for details about the license. ***************************************************************************** } //##apiwiz##sps## // Do not remove, no wizard declaration before this line {------------------------------------------------------------------------------ Function: Arc Params: DC: HDC; Left,Top,Right,Bottom,angle1,angle2 : Integer Returns: Boolean ------------------------------------------------------------------------------} function TQtWidgetSet.Arc(DC: HDC; Left,Top,Right,Bottom,angle1,angle2 : Integer): Boolean; var R: TRect; begin {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI Arc] DC: ', dbghex(DC)); {$endif} Result := IsValidDC(DC); if Result then begin R := Rect(Left, Top, Right, Bottom); QPainter_drawArc(TQtDeviceContext(DC).Widget, @R, Angle1, Angle2); end; end; {------------------------------------------------------------------------------ Function: AngleChord Params: DC: HDC; x1, y1, x2, y2, angle1, angle2: Integer Returns: Boolean ------------------------------------------------------------------------------} function TQtWidgetSet.AngleChord(DC: HDC; x1, y1, x2, y2, angle1, angle2: Integer): Boolean; begin {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI AngleChord] DC: ', dbghex(DC)); {$endif} Result := IsValidDC(DC); if Result then QPainter_drawChord(TQtDeviceContext(DC).Widget, x1, y1, x2 - x1, y2 - y1, Angle1, Angle2); end; {------------------------------------------------------------------------------ Function: BeginPaint Params: Returns: This function is Called: - Once on every OnPaint event ------------------------------------------------------------------------------} function TQtWidgetSet.BeginPaint(Handle: hWnd; var PS: TPaintStruct): hdc; var Widget: TQtWidget; DC: TQtDeviceContext; begin {$ifdef VerboseQtWinAPI} WriteLn('Trace:> [WinAPI BeginPaint] Handle=', dbghex(Handle)); {$endif} Widget := TQtWidget(Handle); if Widget <> nil then DC := TQtDeviceContext.Create(Widget.PaintData.PaintWidget, True) else DC := TQtDeviceContext.Create(nil, True); PS.hdc := HDC(DC); if Handle<>0 then begin QPainter_setLayoutDirection(DC.Widget, QtLayoutDirectionAuto); if Widget.PaintData.ClipRegion <> nil then begin //Write('>>> Setting Paint ClipRegion: '); //DebugRegion('PaintData.ClipRegion: ', Widget.PaintData.ClipRegion); DC.setClipRegion(Widget.PaintData.ClipRegion); DC.setClipping(True); end; if Widget.PaintData.ClipRect <> nil then begin New(DC.vClipRect); DC.vClipRect^ := Widget.PaintData.ClipRect^; end; end; Result := PS.hdc; {$ifdef VerboseQtWinAPI} WriteLn('Trace:< [WinAPI BeginPaint] Result=', dbghex(Result)); {$endif} end; function TQtWidgetSet.BitBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Rop: DWORD): Boolean; begin {$ifdef VerboseQtWinAPI} WriteLn('Trace:> [TQtWidgetSet.BitBlt]'); {$endif} Result := StretchBlt(DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, Width, Height, ROP); {$ifdef VerboseQtWinAPI} WriteLn('Trace:< [TQtWidgetSet.BitBlt]'); {$endif} end; function TQtWidgetSet.CallNextHookEx(hHk: HHOOK; ncode : Integer; wParam: WParam; lParam : LParam) : Integer; begin {$ifdef VerboseQtWinAPI_MISSING_IMPLEMENTATION} WriteLn('***** [WinAPI TQtWidgetSet.CallNextHookEx] missing implementation '); {$endif} Result := 0; end; function TQtWidgetSet.CallWindowProc(lpPrevWndFunc : TFarProc; Handle : HWND; Msg : UINT; wParam: WParam; lParam : lParam) : Integer; begin {$ifdef VerboseQtWinAPI_MISSING_IMPLEMENTATION} WriteLn('***** [WinAPI TQtWidgetSet.CallWindowProc] missing implementation '); {$endif} Result := -1; end; {------------------------------------------------------------------------------ Method: ClientToScreen Params: Handle - Returns: ------------------------------------------------------------------------------} function TQtWidgetSet.ClientToScreen(Handle: HWND; var P: TPoint) : Boolean; begin Result := IsValidHandle(Handle); if Result then P := TQtWidget(Handle).MapToGlobal(P, True); end; function TQtWidgetSet.ClipboardFormatToMimeType(FormatID: TClipboardFormat): string; begin Result := Clipboard.FormatToMimeType(FormatID); end; function TQtWidgetSet.ClipboardGetData(ClipboardType: TClipboardType; FormatID: TClipboardFormat; Stream: TStream): boolean; begin Result := Clipboard.Getdata(ClipboardType, FormatID, Stream); end; function TQtWidgetSet.ClipboardGetFormats(ClipboardType: TClipboardType; var Count: integer; var List: PClipboardFormat): boolean; begin Result := Clipboard.GetFormats(ClipboardType, Count, List); end; function TQtWidgetSet.ClipboardGetOwnerShip(ClipboardType: TClipboardType; OnRequestProc: TClipboardRequestEvent; FormatCount: integer; Formats: PClipboardFormat): boolean; begin Result := Clipboard.GetOwnerShip(ClipboardType, OnRequestProc, FormatCount, Formats); end; function TQtWidgetSet.ClipboardRegisterFormat(const AMimeType: string): TClipboardFormat; begin Result := Clipboard.RegisterFormat(AMimeType); end; {------------------------------------------------------------------------------ Function: CombineRgn Params: Dest, Src1, Src2, fnCombineMode Returns: longint Combine the 2 Source Regions into the Destination Region using the specified Combine Mode. The Destination must already be initialized. The Return value is the Destination's Region type, or ERROR. The Combine Mode can be one of the following: RGN_AND : Gets a region of all points which are in both source regions RGN_COPY : Gets an exact copy of the first source region RGN_DIFF : Gets a region of all points which are in the first source region but not in the second.(Source1 - Source2) RGN_OR : Gets a region of all points which are in either the first source region or in the second.(Source1 + Source2) RGN_XOR : Gets all points which are in either the first Source Region or in the second, but not in both. The result can be one of the following constants Error NullRegion SimpleRegion ComplexRegion ------------------------------------------------------------------------------} function TQtWidgetSet.CombineRgn(Dest, Src1, Src2: HRGN; fnCombineMode: Longint): Longint; var RDest,RSrc1,RSrc2: QRegionH; begin result:=ERROR; if not IsValidGDIObject(Dest) or not IsValidGDIObject(Src1) then exit else begin RDest := TQtRegion(Dest).FHandle; RSrc1 := TQtRegion(Src1).FHandle; end; if (fnCombineMode<>RGN_COPY) and not IsValidGDIObject(Src2) then exit else RSrc2 := TQtRegion(Src2).FHandle; case fnCombineMode of RGN_AND: QRegion_intersected(RSrc1, RDest, RSrc2); RGN_COPY: begin // union of Src1 with a null region RSrc2 := QRegion_create; QRegion_united(RSrc1, RDest, RSrc2); QRegion_destroy(RSrc2); end; RGN_DIFF: QRegion_subtracted(RSrc1, RDest, RSrc2); RGN_OR: QRegion_united(RSrc1, RDest, RSrc2); RGN_XOR: QRegion_xored(RSrc1, RDest, RSrc2); end; if QRegion_isEmpty(RDest) then Result := NULLREGION else begin if TQtRegion(Dest).IsPolyRegion or (TQtRegion(Dest).numRects > 0) then Result := COMPLEXREGION else Result := SIMPLEREGION; end; end; {------------------------------------------------------------------------------ Method: TQtWidgetSet.CreateCompatibleBitmap Params: HDC, Width & Height Returns: HBITMAP ------------------------------------------------------------------------------} function TQtWidgetSet.CreateCompatibleBitmap(DC: HDC; Width, Height: Integer): HBITMAP; var QtDC: TQtDeviceContext; Format: QImageFormat = QImageFormat_ARGB32; ADevice: QPaintDeviceH = nil; //ADesktop: QDesktopWidgetH = nil; begin {$ifdef VerboseQtWinAPI} WriteLn('Trace:> [WinAPI CreateCompatibleBitmap]', ' DC:', dbghex(DC), ' Width:', dbgs(Width), ' Height:', dbgs(Height)); {$endif} Result := 0; if IsValidDC(DC) then begin QtDC := TQtDeviceContext(DC); case QtDC.getDepth of 1: Format := QImageFormat_Mono; 15, 16: Format := QImageFormat_RGB16; 24: Format := QImageFormat_RGB32; 32: Format := QImageFormat_ARGB32; end; end else begin // ADesktop := QApplication_desktop(); // if ADesktop <> nil then // ADevice := QWidget_to_QPaintDevice(ADesktop); ADevice := nil; if ADevice <> nil then begin case QPaintDevice_depth(ADevice) of 1: Format := QImageFormat_Mono; 15, 16: Format := QImageFormat_RGB16; 24: Format := QImageFormat_RGB32; 32: Format := QImageFormat_ARGB32; end; end; end; Result := HBitmap(TQtImage.Create(nil, Width, Height, Format)); {$ifdef VerboseQtWinAPI} WriteLn('Trace:< [WinAPI CreateCompatibleBitmap] Bitmap:', dbghex(Result)); {$endif} end; {------------------------------------------------------------------------------ Method: TQtWidgetSet.CreateBitmap Params: Returns: This functions is for TBitmap support. Specifically it´s utilized on when a handle for a bitmap is needed ------------------------------------------------------------------------------} function TQtWidgetSet.CreateBitmap(Width, Height: Integer; Planes, BitCount: Longint; BitmapBits: Pointer): HBITMAP; var Format: QImageFormat; NewBits: PByte; NewBitsSize: PtrUInt; ARowStride, RSS: Integer; begin {$ifdef VerboseQtWinAPI} WriteLn('Trace:> [WinAPI CreateBitmap]', ' Width:', dbgs(Width), ' Height:', dbgs(Height), ' Planes:', dbgs(Planes), ' BitCount:', dbgs(BitCount), ' BitmapBits: ', dbgs(BitmapBits)); {$endif} // for win32 data is aligned to WORD // for qt we must realign data to DWORD case BitCount of 1: Format := QImageFormat_Mono; 15, 16: Format := QImageFormat_RGB16; 24: Format := QImageFormat_RGB32; 32: Format := QImageFormat_ARGB32; else Format := QImageFormat_ARGB32; end; RSS := GetBytesPerLine(Width, BitCount, rileWordBoundary); if BitmapBits <> nil then begin ARowStride := GetBytesPerLine(Width, BitCount, rileDWordBoundary); if not CopyImageData(Width, Height, RSS, BitCount, BitmapBits, Rect(0, 0, Width, Height), riloBottomToTop, riloBottomToTop, rileDWordBoundary, NewBits, NewBitsSize) then begin // this was never tested ARowStride := RSS; NewBits := AllocMem(RSS * Height); Move(BitmapBits^, NewBits^, RSS * Height); end; Result := HBitmap(TQtImage.Create(NewBits, Width, Height, ARowStride, Format, True)); end else Result := HBitmap(TQtImage.Create(nil, Width, Height, Format)); {$ifdef VerboseQtWinAPI} WriteLn('Trace:< [WinAPI CreateBitmap] Bitmap:', dbghex(Result)); {$endif} end; {------------------------------------------------------------------------------ Function: CreateBrushIndirect Params: none Returns: Nothing ------------------------------------------------------------------------------} function TQtWidgetSet.CreateBrushIndirect(const LogBrush: TLogBrush): HBRUSH; var QtBrush: TQtBrush; Color: TQColor; begin {$ifdef VerboseQtWinAPI} WriteLn(Format('Trace:> [WinAPI CreateBrushIndirect] Style: %d, Color: %8x (%s)', [LogBrush.lbStyle, LogBrush.lbColor, ColorToString(LogBrush.lbColor)])); {$endif} Result := 0; QtBrush := TQtBrush.Create(True); try case LogBrush.lbStyle of BS_NULL: QtBrush.Style := QtNoBrush; // Same as BS_HOLLOW. BS_SOLID: QtBrush.Style := QtSolidPattern; BS_HATCHED: // Hatched brushes. begin case LogBrush.lbHatch of HS_BDIAGONAL: QtBrush.Style := QtBDiagPattern; HS_CROSS: QtBrush.Style := QtCrossPattern; HS_DIAGCROSS: QtBrush.Style := QtDiagCrossPattern; HS_FDIAGONAL: QtBrush.Style := QtFDiagPattern; HS_HORIZONTAL: QtBrush.Style := QtHorPattern; HS_VERTICAL: QtBrush.Style := QtVerPattern; else QtBrush.Style := QtSolidPattern; end; end; BS_DIBPATTERN, // A pattern brush defined by a device-independent // bitmap (DIB) specification. If lbStyle is BS_DIBPATTERN, the // lbHatch member contains a handle to a packed DIB.Windows 95: // Creating brushes from bitmaps or DIBs larger than 8x8 pixels // is not supported. If a larger bitmap is given, only a portion // of the bitmap is used. BS_DIBPATTERN8X8, // Same as BS_DIBPATTERN. BS_DIBPATTERNPT, // A pattern brush defined by a device-independent // bitmap (DIB) specification. If lbStyle is BS_DIBPATTERNPT, the // lbHatch member contains a pointer to a packed DIB. BS_PATTERN, // Pattern brush defined by a memory bitmap. BS_PATTERN8X8: // Same as BS_PATTERN. begin QtBrush.setTextureImage(TQtImage(LogBrush.lbHatch).Handle); QtBrush.Style := QtTexturePattern; end; else DebugLn(Format('Unsupported Style %d',[LogBrush.lbStyle])); end; { Other non-utilized Qt brushes: QtDense1Pattern, QtDense2Pattern, QtDense3Pattern, QtDense4Pattern, QtDense5Pattern, QtDense6Pattern, QtDense7Pattern, QtLinearGradientPattern, QtRadialGradientPattern, QtConicalGradientPattern } // set brush color Color := QBrush_Color(QtBrush.FHandle)^; ColorRefToTQColor(ColorToRGB(TColor(logBrush.lbColor)), Color); QtBrush.setColor(@Color); Result := HBRUSH(QtBrush); except Result := 0; DebugLn('TQtWidgetSet.CreateBrushIndirect: Failed'); end; {$ifdef VerboseQtWinAPI} WriteLn('Trace:< [WinAPI CreateBrushIndirect] Result: ', dbghex(Result)); {$endif} end; {------------------------------------------------------------------------------ Function: CreateBrushWithRadialGradient Params: none Returns: Nothing ------------------------------------------------------------------------------} function TQtWidgetSet.CreateBrushWithRadialGradient(const LogBrush: TLogRadialGradient): HBRUSH; var QtBrush: TQtBrush; begin Result := 0; QtBrush := TQtBrush.CreateWithRadialGradient(LogBrush); Result := HBRUSH(QtBrush); if Result = 0 then DebugLn('TQtWidgetSet.CreateBrushWithRadialGradient: Failed'); end; function TQtWidgetSet.CreateCaret(Handle: HWND; Bitmap: hBitmap; Width, Height: Integer): Boolean; begin Result := (Handle <> 0) and QtCaret.CreateCaret(TQtWidget(Handle), Bitmap, Width, Height); end; {------------------------------------------------------------------------------ Function: CreateCompatibleDC Params: DC - handle to memory device context Returns: handle to a memory device context Creates a memory device context (DC) compatible with the specified device. ------------------------------------------------------------------------------} function TQtWidgetSet.CreateCompatibleDC(DC: HDC): HDC; begin {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI CreateCompatibleDC] DC: ', dbghex(DC)); {$endif} Result := HDC(TQtDeviceContext.Create(nil, True)); end; {------------------------------------------------------------------------------ Function: CreateEllipticRgn Params: p1 - X position of the top-left corner p2 - Y position of the top-left corner p3 - X position of the bottom-right corner p4 - Y position of the bottom-right corner Returns: HRGN ------------------------------------------------------------------------------} function TQtWidgetSet.CreateEllipticRgn(p1, p2, p3, p4: Integer): HRGN; var QtRegion: TQtRegion; begin {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI CreateEllipticRgn] '); {$endif} QtRegion := TQtRegion.Create(True, p1, p2, p3, p4, QRegionEllipse); Result := HRGN(QtRegion); end; {------------------------------------------------------------------------------ Function: CreateFontIndirect Params: const LogFont: TLogFont Returns: HFONT Creates a font GDIObject. ------------------------------------------------------------------------------} function TQtWidgetSet.CreateFontIndirect(const LogFont: TLogFont): HFONT; begin Result := CreateFontIndirectEx(LogFont, ''); end; {------------------------------------------------------------------------------ Function: CreateFontIndirectEx Params: const LogFont: TLogFont Returns: HFONT Creates a font GDIObject. ------------------------------------------------------------------------------} function TQtWidgetSet.CreateFontIndirectEx(const LogFont: TLogFont; const LongFontName: string): HFONT; var QtFont: TQtFont; FamilyName: string; const QStyleStategy: array [DEFAULT_QUALITY..CLEARTYPE_NATURAL_QUALITY] of QFontStyleStrategy = ( { DEFAULT_QUALITY } QFontPreferDefault, { DRAFT_QUALITY } QFontPreferMatch, { PROOF_QUALITY } QFontPreferQuality, { NONANTIALIASED_QUALITY } QFontNoAntialias, { ANTIALIASED_QUALITY } QFontPreferAntialias, { CLEARTYPE_QUALITY } QFontPreferAntialias, { CLEARTYPE_NATURAL_QUALITY } QFontPreferAntialias ); begin {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI CreateFontIndirectEx] FontName: ' + LongFontName); {$endif} Result := 0; QtFont := TQtFont.Create(True); try // -1 has different meaning - it means that font height was set using setPointSize if LogFont.lfHeight <> -1 then QtFont.setPixelSize(Abs(LogFont.lfHeight)); case LogFont.lfWeight of FW_THIN : QtFont.setWeight(QtFontWeight_Thin); FW_EXTRALIGHT : QtFont.setWeight(QtFontWeight_ExtraLight); FW_LIGHT : QtFont.setWeight(QtFontWeight_Light); FW_NORMAL : QtFont.setWeight(QtFontWeight_Normal); FW_MEDIUM : QtFont.setWeight(QtFontWeight_Medium); FW_SEMIBOLD : QtFont.setWeight(QtFontWeight_DemiBold); FW_BOLD : QtFont.setWeight(QtFontWeight_Bold); FW_EXTRABOLD : QtFont.setWeight(QtFontWeight_ExtraBold); FW_HEAVY : QtFont.setWeight(QtFontWeight_Black); FW_DONTCARE : QtFont.setWeight(QtFontWeight_Normal); else raise Exception.CreateFmt('TQtWidgetSet.CreateFontIndirectEx() invalid font weight %d',[LogFont.lfWeight]); end; QtFont.Angle := LogFont.lfEscapement; //LogFont.lfOrientation; QtFont.setItalic(LogFont.lfItalic = High(Byte)); QtFont.setUnderline(LogFont.lfUnderline = High(Byte)); QtFont.setStrikeOut(LogFont.lfStrikeOut = High(Byte)); FamilyName := StrPas(LogFont.lfFaceName); if not IsFontNameDefault(FamilyName) then QtFont.setFamily(FamilyName) else QtFont.setFamily(UTF16ToUTF8(GetDefaultAppFontName)); if LogFont.lfQuality <= High(QStyleStategy) then QtFont.setStyleStrategy(QStyleStategy[LogFont.lfQuality]); Result := HFONT(QtFont); except Result := 0; DebugLn('TQtWidgetSet.CreateFontIndirectEx: Failed'); end; end; function TQtWidgetSet.CreateIconIndirect(IconInfo: PIconInfo): HICON; var AIcon: TQtIcon; APixmap, ATemp: QPixmapH; AMask: QBitmapH; {$IFDEF DARWIN} AImgFmt: QImageFormat; {$ENDIF} begin Result := 0; if IsValidGDIObject(IconInfo^.hbmColor) then begin APixmap := QPixmap_create(); QPixmap_fromImage(APixmap, TQtImage(IconInfo^.hbmColor).Handle); {$IFDEF DARWIN} AImgFmt := TQtImage(IconInfo^.hbmColor).getFormat; if (AImgFmt in [QImageFormat_Mono, QImageFormat_MonoLSB, QImageFormat_Indexed8, QImageFormat_RGB32]) then {$ENDIF} if IconInfo^.hbmMask <> 0 then begin ATemp := QPixmap_create(); QPixmap_fromImage(ATemp, TQtImage(IconInfo^.hbmMask).Handle); AMask := QBitmap_create(ATemp); QPixmap_setMask(APixmap, AMask); QPixmap_destroy(ATemp); QBitmap_destroy(AMask); end; if IconInfo^.fIcon then begin AIcon := TQtIcon.Create; AIcon.addPixmap(APixmap); Result := HICON(AIcon); end else Result := HCURSOR(TQtCursor.Create(APixmap, IconInfo^.xHotspot, IconInfo^.yHotspot)); QPixmap_destroy(APixmap); end; end; {------------------------------------------------------------------------------ Function: CreatePatternBrush Params: HBITMAP Returns: HBRUSH ------------------------------------------------------------------------------} function TQtWidgetSet.CreatePatternBrush(ABitmap: HBITMAP): HBRUSH; var Image: QImageH; QtBrush: TQtBrush; begin {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI CreatePatternBrush]',' Bitmap=', dbghex(ABitmap)); {$endif} Result := 0; if ABitmap = 0 then exit; QtBrush := TQtBrush.Create(True); Image := QImage_create(TQtImage(ABitmap).Handle); try QtBrush.setTextureImage(Image); finally QImage_destroy(Image); end; Result := HBRUSH(QtBrush); end; {------------------------------------------------------------------------------ Function: CreatePenIndirect Params: none Returns: HPEN ------------------------------------------------------------------------------} function TQtWidgetSet.CreatePenIndirect(const LogPen: TLogPen): HPEN; var QtPen: TQtPen; color: TQColor; begin Result := 0; QtPen := TQtPen.Create(True); with LogPen do begin case lopnStyle and PS_STYLE_MASK of PS_SOLID: QtPen.setStyle(QtSolidLine); PS_DASH: QtPen.setStyle(QtDashLine); PS_DOT: QtPen.setStyle(QtDotLine); PS_DASHDOT: QtPen.setStyle(QtDashDotLine); PS_DASHDOTDOT: QtPen.setStyle(QtDashDotDotLine); PS_NULL: QtPen.setStyle(QtNoPen); else QtPen.setStyle(QtSolidLine); end; if lopnWidth.X <= 0 then QtPen.setCosmetic(True) else begin QtPen.setCosmetic(False); QtPen.setWidth(lopnWidth.X); end; QPen_Color(QtPen.FHandle, @Color); ColorRefToTQColor(ColorToRGB(TColor(lopnColor)), Color); QPen_setColor(QtPen.FHandle, @Color); end; Result := HPEN(QtPen); end; {------------------------------------------------------------------------------ Function: CreatePolygonRgn Params: none Returns: HRGN ------------------------------------------------------------------------------} function TQtWidgetSet.CreatePolygonRgn(Points: PPoint; NumPts: Integer; FillMode: integer): HRGN; var QtRegion: TQtRegion; QtPoints: PQtPoint; i: Integer; Poly: QPolygonH; begin {$ifdef VerboseQtWinAPI} WriteLn('Trace: [WinAPI CreatePolygonRgn] '); {$endif} GetMem(QtPoints, NumPts * SizeOf(TQtPoint)); for i := 0 to NumPts - 1 do QtPoints[i] := QtPoint(Points[i].x, Points[i].y); Poly := QPolygon_create(NumPts, PInteger(QtPoints)); FreeMem(QtPoints); try {fillmode can be ALTERNATE or WINDING as msdn says} if FillMode = ALTERNATE then QtRegion := TQtRegion.Create(True, Poly, QtOddEvenFill) else QtRegion := TQtRegion.Create(True, Poly, QtWindingFill); Result := HRGN(QtRegion); finally QPolygon_destroy(Poly); end; end; {------------------------------------------------------------------------------ Function: CreateRectRgn Params: none Returns: HRGN ------------------------------------------------------------------------------} function TQtWidgetSet.CreateRectRgn(X1,Y1,X2,Y2 : Integer): HRGN; begin Result := HRGN(TQtRegion.Create(True, X1, Y1, X2, Y2)); {$ifdef VerboseQtWinAPI} WriteLn('Trace: [WinAPI CreateRectRgn] Result: ', dbghex(Result), ' QRegionH: ', dbghex(PtrUInt(TQtRegion(Result).FHandle))); {$endif} end; {------------------------------------------------------------------------------ Procedure: DeleteCriticalSection Params: var CritSection: TCriticalSection Returns: Nothing ------------------------------------------------------------------------------} procedure TQtWidgetSet.DeleteCriticalSection(var CritSection: TCriticalSection); var ACritSec: System.PRTLCriticalSection; begin ACritSec:=System.PRTLCriticalSection(CritSection); System.DoneCriticalsection(ACritSec^); Dispose(ACritSec); CritSection:=0; end; {------------------------------------------------------------------------------ Function: DeleteDC Params: none Returns: Nothing ------------------------------------------------------------------------------} function TQtWidgetSet.DeleteDC(hDC: HDC): Boolean; begin {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI DeleteDC] Handle: ', dbghex(hDC)); {$endif} Result := False; if not IsValidDC(hDC) then exit; TQtDeviceContext(hDC).Free; Result := True; end; {------------------------------------------------------------------------------ Function: DeleteObject Params: none Returns: Nothing ------------------------------------------------------------------------------} function TQtWidgetSet.DeleteObject(GDIObject: HGDIOBJ): Boolean; var aObject: TObject; APaintEngine: QPaintEngineH; APainter: QPainterH; {$ifdef VerboseQtWinAPI} ObjType: string; {$endif} begin {$ifdef VerboseQtWinAPI} WriteLn('Trace:> [WinAPI DeleteObject] GDIObject: ', dbghex(GDIObject)); ObjType := 'Unidentifyed'; {$endif} Result := False; if GDIObject = 0 then Exit(True); if not IsValidGDIObject(GDIObject) then Exit; aObject := TObject(GDIObject); if (aObject is TQtResource) and TQtResource(aObject).FShared then Exit(True); {------------------------------------------------------------------------------ Font ------------------------------------------------------------------------------} if aObject is TQtFont then begin {$ifdef VerboseQtWinAPI} ObjType := 'Font'; {$endif} end {------------------------------------------------------------------------------ Brush ------------------------------------------------------------------------------} else if aObject is TQtBrush then begin {$ifdef VerboseQtWinAPI} ObjType := 'Brush'; {$endif} end {------------------------------------------------------------------------------ Image ------------------------------------------------------------------------------} else if aObject is TQtImage then begin {$ifdef VerboseQtWinAPI} ObjType := 'Image'; {$endif} // we must stop paintdevice before destroying APaintEngine := QImage_paintEngine(TQtImage(AObject).Handle); if (APaintEngine <> nil) and QPaintEngine_isActive(APaintEngine) then begin APainter := QPaintEngine_painter(APaintEngine); if APainter <> nil then QPainter_end(APainter); end; end {------------------------------------------------------------------------------ Region ------------------------------------------------------------------------------} else if aObject is TQtRegion then begin {$ifdef VerboseQtWinAPI} ObjType := 'Region'; {$endif} end {------------------------------------------------------------------------------ Pen ------------------------------------------------------------------------------} else if aObject is TQtPen then begin {$ifdef VerboseQtWinAPI} ObjType := 'Pen'; {$endif} end; if AObject is TQtResource then if TQtResource(AObject).Owner <> nil then begin // this is an owned (default) resource, let owner free it DebugLn('WARNING: TQtWidgetSet.DeleteObject() trying to free a default resource ',dbgsName(AObject),' owner=',dbgsName(TQtResource(AObject).Owner)); AObject := nil; end; if AObject <> nil then begin //WriteLn('Delete object: ', PtrUInt(AObject)); FreeThenNil(AObject); end; Result := True; {$ifdef VerboseQtWinAPI} WriteLn('Trace:< [WinAPI DeleteObject] Result=', dbgs(Result), ' ObjectType=', ObjType); {$endif} end; function TQtWidgetSet.DestroyCaret(Handle: HWND): Boolean; begin Result := (Handle <> 0) and QtCaret.DestroyCaret; end; {------------------------------------------------------------------------------ Method: DestroyIcon Params: Handle Returns: Result of destroying ------------------------------------------------------------------------------} function TQtWidgetSet.DestroyIcon(Handle: HICON): Boolean; begin Result := (Handle <> 0) and ( (TObject(Handle) is TQtIcon) or (TObject(Handle) is TQtCursor) ); if Result then TObject(Handle).Free; end; {------------------------------------------------------------------------------ Method: DPtoLP Params: DC: HDC; var Points; Count: Integer Returns: Boolean ------------------------------------------------------------------------------} function TQtWidgetSet.DPtoLP(DC: HDC; var Points; Count: Integer): BOOL; var P: PPoint; QtPoint: TQtPoint; Matrix: QTransformH; MatrixInv: QTransformH; QtDC: TQtDeviceContext; Inverted: Boolean; begin {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI DPtoLP] '); {$endif} Result := False; if not IsValidDC(DC) then Exit; QtDC := TQtDeviceContext(DC); Matrix := QTransform_create; MatrixInv := QTransform_create; QPainter_combinedTransform(QtDC.Widget, Matrix); P := @Points; try while Count > 0 do begin Dec(Count); Inverted := QTransform_isInvertible(Matrix); QTransform_inverted(Matrix, MatrixInv, @Inverted); QtPoint.X := P^.X; QtPoint.Y := P^.Y; QTransform_map(MatrixInv, PQtPoint(@QtPoint), PQtPoint(@QtPoint)); P^.X := QtPoint.X; P^.Y := QtPoint.Y; Inc(P); end; Result := True; finally QTransform_destroy(MatrixInv); QTransform_destroy(Matrix); end; end; {------------------------------------------------------------------------------ Method: DrawEdge Params: DC: HDC; var Rect: TRect; edge: Cardinal; grfFlags: Cardinal Returns: Boolean ------------------------------------------------------------------------------} function TQtWidgetSet.DrawEdge(DC: HDC; var Rect: TRect; edge: Cardinal; grfFlags: Cardinal): Boolean; var Brush: HBRUSH; ColorDark, ColorLight: TColorRef; ClientRect: TRect; QtDC: TQtDeviceContext; procedure InternalDrawEdge(Outer: Boolean; const R: TRect); var X1, Y1, X2, Y2: Integer; ColorLeftTop, ColorRightBottom: TColor; EdgeQtColor: TQColor; APen, OldPen: TQtPen; begin X1 := R.Left; Y1 := R.Top; X2 := R.Right; Y2 := R.Bottom; ColorLeftTop := clNone; ColorRightBottom := clNone; if Outer then begin if Edge and BDR_RAISEDOUTER <> 0 then begin ColorLeftTop := ColorLight; ColorRightBottom := ColorDark; end else if Edge and BDR_SUNKENOUTER <> 0 then begin ColorLeftTop := ColorDark; ColorRightBottom := ColorLight; end; end else begin if Edge and BDR_RAISEDINNER <> 0 then begin ColorLeftTop := ColorLight; ColorRightBottom := ColorDark; end else if Edge and BDR_SUNKENINNER <> 0 then begin ColorLeftTop := ColorDark; ColorRightBottom := ColorLight; end; end; if grfFlags and BF_DIAGONAL = 0 then begin APen := TQtPen.Create(True); ColorRefToTQColor(TColorRef(ColorLeftTop), EdgeQtColor{%H-}); APen.setColor(EdgeQtColor); OldPen := QtDC.setPen(APen); if grfFlags and BF_LEFT <> 0 then QtDC.DrawLine(X1, Y1, X1, Y2); if grfFlags and BF_TOP <> 0 then QtDC.DrawLine(X1, Y1, X2, Y1); QtDC.setPen(OldPen); APen.Free; APen := TQtPen.Create(True); ColorRefToTQColor(TColorRef(ColorRightBottom), EdgeQtColor); APen.setColor(EdgeQtColor); OldPen := QtDC.SetPen(APen); if grfFlags and BF_RIGHT <> 0 then QtDC.DrawLine(X2, Y1, X2, Y2); if grfFlags and BF_BOTTOM <> 0 then QtDC.DrawLine(X1, Y2, X2, Y2); QtDC.SetPen(OldPen); APen.Free; end else begin APen := TQtPen.Create(True); ColorRefToTQColor(TColorRef(ColorLeftTop), EdgeQtColor); APen.setColor(EdgeQtColor); OldPen := QtDC.setPen(APen); if (grfFlags and BF_DIAGONAL_ENDTOPLEFT = BF_DIAGONAL_ENDTOPLEFT) or (grfFlags and BF_DIAGONAL_ENDBOTTOMRIGHT = BF_DIAGONAL_ENDBOTTOMRIGHT) then QtDC.DrawLine(X1, Y1, X2, Y2) else QtDC.DrawLine(X1, Y2, X2, Y1); QtDC.setPen(OldPen); APen.Free; end; end; begin {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI DrawEdge] '); {$endif} Result := False; if not IsValidDC(DC) or IsRectEmpty(Rect) then exit; QtDC := TQtDeviceContext(DC); ClientRect := Rect; Dec(ClientRect.Right, 1); Dec(ClientRect.Bottom, 1); QtDC.save; try ColorDark := ColorToRGB(clBtnShadow); ColorLight := ColorToRGB(clBtnHighlight); if grfFlags and BF_FLAT <> 0 then ColorLight := clSilver; if grfFlags and BF_MONO <> 0 then begin ColorDark := TColorRef(clBlack); ColorLight := TColorRef(clWhite); end; try if Edge and (BDR_SUNKENOUTER or BDR_RAISEDOUTER) <> 0 then InternalDrawEdge(True, ClientRect); InflateRect(ClientRect, -1, -1); if grfFlags and BF_MONO = 0 then begin ColorLight := ColorToRGB(clBtnHighlight); ColorDark := ColorToRGB(clBtnShadow); end; if Edge and (BDR_SUNKENINNER or BDR_RAISEDINNER) <> 0 then begin InternalDrawEdge(False, ClientRect); InflateRect(ClientRect, -1, -1); end; finally end; inc(ClientRect.Right); inc(ClientRect.Bottom); if grfFlags and BF_MIDDLE <> 0 then begin Brush := CreateSolidBrush(TColorRef(clBtnFace)); try FillRect(DC, ClientRect, Brush); finally DeleteObject(Brush); end; end; if grfFlags and BF_ADJUST <> 0 then Rect := ClientRect; Result := True; finally QtDC.Restore; end; end; {------------------------------------------------------------------------------ Method: DrawFocusRect Params: DC: HDC; const Rect: TRect Returns: Boolean ------------------------------------------------------------------------------} function TQtWidgetSet.DrawFocusRect(DC: HDC; const Rect: TRect): boolean; var StyleOption: QStyleOptionFocusRectH; QtDC: TQtDeviceContext; begin {$ifdef VerboseQtWinAPI} WriteLn('[TQtWidgetSet.DrawFocusRect] Handle: ', dbghex(DC)); {$endif} Result := False; if not IsValidDC(DC) then exit; QtDC := TQtDeviceContext(DC); StyleOption := QStyleOptionFocusRect_create; QtDC.save; try QStyleOption_setRect(StyleOption, @Rect); if not QtDC.getClipping then QtDC.setClipRect(Rect); QStyle_drawPrimitive(QApplication_style, QStylePE_FrameFocusRect, StyleOption, QtDC.Widget, QtDC.Parent); Result := True; finally QStyleOptionFocusRect_destroy(StyleOption); QtDC.restore; end; end; function TQtWidgetSet.DrawFrameControl(DC: HDC; const Rect: TRect; uType, uState: Cardinal): Boolean; var QtDC: TQtDeviceContext; Painter: QPainterH; Widget: QWidgetH; function uStatetoQStyleState: QStyleState; begin Result := QStyleState_None; if (uState and DFCS_INACTIVE = 0) then Result := Result or QStyleState_Enabled; if (uState and DFCS_PUSHED <> 0) then Result := Result or QStyleState_MouseOver or QStyleState_Sunken else Result := Result or QStyleState_Raised; if (uState and DFCS_CHECKED <> 0) then Result := Result or QStyleState_On else Result := Result or QStyleState_Off; if ((uState and DFCS_HOT <> 0) or (uState and DFCS_PUSHED <> 0)) then Result := Result or QStyleState_MouseOver or QStyleState_Active; if (uType <> DFC_BUTTON) and ((uState and DFCS_FLAT <> 0) and not (uState and DFCS_PUSHED <> 0)) then Result := Result and not QStyleState_Raised; // DFCS_TRANSPARENT = 2048; //DFCS_ADJUSTRECT = 8192; //DFCS_FLAT = 16384; //DFCS_MONO = 32768; end; function DrawButton: boolean; var Opt: QStyleOptionButtonH; Element: QStyleControlElement; State: QStyleState; Features: QStyleOptionButtonButtonFeatures; begin Result := False; State := uStatetoQStyleState; if uState and DFCS_FLAT <> 0 then Features := QStyleOptionButtonFlat else Features := QStyleOptionButtonNone; if (uState and $1F) in [DFCS_BUTTONCHECK, DFCS_BUTTON3STATE] then Element := QStyleCE_CheckBox else if (DFCS_BUTTONRADIO and uState) <> 0 then Element := QStyleCE_RadioButton else if (DFCS_BUTTONPUSH and uState) <> 0 then Element := QStyleCE_PushButton else if (DFCS_BUTTONRADIOIMAGE and uState) <> 0 then Element := QStyleCE_RadioButton //TODO: what to implement here ? else if (DFCS_BUTTONRADIOMASK and uState) <> 0 then Element := QStyleCE_RadioButton //TODO: what to implement here ? ; Opt := QStyleOptionButton_create(); QStyleOptionButton_setFeatures(Opt, Features); QStyleOption_setRect(Opt, @Rect); QStyleOption_setState(Opt, State); QStyle_drawControl(QApplication_style(), Element, Opt, Painter, Widget); QStyleOptionButton_destroy(Opt); Result := True; end; function DrawScrollBarArrows: boolean; var Opt: QStyleOptionH; Element: QStylePrimitiveElement; State: QStyleState; begin Result := False; //TODO: DFCS_SCROLLCOMBOBOX and DFCS_SCROLLSIZEGRIP State := uStatetoQStyleState; Element := QStylePE_CustomBase; if (uState and $1F) in [DFCS_SCROLLUP] then Element := QStylePE_IndicatorArrowUp else if (uState and $1F) in [DFCS_SCROLLDOWN] then Element := QStylePE_IndicatorArrowDown else if (uState and $1F) in [DFCS_SCROLLLEFT] then Element := QStylePE_IndicatorArrowLeft else if (uState and $1F) in [DFCS_SCROLLRIGHT] then Element := QStylePE_IndicatorArrowRight; if Element = QStylePE_CustomBase then exit; Opt := QStyleOption_create(Ord(QStyleOptionVersion), Ord(QStyleOptionSO_Default)); QStyleOption_setRect(Opt, @Rect); QStyleOption_setState(Opt, State); QStyle_drawPrimitive(QApplication_style(), Element, Opt, Painter, Widget); QStyleOption_destroy(Opt); Result := True; end; begin Result := False; if not IsValidDC(DC) then exit; QtDC := TQtDeviceContext(DC); Painter := QtDC.Widget; Widget := QtDC.Parent; case uType of DFC_BUTTON: Result := DrawButton; DFC_CAPTION: ; // title bar captions DFC_MENU: ; // menu DFC_SCROLL: Result := DrawScrollBarArrows; end; end; {------------------------------------------------------------------------------ Method: DrawText Params: DC, Str, Count, Rect, Flags Returns: If the string was drawn, or CalcRect run if DT_CALCRECT is one of the Flags passed to this function, then: * DrawText should not draw the text, but determine the size that would be required to write it. * If there are multiple lines of text, this function will keep Rect.Width fixed and expand Rect.Height to fit the text. * If there is one line of text, Rect is reduced or expanded to fit it. * The result will the height of the text. ------------------------------------------------------------------------------} function TQtWidgetSet.DrawText(DC: HDC; Str: PChar; Count: Integer; var ARect: TRect; Flags: Cardinal): Integer; var WideStr: WideString; R: TRect; QtDC: TQtDeviceContext; F: Integer; Pt: TPoint; ClipRect: TRect; B: Boolean; procedure CalculateOffsetWithAngle(const AFontAngle: Integer; var TextLeft,TextTop: Integer); var OffsX, OffsY: integer; Angle: Integer; Size: TSize; begin OffsX := R.Right - R.Left; OffsY := R.Bottom - R.Top; Size.cX := OffsX; Size.cy := OffsY; Angle := AFontAngle div 10; if Angle < 0 then Angle := 360 + Angle; if Angle <= 90 then begin OffsX := 0; OffsY := Trunc(Size.cx * sin(Angle * Pi / 180)); end else if Angle <= 180 then begin OffsX := Trunc(Size.cx * -cos(Angle * Pi / 180)); OffsY := Trunc(Size.cx * sin(Angle * Pi / 180) + Size.cy * cos((180 - Angle) * Pi / 180)); end else if Angle <= 270 then begin OffsX := Trunc(Size.cx * -cos(Angle * Pi / 180) + Size.cy * sin((Angle - 180) * Pi / 180)); OffsY := Trunc(Size.cy * sin((270 - Angle) * Pi / 180)); end else if Angle <= 360 then begin OffsX := Trunc(Size.cy * sin((360 - Angle) * Pi / 180)); OffsY := 0; end; TextTop := OffsY; TextLeft := OffsX; end; begin {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI DrawText] DC: ', dbghex(DC), ' Str: ', string(Str), ' CalcRect: ', dbgs((Flags and DT_CALCRECT) = DT_CALCRECT),' ARect ',dbgs(ARect)); {$endif} Result := 0; if not IsValidDC(DC) then Exit; QtDC :=TQtDeviceContext(DC); if Count >= 0 then WideStr := {%H-}Copy(Str, 1, Count) else WideStr := Str; ClipRect := Rect(0, 0, 0, 0); B := QtDC.getClipping; if (Flags and DT_NOCLIP = DT_NOCLIP) and (Flags and DT_WORDBREAK = DT_WORDBREAK) and {if DT_CALCRECT is inlcuded we should avoid wrong calculation} (Flags and DT_CALCRECT = 0) then begin if B then ClipRect := QtDC.getClipRegion.getBoundingRect; //this is just to get same behaviour as gtk2 and win32 //IMO, we should change ARect.Left and/or ARect.Top if smaller than //clip rect (map to clipRect). Then multiline text is drawn ok. //look at issue http://bugs.freepascal.org/view.php?id=17678 . zeljko. if not B or (B and ((ARect.Left < ClipRect.Left) or (ARect.Top < ClipRect.Top))) then begin {$note remove ifdef if I'm wrong about DT_WORDBREAK OBSERVATION} {$IFDEF QT_DRAWTEXT_MAP_TO_CLIPRECT} if ARect.Left < ClipRect.Left then ARect.Left := ClipRect.Left; if ARect.Top < ClipRect.Top then ARect.Top := ClipRect.Top; {$ELSE} Flags := Flags and not DT_WORDBREAK; {$ENDIF} end; end; F := DTFlagsToQtFlags(Flags); QtDC.Metrics.BoundingRect(@R, @ARect, F, @WideStr); //TODO: result should be different when DT_VCENTER or DT_BOTTOM is set Result := R.Bottom - R.Top; if (Flags and DT_CALCRECT) = DT_CALCRECT then begin if (Flags and DT_WORDBREAK = DT_WORDBREAK) and ((R.Bottom - R.Top) > (ARect.Bottom - ARect.Top)) then // MSDN says do not touch rect width when we have DT_WORDBREAK flag // and new text is multiline (if R height > ARect height).See #17329. else ARect.Right := ARect.Left + R.Right - R.Left; ARect.Bottom := ARect.Top + R.Bottom - R.Top; {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI DrawText] Rect=', dbgs(ARect)); {$endif} Exit; end; // if our Font.Orientation <> 0 we must recalculate X,Y offset // also it works only with DT_TOP DT_LEFT. Qt can handle multiline // text in this case too. Pt := Point(0, 0); if (QtDC.Font.Angle <> 0) then begin if IsRectEmpty(ClipRect) and QtDC.getClipping then ClipRect := QtDC.getClipRegion.getBoundingRect; if EqualRect(ClipRect, ARect) then begin Pt := Point(ARect.Left, ARect.Top); CalculateOffsetWithAngle(QtDC.font.Angle, Pt.X, Pt.Y); end; end; // we cannot fit into rectangle, so use DT_SINGLELINE.See #17329. // http://msdn.microsoft.com/en-us/library/dd162498%28v=VS.85%29.aspx if B and (Flags and DT_NOCLIP = DT_NOCLIP) and (Flags and DT_WORDBREAK = DT_WORDBREAK) and (Flags and DT_SINGLELINE = DT_SINGLELINE) and ((R.Bottom - R.Top) >= (ARect.Bottom - ARect.Top)) then begin Flags := Flags and not DT_WORDBREAK; F := DTFlagsToQtFlags(Flags); end; if (Flags and DT_MODIFYSTRING = DT_MODIFYSTRING) and (Flags and DT_END_ELLIPSIS = DT_END_ELLIPSIS) and (Flags and DT_WORDBREAK = 0) then begin // windows are removing trailing spaces in this case // and we are doing same thing too. WideStr := TrimLeft(WideStr); with ARect do WideStr := QtDC.Metrics.elidedText(WideStr, QtElideRight, Right - Left, 0); end; QtDC.DrawText(ARect.Left + Pt.X, ARect.Top + Pt.Y, ARect.Right-ARect.Left, ARect.Bottom-ARect.Top, F, @WideStr); end; {------------------------------------------------------------------------------ Method: Ellipse Params: X1, Y1, X2, Y2 Returns: Nothing Use Ellipse to draw a filled circle or ellipse. ------------------------------------------------------------------------------} function TQtWidgetSet.Ellipse(DC: HDC; x1, y1, x2, y2: Integer): Boolean; var R: TRect; APenWidthF: QReal; ARectF: QRectFH; begin if not IsValidDC(DC) then Exit(False); R := NormalizeRect(Rect(X1, Y1, X2, Y2)); if IsRectEmpty(R) then Exit(True); APenWidthF := QPen_widthF(QPainter_pen(TQtDeviceContext(DC).Widget)); if APenWidthF = 0 then APenWidthF := 1; ARectF := QRectF_Create(R.Left, R.Top, R.Right - R.Left - 0.5, R.Bottom - R.Top - 0.5); QPainter_drawEllipse(TQtDeviceContext(DC).Widget, ARectF); QRectF_destroy(ARectF); Result := True; end; function TQtWidgetSet.EnableScrollBar(Wnd: HWND; wSBflags, wArrows: Cardinal): Boolean; begin {maybe we can put creating of scrollbar here instead of SetScrollInfo() } Result := False; {$ifdef VerboseQtWinAPI_MISSING_IMPLEMENTATION} WriteLn('***** [WinAPI TQtWidgetSet.EnableScrollbar] missing implementation '); {$endif} end; function TQtWidgetSet.EnableWindow(hWnd: HWND; bEnable: Boolean): Boolean; begin {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI EnableWindow] '); {$endif} Result := False; if HWND <> 0 then begin Result := not TQtWidget(hwnd).getEnabled; TQtWidget(hWnd).setEnabled(bEnable); end; end; {------------------------------------------------------------------------------ Function: EndPaint Params: Returns: ------------------------------------------------------------------------------} function TQtWidgetSet.EndPaint(Handle: hwnd; var PS: TPaintStruct): Integer; begin {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI EndPaint] Handle: ', dbghex(Handle), ' PS.HDC: ', dbghex(PS.HDC)); {$endif} Result := 1; if IsValidDC(PS.HDC) and (TObject(PS.HDC) is TQtDeviceContext) then begin {$ifdef VerboseQtWinAPI} WriteLn('Freeing resources'); {$endif} TQtDeviceContext(PS.HDC).Free; end; end; {------------------------------------------------------------------------------ Procedure: EnterCriticalSection Params: var CritSection: TCriticalSection Returns: Nothing ------------------------------------------------------------------------------} procedure TQtWidgetSet.EnterCriticalSection(var CritSection: TCriticalSection); var ACritSec: System.PRTLCriticalSection; begin ACritSec:=System.PRTLCriticalSection(CritSection); System.EnterCriticalsection(ACritSec^); end; function TQtWidgetSet.EnumDisplayMonitors(hdc: HDC; lprcClip: PRect; lpfnEnum: MonitorEnumProc; dwData: LPARAM): LongBool; var i: integer; Desktop: QScreenH; AArray: TPtrIntArray; begin Desktop := QGuiApplication_primaryScreen(); Result := True; QScreen_virtualSiblings(Desktop, @AArray); for i := 1 to length(AArray) do begin Result := lpfnEnum(i, 0, nil, dwData); if not Result then break; end; end; function CharsetToQtCharSet(const ALCLCharset: Byte): QFontDatabaseWritingSystem; begin Result := QFontDatabaseAny; case ALCLCharset of SYMBOL_CHARSET: Result := QFontDatabaseSymbol; FCS_ISO_8859_1 .. FCS_ISO_8859_4, FCS_ISO_8859_9,FCS_ISO_8859_10, FCS_ISO_8859_15, EASTEUROPE_CHARSET: Result := QFontDatabaseLatin; FCS_ISO_8859_5, RUSSIAN_CHARSET: Result := QFontDatabaseCyrillic; FCS_ISO_8859_6, ARABIC_CHARSET: Result := QFontDatabaseArabic; FCS_ISO_8859_7, GREEK_CHARSET: Result := QFontDatabaseGreek; FCS_ISO_8859_8, HEBREW_CHARSET: Result := QFontDatabaseHebrew; SHIFTJIS_CHARSET: Result := QFontDatabaseJapanese; HANGEUL_CHARSET: Result := QFontDatabaseKorean; GB2312_CHARSET: Result := QFontDatabaseSimplifiedChinese; CHINESEBIG5_CHARSET: Result := QFontDatabaseTraditionalChinese; THAI_CHARSET: Result := QFontDatabaseThai; end; end; function QtCharsetToCharset(AWritingSystem: QFontDatabaseWritingSystem; AList: TFPList): Byte; begin Result := DEFAULT_CHARSET; case AWritingSystem of QFontDatabaseAny: begin Result := FCS_ISO_10646_1; AList.Add(TObject(PtrUInt(Result))); end; QFontDatabaseSymbol: begin Result := SYMBOL_CHARSET; AList.Add(TObject(PtrUInt(Result))); end; QFontDatabaseThai: begin Result := THAI_CHARSET; AList.Add(TObject(PtrUInt(Result))); end; QFontDatabaseTraditionalChinese: begin Result := CHINESEBIG5_CHARSET; AList.Add(TObject(PtrUInt(Result))); end; QFontDatabaseSimplifiedChinese: begin Result := GB2312_CHARSET; AList.Add(TObject(PtrUInt(Result))); end; QFontDatabaseKorean: begin Result := HANGEUL_CHARSET; AList.Add(TObject(PtrUInt(Result))); end; QFontDatabaseJapanese: begin Result := SHIFTJIS_CHARSET; AList.Add(TObject(PtrUInt(Result))); end; QFontDatabaseHebrew: begin Result := HEBREW_CHARSET; AList.Add(TObject(PtrUInt(Result))); AList.Add(TObject(PtrUInt(FCS_ISO_8859_8))); end; QFontDatabaseGreek: begin Result := GREEK_CHARSET; AList.Add(TObject(PtrUInt(Result))); AList.Add(TObject(PtrUInt(FCS_ISO_8859_7))); end; QFontDatabaseArabic: begin Result := ARABIC_CHARSET; AList.Add(TObject(PtrUInt(Result))); end; QFontDatabaseCyrillic: begin Result := RUSSIAN_CHARSET; AList.Add(TObject(PtrUInt(Result))); AList.Add(TObject(PtrUInt(FCS_ISO_8859_5))); end; QFontDatabaseLatin: begin Result := FCS_ISO_10646_1; AList.Add(TObject(PtrUInt(Result))); AList.Add(TObject(PtrUInt(ANSI_CHARSET))); AList.Add(TObject(PtrUInt(FCS_ISO_8859_1))); AList.Add(TObject(PtrUInt(FCS_ISO_8859_2))); AList.Add(TObject(PtrUInt(FCS_ISO_8859_3))); AList.Add(TObject(PtrUInt(FCS_ISO_8859_4))); AList.Add(TObject(PtrUInt(FCS_ISO_8859_9))); AList.Add(TObject(PtrUInt(FCS_ISO_8859_10))); AList.Add(TObject(PtrUInt(FCS_ISO_8859_15))); AList.Add(TObject(PtrUInt(EASTEUROPE_CHARSET))); end; end; end; {------------------------------------------------------------------------------ Function: EnumFontFamiliesEx Params: hdc [in] Handle to the device context. lpLogfont [in] Pointer to a LOGFONT structure that contains information about the fonts to enumerate. The function examines the following members. Member Description lfCharset If set to DEFAULT_CHARSET, the function enumerates all fonts in all character sets. If set to a valid character set value, the function enumerates only fonts in the specified character set. lfFaceName If set to an empty string, the function enumerates one font in each available typeface name. If set to a valid typeface name, the function enumerates all fonts with the specified name. lfPitchAndFamily Must be set to zero for all language versions of the operating system. lpEnumFontFamExProc [in] Pointer to the application definedcallback function. For more information, see the EnumFontFamExProc function. lParam [in] Specifies an applicationdefined value. The function passes this value to the callback function along with font information. dwFlags This parameter is not used and must be zero. Returns: The return value is the last value returned by the callback function. This value depends on which font families are available for the specified device. ------------------------------------------------------------------------------} function TQtWidgetSet.EnumFontFamiliesEx(DC: HDC; lpLogFont: PLogFont; Callback: FontEnumExProc; Lparam: LParam; Flags: dword): longint; var EnumLogFont: TEnumLogFontEx; Metric: TNewTextMetricEx; FontList: TStringList; FontType: Integer; i: Integer; y: Integer; AStyle: String; StylesCount: Integer; StylesList: QStringListH; ScriptList: QStringListH; CharsetList: TFPList; function QtGetFontFamiliesDefault(var List:TStringList; const AWritingSystem: QFontDatabaseWritingSystem = QFontDatabaseAny):integer; var StrLst: QStringlistH; WStr: WideString; j: integer; begin Result := -1; StrLst := QStringList_create; try QFontDatabase_families(StrLst, AWritingSystem); Result := QStringList_size(StrLst); for j := 0 to Result - 1 do begin QStringList_at(StrLst, @WStr, j); List.Add(UTF16ToUTF8(WStr)); end; finally QStringList_destroy(StrLst); end; end; function QtGetFontFamilies(var List: TStringList; const APitch: Byte; const AFamilyName: String; const AWritingSystem: QFontDatabaseWritingSystem = QFontDatabaseAny): Integer; var StrLst: QStringlistH; NewList: QStringListH; WStr: WideString; j: integer; begin Result := -1; StrLst := QStringList_create(); NewList := QStringList_create(); try QFontDatabase_families(StrLst, AWritingSystem); for j := 0 to QStringList_size(StrLst) - 1 do begin QStringList_at(StrLst, @WStr, j); if APitch <> DEFAULT_PITCH then begin case APitch of FIXED_PITCH, MONO_FONT: begin if QFontDatabase_isFixedPitch(@WStr) then QStringList_append(NewList, @WStr); end; VARIABLE_PITCH: begin if QFontDatabase_isScalable(@WStr) then QStringList_append(NewList, @WStr); end; end; end else QStringList_append(NewList, @WStr); end; if AFamilyName <> '' then begin for j := QStringList_size(NewList) - 1 downto 0 do begin QStringList_at(NewList, @WStr, j); if UTF16ToUTF8(WStr) <> AFamilyName then QStringList_removeAt(NewList, j); end; end; for j := 0 to QStringList_size(NewList) - 1 do begin QStringList_at(NewList, @WStr, j); List.Add(UTF16ToUTF8(WStr)); end; Result := List.Count; finally QStringList_destroy(StrLst); QStringList_destroy(NewList); end; end; function GetStyleAt(AIndex: Integer): String; var WStr: WideString; begin Result := ''; if (AIndex >= 0) and (AIndex < QStringList_size(StylesList)) then begin QStringList_at(StylesList, @WStr, AIndex); Result := UTF16ToUTF8(WStr); end; end; function GetWritingSystems(AFontName: String; AList: QStringListH; ACharsetList: TFPList): Boolean; var WStr: WideString; Arr: TPtrIntArray; j: Integer; begin Result := False; QStringList_clear(AList); if Assigned(CharSetList) then CharSetList.Clear; WStr := UTF8ToUTF16(AFontName); QFontDatabase_writingSystems(@Arr, @WStr); Result := length(Arr) > 0; for j := 0 to High(Arr) do begin if Assigned(ACharsetList) then QtCharsetToCharset(QFontDatabaseWritingSystem(Arr[j]), ACharsetList); QFontDatabase_writingSystemName(@WStr, QFontDatabaseWritingSystem(Arr[j])); QStringList_append(AList, @WStr); end; end; function FillLogFontA(AFontName: String; var ALogFontA: TLogFontA; var AMetric: TNewTextMetricEx; var AFontType: Integer; out AStyle: String): Integer; var Font: QFontH; WStr: WideString; begin WStr := UTF8ToUTF16(AFontName); Font := QFont_create(@WStr); ALogFontA.lfItalic := Byte(QFont_italic(Font)); ALogFontA.lfWeight := QFont_weight(Font); ALogFontA.lfHeight := QFont_pointSize(Font); ALogFontA.lfUnderline := Byte(QFont_underline(Font)); ALogFontA.lfStrikeOut := Byte(QFont_strikeOut(Font)); if QFont_styleStrategy(Font) = QFontPreferBitmap then AFontType := AFontType or RASTER_FONTTYPE; if QFont_styleStrategy(Font) = QFontPreferDevice then AFontType := AFontType or DEVICE_FONTTYPE; if not (QFont_styleStrategy(Font) = QFontPreferDefault) then AFontType := AFontType and not TRUETYPE_FONTTYPE; QStringList_clear(StylesList); QFontDatabase_styles(StylesList, @WStr); AStyle := ''; Result := QStringList_size(StylesList); if Result > 0 then AStyle := GetStyleAt(0); // fill script and charset list GetWritingSystems(AFontName, ScriptList, CharsetList); QFont_destroy(Font); end; begin {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI EnumFontFamiliesEx] Charset=',lpLogFont^.lfCharSet, ' face ',lpLogFont^.lfFaceName,' pitchAndFamily=',lpLogFont^.lfPitchAndFamily); {$endif} Result := 0; Metric.ntmentm.ntmAvgWidth := 0; // just to shutup compiler if (lpLogFont^.lfCharSet = DEFAULT_CHARSET) and (lpLogFont^.lfFaceName= '') and (lpLogFont^.lfPitchAndFamily = 0) then begin FontType := 0; FontList := TStringList.create; try if QtGetFontFamiliesDefault(FontList) > 0 then begin for i := 0 to FontList.Count - 1 do begin EnumLogFont.elfLogFont.lfFaceName := FontList[i]; Result := Callback(EnumLogFont, Metric, FontType, LParam); end; end; finally FontList.free; end; end else begin Result := 0; FontType := TRUETYPE_FONTTYPE; FontList := TStringList.create; StylesList := QStringList_create(); ScriptList := QStringList_create(); CharsetList := TFPList.Create; try if QtGetFontFamilies(FontList, lpLogFont^.lfPitchAndFamily, lpLogFont^.lfFaceName, CharsetToQtCharSet(lpLogFont^.lfCharSet)) > 0 then begin for i := 0 to FontList.Count - 1 do begin EnumLogFont.elfLogFont.lfFaceName := FontList[i]; EnumLogFont.elfLogFont.lfPitchAndFamily := lpLogFont^.lfPitchAndFamily; EnumLogFont.elfFullName := FontList[i]; StylesCount := FillLogFontA(FontList[i], EnumLogFont.elfLogFont, Metric, FontType, AStyle); EnumLogFont.elfStyle := AStyle; if CharSetList.Count > 0 then EnumLogFont.elfLogFont.lfCharSet := {%H-}PtrUInt(CharsetList.Items[0]); Result := Callback(EnumLogFont, Metric, FontType, LParam); for y := 1 to StylesCount - 1 do begin AStyle := GetStyleAt(y); EnumLogFont.elfStyle := AStyle; Result := Callback(EnumLogFont, Metric, FontType, LParam); end; for y := 1 to CharsetList.Count - 1 do begin EnumLogFont.elfLogFont.lfCharSet := {%H-}PtrUInt(CharsetList.Items[y]); Result := Callback(EnumLogFont, Metric, FontType, LParam); end; end; end; finally FontList.free; QStringList_destroy(StylesList); QStringList_destroy(ScriptList); CharSetList.Free; end; end; end; {------------------------------------------------------------------------------ Function: ExcludeClipRect Params: none Returns: Nothing ------------------------------------------------------------------------------} function TQtWidgetSet.ExcludeClipRect(dc: hdc; Left, Top, Right, Bottom : Integer) : Integer; var Region: QRegionH; ClipRegion: QRegionH; ExRegion: QRegionH; QtDC: TQtDeviceContext; R: TRect; begin {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI ExcludeClipRect]'); {$endif} Result := ERROR; if not IsValidDC(DC) then Exit; QtDC := TQtDeviceContext(DC); {ExcludeClipRect on X11 paint engine is pretty slow with complex regions eg. setting clipRegion with hundreds of rects (usually created by calling ExcludeClipRect for many children on widget) dramatically kills performance of our application. To get rid of it we are using trick from webkit. If numRects is over 25 then create an new rect region with boundsRect of NewRegion. see issue http://bugs.freepascal.org/view.php?id=19698. If you want accurate ExcludeClipRect use graphicssystem Raster or see comment in TQtWidgetSet.ExtSelectClipRgn} ExRegion := QRegion_create(Left, Top, Right - Left, Bottom - Top, QRegionRectangle); Region := QRegion_create; ClipRegion := QRegion_create; try QPainter_clipRegion(QtDC.Widget, ClipRegion); QRegion_subtracted(ClipRegion, Region, ExRegion); // only for X11 paintEngine. if (QPaintEngine_type(QtDC.PaintEngine) = QPaintEngineX11) and not QRegion_isEmpty(Region) and (QRegion_numRects(Region) > 25) then begin QRegion_boundingRect(Region, @R); QRegion_setRects(Region, @R, 1); end; QtDC.setClipRegion(Region); QtDC.setClipping(True); if QRegion_isEmpty(Region) then Result := NULLREGION else if QRegion_numRects(Region) = 1 then Result := SIMPLEREGION else Result := COMPLEXREGION; finally QRegion_destroy(ClipRegion); QRegion_destroy(Region); QRegion_destroy(ExRegion); end; end; function TQtWidgetSet.ExtCreatePen(dwPenStyle, dwWidth: DWord; const lplb: TLogBrush; dwStyleCount: DWord; lpStyle: PDWord): HPEN; var QtPen: TQtPen; color: TQColor; begin Result := 0; QtPen := TQtPen.Create(True); QtPen.IsExtPen := True; case dwPenStyle and PS_STYLE_MASK of PS_SOLID: QtPen.setStyle(QtSolidLine); PS_DASH: QtPen.setStyle(QtDashLine); PS_DOT: QtPen.setStyle(QtDotLine); PS_DASHDOT: QtPen.setStyle(QtDashDotLine); PS_DASHDOTDOT: QtPen.setStyle(QtDashDotDotLine); PS_USERSTYLE: QtPen.setStyle(QtCustomDashLine); PS_NULL: QtPen.setStyle(QtNoPen); end; QtPen.setCosmetic((dwPenStyle and PS_TYPE_MASK) = PS_COSMETIC); if (dwPenStyle and PS_TYPE_MASK) = PS_GEOMETRIC then begin QtPen.setWidth(dwWidth); case dwPenStyle and PS_JOIN_MASK of PS_JOIN_ROUND: QtPen.setJoinStyle(QtRoundJoin); PS_JOIN_BEVEL: QtPen.setJoinStyle(QtBevelJoin); PS_JOIN_MITER: QtPen.setJoinStyle(QtMiterJoin); end; case dwPenStyle and PS_ENDCAP_MASK of PS_ENDCAP_ROUND: QtPen.setCapStyle(QtRoundCap); PS_ENDCAP_SQUARE: QtPen.setCapStyle(QtSquareCap); PS_ENDCAP_FLAT: QtPen.setCapStyle(QtFlatCap); end; end; if (dwPenStyle and PS_STYLE_MASK) = PS_USERSTYLE then QtPen.setDashPattern(lpStyle, dwStyleCount); QPen_Color(QtPen.FHandle, @Color); ColorRefToTQColor(ColorToRGB(TColor(lplb.lbColor)), Color); QPen_setColor(QtPen.FHandle, @Color); Result := HPEN(QtPen); end; function TQtWidgetSet.ExtSelectClipRGN(dc: hdc; rgn : hrgn; Mode : Longint) : Integer; var Clip: HRGN = 0; Tmp : hRGN; DCOrigin: TPoint; QtWidget: TQtWidget = nil; QtDC: TQtDeviceContext; QtRgn: TQtRegion; R: TRect; begin {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI TQtWidgetSet.ExtSelectClipRGN]'); {$endif} if not IsValidDC(DC) then begin Result := ERROR; exit; end else Result := SIMPLEREGION; QtDC := TQtDeviceContext(DC); if Assigned(QtDC.Parent) then QtWidget := QtObjectFromWidgetH(QtDC.Parent); if Assigned(QtWidget) or (not Assigned(QtWidget) and Assigned(QtDC.vImage)) then begin // there is no clipping region in the DC case Mode of RGN_COPY: Result := SelectClipRGN(DC, RGN); RGN_OR, RGN_XOR, RGN_AND: begin // as MSDN says only RGN_COPY allows NULL RGN param. if not IsValidGDIObject(RGN) then begin Result := ERROR; exit; end; // get existing clip QtRgn := QtDC.getClipRegion; if (QtRgn = nil) or (QtRgn.GetRegionType = NULLREGION) then begin Result := SelectClipRGN(DC, RGN); exit; end; // get transformation GetWindowOrgEx(DC, @DCOrigin); R := QtRgn.getBoundingRect; Clip := CreateRectRGN(0, 0, R.Right - R.Left, R.Bottom - R.Top); TQtRegion(Clip).translate(DCOrigin.X, DCOrigin.Y); // create target clip Tmp := CreateEmptyRegion; // combine Result := CombineRGN(Tmp, Clip, RGN, Mode); // commit SelectClipRGN(DC, Tmp); // clean up DeleteObject(Clip); DeleteObject(Tmp); end; RGN_DIFF: begin // when substracting we must have active clipregion // with all of its rects. QtRgn := QtDC.getClipRegion; if (QtRgn = nil) or (QtRgn.GetRegionType = NULLREGION) then begin Result := SelectClipRGN(DC, RGN); exit; end; Tmp := CreateEmptyRegion; Result := CombineRGN(Tmp, HRGN(QtRgn), RGN, MODE); // X11 paintEngine comment only ! // we'll NOT reset num of rects here (performance problem) like we do // in ExcludeClipRect, because this function must be correct, // if someone want accurate ExcludeClipRect with X11 then // use code from intfbasewinapi.inc TWidgetSet.ExcludeClipRect() // which calls this function and then combineRgn. SelectClipRGN(DC, Tmp); DeleteObject(Tmp); end; end; end else Result := inherited ExtSelectClipRGN(DC, RGN, Mode); end; {------------------------------------------------------------------------------ Function: ExtTextOut Params: none Returns: Nothing ------------------------------------------------------------------------------} function TQtWidgetSet.ExtTextOut(DC: HDC; X, Y: Integer; Options: Longint; Rect: PRect; Str: PChar; Count: Longint; Dx: PInteger): Boolean; var WideStr: WideString; QtDC: TQtDeviceContext absolute DC; R, R1: TRect; ALayout: QtLayoutDirection; B: boolean; APen: QPenH; procedure DoDrawCharByChar(const AClipped: Boolean); var CurX, CharLen: Integer; CurCount: LongInt; CurDx: PInteger; CurStr: PChar; W: WideString; begin CurDx := Dx; CurStr := Str; CurCount := Count; CurX := X; while CurCount > 0 do begin CharLen := UTF8CodepointSize(CurStr); W := {%H-}Copy(CurStr, 1, CharLen); if AClipped then QtDC.drawText(CurX, Y, Rect^.Right - Rect^.Left, Rect^.Bottom - Rect^.Top, QtTextDontClip, @W) else QtDC.drawText(CurX, Y, @W); inc(CurX, CurDx^); inc(CurDx); inc(CurStr, CharLen); dec(CurCount, CharLen); end; end; begin {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI ExtTextOut]'); {$endif} Result := False; if not IsValidDC(DC) then Exit; B := False; if ((Options and (ETO_OPAQUE + ETO_CLIPPED)) <> 0) and (Rect = nil) then begin if Count >= 0 then WideStr := {%H-}Copy(Str, 1, Count) else WideStr := Str; R := QtDC.getClipRegion.getBoundingRect; QtDC.font.Metrics.boundingRect(@R1, @R, 0, @WideStr); B := True; Rect := @R1; end; if ((Options and ETO_OPAQUE) <> 0) and (Rect <> nil) then begin if B then QtDC.fillRect(X, Y, Rect^.Right - Rect^.Left, Rect^.Bottom - Rect^.Top) else QtDC.fillRect(Rect^.Left, Rect^.Top, Rect^.Right - Rect^.Left, Rect^.Bottom - Rect^.Top); end; if Str <> nil then begin ALayout := QPainter_layoutDirection(QtDC.Widget); if Options and ETO_RTLREADING <> 0 then QPainter_setLayoutDirection(QtDC.Widget, QtRightToLeft); if Count >= 0 then WideStr := {%H-}Copy(Str, 1, Count) else WideStr := Str; //optimization APen := QPen_Create(QPainter_pen(QtDC.Widget)); QtDC.SetTextPen; QtDC.PenTextInternal := False; if (Options and ETO_CLIPPED <> 0) then begin QtDC.save; try QtDC.setClipRect(Rect^); if Dx <> nil then DoDrawCharByChar(True) else QtDC.drawText(X, Y, Rect^.Right - Rect^.Left, Rect^.Bottom - Rect^.Top, QtTextDontClip, @WideStr); finally QtDC.Restore; end; end else begin if Dx <> nil then DoDrawCharByChar(False) else QtDC.drawText(X, Y, @WideStr); end; QPainter_setPen(QtDC.Widget, APen); QPen_destroy(APen); QtDC.PenTextInternal := True; if Options and ETO_RTLREADING <> 0 then QPainter_setLayoutDirection(QtDC.Widget, ALayout); end; Result := True; end; {------------------------------------------------------------------------------ Function: FillRect Params: none Returns: Nothing ------------------------------------------------------------------------------} function TQtWidgetSet.FillRect(DC: HDC; const Rect: TRect; Brush: HBRUSH): Boolean; begin Result := False; {$ifdef VerboseQtWinAPI} DebugLn('[WinAPI FillRect Rect=', dbgs(Rect),' Brush=', dbghex(Brush)); {$endif} if not IsValidDC(DC) then exit; if not IsValidGdiObject(Brush) then exit; TQtDeviceContext(DC).fillRect(@Rect, TQtBrush(Brush).FHandle); Result := True; end; {------------------------------------------------------------------------------ Function: FillRgn Params: DC: HDC; RegionHnd: HRGN; hbr: HBRUSH Returns: Boolean ------------------------------------------------------------------------------} function TQtWidgetSet.FillRgn(DC: HDC; RegionHnd: HRGN; hbr: HBRUSH): Bool; var OldRgn: TQtRegion; R: TRect; hasClipping: Boolean; QtDC: TQtDeviceContext; APath: QPainterPathH; APolyFH: QPolygonFH; begin {$ifdef VerboseQtWinAPI} DebugLn('[WinAPI FillRgn Rgn=', dbgs(RegionHnd),' Brush=', dbghex(hbr)); {$endif} Result := False; if not IsValidDC(DC) then exit; QtDC := TQtDeviceContext(DC); HasClipping := QtDC.getClipping; QtDC.save; if HasClipping then OldRgn := TQtRegion.Create(True) else OldRgn := nil; try if HasClipping then QPainter_clipRegion(QtDC.Widget, OldRgn.FHandle); if SelectClipRgn(DC, RegionHnd) <> ERROR then begin if TQtRegion(RegionHnd).IsPolyRegion then begin APath := QPainterPath_create(); APolyFH := QPolygonF_create(TQtRegion(RegionHnd).Polygon); try QPainterPath_addPolygon(APath, APolyFH); QPainter_fillPath(QtDC.Widget, APath, TQtBrush(hbr).FHandle); finally QPainterPath_destroy(APath); QPolygonF_destroy(APolyFH); end; end else begin R := TQtRegion(RegionHnd).getBoundingRect; QtDC.fillRect(@R, TQtBrush(hbr).FHandle); end; if HasClipping then SelectClipRgn(DC, HRGN(OldRgn)); Result := True; end; finally if HasClipping then OldRgn.Free; QtDC.restore; end; end; {------------------------------------------------------------------------------ Function: Frame3D Params: none Returns: Nothing Draws a 3d border in Qt native style. ------------------------------------------------------------------------------} function TQtWidgetSet.Frame3d(DC: HDC; var ARect: TRect; const FrameWidth: integer; const Style: TBevelCut): Boolean; var QtDC: TQtDeviceContext; AWidget: HWND; ATransparent: Boolean; begin {$ifdef VerboseQtWinAPI} DebugLn('[TQtWidgetSet.Frame3d Rect=', dbgs(ARect)); {$endif} Result := False; if not IsValidDC(DC) then exit; QtDC := TQtDeviceContext(DC); // issue #26491, draw opaque TCustomPanel if csOpaque is setted up in control style // otherwise use brush and painter backgroundmode settings. ATransparent := True; if (QtDC.Parent <> nil) and QObject_isWidgetType(QtDC.Parent) then begin AWidget := HwndFromWidgetH(QtDC.Parent); if (AWidget <> 0) and Assigned(TQtWidget(AWidget).LCLObject) then begin ATransparent := not (csOpaque in TQtWidget(AWidget).LCLObject.ControlStyle); // issue #26607 if ATransparent and (TQtWidget(AWidget).LCLObject is TCustomPanel) and (TQtWidget(AWidget).LCLObject.Color <> clDefault) and not TCustomPanel(TQtWidget(AWidget).LCLObject).ParentColor then ATransparent := False; end; end; case Style of bvNone: ; bvLowered: QtDC.qDrawWinPanel(ARect.Left, ARect.Top, ARect.Right - ARect.Left, ARect.Bottom - ARect.Top, ATransparent, nil, True, FrameWidth); bvRaised: QtDC.qDrawWinPanel(ARect.Left, ARect.Top, ARect.Right - ARect.Left, ARect.Bottom - ARect.Top, ATransparent, nil, False, FrameWidth); bvSpace: QtDC.qDrawPlainRect(ARect.Left, ARect.Top, ARect.Right - ARect.Left, ARect.Bottom - ARect.Top, nil, FrameWidth); end; InflateRect(ARect, -FrameWidth, -FrameWidth); Result := True; end; {------------------------------------------------------------------------------ Function: FrameRect Params: none Returns: Nothing ------------------------------------------------------------------------------} function TQtWidgetSet.FrameRect(DC: HDC; const ARect: TRect; hBr: HBRUSH): Integer; var AColor: PQColor; begin Result := 0; if not IsValidDC(DC) then Exit; if IsValidGDIObject(hBr) then AColor := TQtBrush(HBR).getColor else AColor := nil; TQtDeviceContext(DC).qDrawPLainRect(ARect.Left, ARect.Top, ARect.Right - ARect.Left, ARect.Bottom - ARect.Top, AColor); Result := 1; end; function TQtWidgetSet.GetActiveWindow: HWND; var Widget: QWidgetH; W: TQtWidget; SubW: TQtWidget; Area: QMdiAreaH; begin Result := 0; Widget := QApplication_activeWindow; {return modal if activeWindow is nil issue #33409} if Widget = nil then Widget := QApplication_activeModalWidget; if Widget = nil then Widget := QApplication_activePopupWidget; if Widget <> nil then begin W := QtObjectFromWidgetH(Widget); if Assigned(W) and IsValidHandle(HWND(W)) then begin if (TQtWidget(W) is TQtMainWindow) and Assigned(TQtMainWindow(W).MDIAreaHandle) then begin Area := QMdiAreaH(TQtMainWindow(W).MDIAreaHandle.Widget); SubW := QtObjectFromWidgetH(QMdiArea_activeSubWindow(Area)); if SubW <> nil then Result := HWND(SubW) else Result := HWND(W); end else Result := HWND(W); end; end; end; {------------------------------------------------------------------------------ Method: TQtWidgetSet.GetBitmapBits Params: none Returns: ------------------------------------------------------------------------------} function TQtWidgetSet.GetBitmapBits(Bitmap: HBITMAP; Count: Longint; Bits: Pointer): Longint; var Image: QImageH; begin {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI GetBitmapBits]',' Bitmap=', dbghex(Bitmap),' Count=',Count); {$endif} Result := 0; if (Bitmap = 0) or (Count <= 0) then Exit; Image := QImage_create(TQtImage(Bitmap).Handle); try Result := (QImage_width(Image) * QImage_height(Image) * QImage_depth(Image) + 7) div 8; if Count < Result then Result := Count; if Result > 0 then Move(QImage_constBits(Image)^, Bits^, Result); finally QImage_destroy(Image); end; end; function TQtWidgetSet.GetBkColor(DC: HDC): TColorRef; var QtDC: TQtDeviceContext; begin Result := CLR_INVALID; if not IsValidDC(DC) then Exit; QtDC := TQtDeviceContext(DC); Result := QtDC.GetBkColor; end; function TQtWidgetSet.GetCapture: HWND; var w: QWidgetH; Widget: TQtWidget; begin w := QWidget_mouseGrabber(); if w <> nil then begin // Capture widget can be child of complex control. In any case we should return TQtWidget as result. // So we will look for parent while not found apropriate LCL handle. Widget := GetFirstQtObjectFromWidgetH(w); Result := HWND(Widget); end else Result := 0; {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI GetCapture] Capture = ', Result); {$endif} end; function TQtWidgetSet.GetCaretPos(var lpPoint: TPoint): Boolean; begin Result := QtCaret.GetCaretPos(lpPoint); end; function TQtWidgetSet.GetCaretRespondToFocus(handle: HWND; var ShowHideOnFocus: boolean): Boolean; begin ShowHideOnFocus := QtCaret.GetQtCaretRespondToFocus; Result := True; end; {------------------------------------------------------------------------------ Function: GetClientBounds Params: handle: Result: Returns: true on success Returns the client bounds of a control. The client bounds is the rectangle of the inner area of a control, where the child controls are visible. The coordinates are relative to the control's left and top. ------------------------------------------------------------------------------} function TQtWidgetSet.GetClientBounds(handle : HWND; var ARect : TRect) : Boolean; begin {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI GetClientBounds]'); {$endif} if Handle = 0 then Exit(False); ARect := TQtWidget(handle).getClientBounds; Result := True; end; {------------------------------------------------------------------------------ Function: GetClientRect Params: handle: Result: Returns: true on success Returns the client bounds of a control. The client bounds is the rectangle of the inner area of a control, where the child controls are visible. The coordinates are relative to the control's left and top. ------------------------------------------------------------------------------} function TQtWidgetSet.GetClientRect(handle : HWND; var ARect : TRect) : Boolean; begin {$ifdef VerboseQtWinAPI} WriteLn('[WinAPI GetClientRect]'); {$endif} if Handle = 0 then Exit(False); GetClientBounds(Handle, ARect); Types.OffsetRect(ARect, -ARect.Left, -ARect.Top); Result := True; end; {------------------------------------------------------------------------------ Function: GetClipBox Params: dc, lprect Returns: Integer Returns the smallest rectangle which includes the entire current Clipping Region, or if no Clipping Region is set, the current dimensions of the Drawable. The result can be one of the following constants Error NullRegion SimpleRegion ComplexRegion ------------------------------------------------------------------------------} function TQtWidgetSet.GetClipBox(DC: hDC; lpRect: PRect): Longint; var ARegion: QRegionH; Pt: TPoint; begin Result := NULLREGION; if lpRect <> nil then lpRect^ := Rect(0,0,0,0); if not IsValidDC(DC) then Result := ERROR; if Result <> ERROR then with TQtDeviceContext(DC) do begin {$ifdef VerboseQtWinAPI} Writeln('TQtWidgetSet.GetClipBox FastClip=', ((vClipRect <> nil) and not vClipRectDirty) ); {$endif} // the most correct way to get a clipbox if through // region.boundingrect, but it's slower. // TODO: remove "and false" below when vClipRectDirty is implemented // it should be "true" when user set a custom clip rect // and "false" on beginpaint if (vClipRect<>nil) and not vClipRectDirty and false then lpRect^ := vClipRect^ else if getClipping then begin ARegion := QRegion_Create; try QPainter_clipRegion(Widget, ARegion); GetWindowOrgEx(DC, @Pt); if (Pt.X <> 0) or (Pt.Y <> 0) then SetWindowOrgEx(DC, Pt.X, Pt.Y, @Pt); QRegion_boundingRect(ARegion, lpRect); finally QRegion_destroy(ARegion); end; Result := SIMPLEREGION; end else if vImage <> nil then begin lpRect^ := Rect(0, 0, vImage.width, vImage.height); Result := SIMPLEREGION; end; {$ifdef VerboseQtWinAPI} WriteLn('TQtWidgetSet.GetClipBox Rect=', dbgs(lprect^)); {$endif} end; end; {------------------------------------------------------------------------------ Function: GetClipRGN Params: dc, rgn Returns: Integer Returns a copy of the current Clipping Region. The result can be one of the following constants 0 = no clipping set 1 = ok -1 = error ------------------------------------------------------------------------------} function TQtWidgetSet.GetClipRGN(DC : hDC; RGN : hRGN): Longint; begin {$ifdef VerboseQtWinAPI} Writeln('Trace: [WinAPI GetClipRgn]', ' DC: ', dbghex(DC), ' RGN: ', dbghex(Rgn)); if RGN<>0 then WriteLn(' QRegionH=', PtrInt(TQtRegion(Rgn).FHandle)) else WriteLn(' Rgn=0'); {$endif} // it assumes that clipregion object has been created some other place Result := -1; if not IsValidDC(DC) then exit; if Rgn = 0 then exit; if not TQtDeviceContext(DC).getClipping then Result := 0 else begin // if our TQtRegion contains widget then // first destroy it because QPainter creates // new reference. if TQtRegion(Rgn).FHandle <> nil then begin QRegion_destroy(TQtRegion(Rgn).FHandle); TQtRegion(Rgn).FHandle := QRegion_create; end; QPainter_clipRegion(TQtDeviceContext(DC).Widget, TQtRegion(Rgn).FHandle); Result := 1; end; end; function TQtWidgetSet.GetCmdLineParamDescForInterface: TStringList; begin result := TStringList.Create; AddCmdLineParamDesc(result, ['-nograb'], rsqtOptionNoGrab); AddCmdLineParamDesc(result, ['-dograb'], rsqtOptionDoGrab); AddCmdLineParamDesc(result, ['-sync'], rsqtOptionSync); AddCmdLineParamDesc(result, ['-style