From: <tw...@us...> - 2021-02-20 16:47:16
|
Revision: 3436 http://sourceforge.net/p/gexperts/code/3436 Author: twm Date: 2021-02-20 16:47:13 +0000 (Sat, 20 Feb 2021) Log Message: ----------- synced with latest dzlib version from OSDN Modified Paths: -------------- trunk/ExternalSource/dzlib/dzlib.inc trunk/ExternalSource/dzlib/u_dzClassUtils.pas trunk/ExternalSource/dzlib/u_dzConvertUtils.pas trunk/ExternalSource/dzlib/u_dzFileStreams.pas trunk/ExternalSource/dzlib/u_dzGraphicsUtils.pas trunk/ExternalSource/dzlib/u_dzMiscUtils.pas trunk/ExternalSource/dzlib/u_dzSelectDirectoryFix.pas trunk/ExternalSource/dzlib/u_dzTypes.pas trunk/ExternalSource/dzlib/u_dzVclUtils.pas trunk/ExternalSource/dzlib/u_dzVersionInfo.pas Modified: trunk/ExternalSource/dzlib/dzlib.inc =================================================================== --- trunk/ExternalSource/dzlib/dzlib.inc 2021-02-20 11:51:37 UTC (rev 3435) +++ trunk/ExternalSource/dzlib/dzlib.inc 2021-02-20 16:47:13 UTC (rev 3436) @@ -51,8 +51,8 @@ {$ENDIF} {$ENDIF} -{$IFDEF DELPHIX_TOKYO_UP} -{$DEFINE FILECTRL_DIRECTORYEXISTS_IS_DEPRECATED} +{$IFDEF DELPHI2007_UP} +{$DEFINE HAS_INTTOHEX_FUNCTION} {$ENDIF} // The following cond. defines address errors in various Delphi versions regarding the declaration @@ -62,8 +62,6 @@ // THandleStream.FHandle is declared as THandle (before that it's an Integer) {$DEFINE THANDLESTREAM_HANDLE_IS_THANDLE} {$DEFINE HAS_TOBJECT_TOSTRING} -// TMonitor.PixelsPerInch probably didn't exist in Delphi 2009, it does exist in Delphi 10.2 adjust as necessary -{$DEFINE HAS_TMONITOR_PIXELSPERINCH} {$ENDIF} {$IFDEF DELPHIXE_UP} @@ -76,14 +74,22 @@ {$DEFINE MAXLISTSIZE_IS_DEPRECATED} {$ENDIF} +{$IFDEF DELPHIXE3_UP} +// TMonitor.PixelsPerInch probably didn't exist in Delphi XE3, it does exist in Delphi 10.2 adjust as necessary +{$DEFINE HAS_TMONITOR_PIXELSPERINCH} +{$ENDIF} + {$IFDEF DELPHIXE6_UP} {$DEFINE JSONOBJECT_HAS_COUNT} {$ENDIF} {$IFDEF DELPHIX_TOKYO_UP} +{$DEFINE FILECTRL_DIRECTORYEXISTS_IS_DEPRECATED} +{$ENDIF} + +{$IFDEF DELPHIX_TOKYO_UP} // this function probably already existed in earlier versions, I just run across a compile error for 10.2 Tokyo -{$DEFINE HAS_INTTOHEX_FUNCTION} -{$DEFINE HAS_INTTOHEX_FUNCTION_64} +{$DEFINE HAS_INTTOHEX_FUNCTION_UINT64} {$ENDIF} {$IFOPT T+} Modified: trunk/ExternalSource/dzlib/u_dzClassUtils.pas =================================================================== --- trunk/ExternalSource/dzlib/u_dzClassUtils.pas 2021-02-20 11:51:37 UTC (rev 3435) +++ trunk/ExternalSource/dzlib/u_dzClassUtils.pas 2021-02-20 16:47:13 UTC (rev 3436) @@ -2208,4 +2208,3 @@ end; end. - Modified: trunk/ExternalSource/dzlib/u_dzConvertUtils.pas =================================================================== --- trunk/ExternalSource/dzlib/u_dzConvertUtils.pas 2021-02-20 11:51:37 UTC (rev 3435) +++ trunk/ExternalSource/dzlib/u_dzConvertUtils.pas 2021-02-20 16:47:13 UTC (rev 3436) @@ -150,6 +150,18 @@ /// Reduces an Integer to a Byte value by cutting it off at 0 and 255 </summary> function ReduceToByte(const _Value: Integer): Byte; {$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} +function ReduceToInt8(const _Value: Integer): Int8; +{$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} +function ReduceToUInt8(const _Value: Integer): UInt8; +{$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} +function ReduceToInt16(const _Value: Integer): Int16; +{$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} +function ReduceToUInt16(const _Value: Integer): UInt16; +{$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} +function ReduceToInt32(const _Value: Int64): Int32; +{$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} +function ReduceToUInt32(const _Value: Int64): UInt32; +{$IFDEF SUPPORTS_INLINE}inline;{$ENDIF} ///<summary> /// Converts a string of the form '-hh:mm:ss', 'hh:mm:ss', @@ -605,14 +617,69 @@ function ReduceToByte(const _Value: Integer): Byte; begin + Result := ReduceToUInt8(_Value); +end; + +function ReduceToUInt8(const _Value: Integer): UInt8; +begin if _Value < 0 then Result := 0 - else if _Value > 255 then - Result := 255 + else if _Value > MaxUInt8 then + Result := MaxUInt8 else Result := _Value; end; +function ReduceToInt8(const _Value: Integer): Int8; +begin + if _Value < MinInt8 then + Result := MinInt8 + else if _Value > MaxInt8 then + Result := MaxInt8 + else + Result := _Value; +end; + +function ReduceToUInt16(const _Value: Integer): UInt16; +begin + if _Value < 0 then + Result := 0 + else if _Value > MaxUInt16 then + Result := MaxUInt16 + else + Result := _Value; +end; + +function ReduceToInt16(const _Value: Integer): Int16; +begin + if _Value < MinInt16 then + Result := MinInt16 + else if _Value > MaxInt16 then + Result := MaxInt16 + else + Result := _Value; +end; + +function ReduceToUInt32(const _Value: Int64): UInt32; +begin + if _Value < 0 then + Result := 0 + else if _Value > MaxUInt32 then + Result := MaxUInt32 + else + Result := _Value; +end; + +function ReduceToInt32(const _Value: Int64): Int32; +begin + if _Value < MinInt32 then + Result := MinInt32 + else if _Value > MaxInt32 then + Result := MaxInt32 + else + Result := _Value; +end; + function isHexDigit(_a: Char): Boolean; begin Result := isDigit(_a, 16); Modified: trunk/ExternalSource/dzlib/u_dzFileStreams.pas =================================================================== --- trunk/ExternalSource/dzlib/u_dzFileStreams.pas 2021-02-20 11:51:37 UTC (rev 3435) +++ trunk/ExternalSource/dzlib/u_dzFileStreams.pas 2021-02-20 16:47:13 UTC (rev 3436) @@ -13,6 +13,7 @@ Classes, SysUtils, Windows, + u_dzTypes, // necessary for correcting NativeInt u_dzTranslator; type @@ -226,7 +227,6 @@ implementation uses - u_dzTypes, u_dzFileUtils, u_dzMiscUtils; Modified: trunk/ExternalSource/dzlib/u_dzGraphicsUtils.pas =================================================================== --- trunk/ExternalSource/dzlib/u_dzGraphicsUtils.pas 2021-02-20 11:51:37 UTC (rev 3435) +++ trunk/ExternalSource/dzlib/u_dzGraphicsUtils.pas 2021-02-20 16:47:13 UTC (rev 3436) @@ -2,11 +2,11 @@ {$INCLUDE 'dzlib.inc'} -{$IFDEF DELPHI2005} +{.$IFDEF DELPHI2005} // the Delphi 2005 cmpiler crashes if this is compiled with typed @ operator // turned on {$TYPEDADDRESS OFF} -{$ENDIF} +{.$ENDIF} {$IFDEF OPTIMIZE_DZ_GRAPHIC_UTILS} {$OPTIMIZATION ON} Modified: trunk/ExternalSource/dzlib/u_dzMiscUtils.pas =================================================================== --- trunk/ExternalSource/dzlib/u_dzMiscUtils.pas 2021-02-20 11:51:37 UTC (rev 3435) +++ trunk/ExternalSource/dzlib/u_dzMiscUtils.pas 2021-02-20 16:47:13 UTC (rev 3436) @@ -24,7 +24,8 @@ Windows, SysUtils, Registry, - u_dzTranslator; + u_dzTranslator, + u_dzTypes; type ///<summary> raised by Max([array of const]) and Min([array of const]) if the passed @@ -86,11 +87,11 @@ function IntToHex(_Value: Int64): string; overload; {$ENDIF HAS_INTTOHEX_FUNCTION} -{$IFNDEF HAS_INTTOHEX_FUNCTION_64} {$IFDEF SUPPORTS_UINT64} +{$IFNDEF HAS_INTTOHEX_FUNCTION_UINT64} function IntToHex(_Value: UInt64): string; overload; +{$ENDIF HAS_INTTOHEX_FUNCTION_64} {$ENDIF SUPPORTS_UINT64} -{$ENDIF HAS_INTTOHEX_FUNCTION_64} function PtrToHex(_Value: Pointer): string; @@ -232,7 +233,6 @@ {$ENDIF} {$ENDIF} StrUtils, - u_dzTypes, u_dzFileUtils, u_dzStringUtils, u_dzConvertUtils; @@ -537,8 +537,8 @@ end; {$ENDIF HAS_INTTOHEX_FUNCTION} -{$IFNDEF HAS_INTTOHEX_FUNCTION_64} {$IFDEF SUPPORTS_UINT64} +{$IFNDEF HAS_INTTOHEX_FUNCTION_UINT64} function IntToHex(_Value: UInt64): string; overload; var Buf: PUInt32; @@ -548,8 +548,8 @@ Buf := PUInt32(@_Value); Result := Result + IntToHex(Buf^, 8); end; +{$ENDIF HAS_INTTOHEX_FUNCTION_UINT64} {$ENDIF SUPPORTS_UINT64} -{$ENDIF HAS_INTTOHEX_FUNCTION_64} function PtrToHex(_Value: Pointer): string; begin Modified: trunk/ExternalSource/dzlib/u_dzSelectDirectoryFix.pas =================================================================== --- trunk/ExternalSource/dzlib/u_dzSelectDirectoryFix.pas 2021-02-20 11:51:37 UTC (rev 3435) +++ trunk/ExternalSource/dzlib/u_dzSelectDirectoryFix.pas 2021-02-20 16:47:13 UTC (rev 3436) @@ -53,6 +53,7 @@ Forms, Messages, Classes, + u_dzTypes, u_dzVclUtils; type Modified: trunk/ExternalSource/dzlib/u_dzTypes.pas =================================================================== --- trunk/ExternalSource/dzlib/u_dzTypes.pas 2021-02-20 11:51:37 UTC (rev 3435) +++ trunk/ExternalSource/dzlib/u_dzTypes.pas 2021-02-20 16:47:13 UTC (rev 3436) @@ -59,12 +59,17 @@ {$IF not declared(PUInt64)} PUInt64 = ^UInt64; {$IFEND} - -{$IF not declared(NativeUInt)} +{$IF SizeOf(Pointer) <> SizeOf(NativeInt)} +// In Delphi 2007 and older, the NativeInt declaration is wrong. It should always have the same size +// as a pointer. +type + NativeInt = Int32; +{$IFEND} +{$IF not declared(NativeUInt) or (SizeOf(Pointer) <> SizeOf(NativeUInt))} NativeUInt = UInt32; {$IFEND} {$IF not declared(UIntPtr)} -{$IF sizeOf(Pointer)=4} +{$IF SizeOf(Pointer)=4} UIntPtr = UInt32; {$ELSE} UIntPtr = UInt64; @@ -71,6 +76,51 @@ {$IFEND} {$IFEND} +{$IF not declared(MaxUInt32)} +const + MaxUInt32 = $FFFFFFFF; +{$IFEND} + +{$IF not declared(MaxInt32)} +const + MaxInt32 = $7FFFFFFF; +{$IFEND} + +{$IF not declared(MinInt32)} +const + MinInt32 = -$80000000; +{$IFEND} + +{$IF not declared(MaxUInt16)} +const + MaxUInt16 = $FFFF; +{$IFEND} + +{$IF not declared(MaxInt16)} +const + MaxInt16 = $7FFF; +{$IFEND} + +{$IF not declared(MinInt16)} +const + MinInt16 = -$8000; +{$IFEND} + +{$IF not declared(MaxUInt8)} +const + MaxUInt8 = $FF; +{$IFEND} + +{$IF not declared(MaxInt8)} +const + MaxInt8 = $7F; +{$IFEND} + +{$IF not declared(MinInt8)} +const + MinInt8 = -$80; +{$IFEND} + type EdzException = class(Exception) end; @@ -108,6 +158,136 @@ type TMethodPointer = procedure of object; +type + TRectLTWH = record +{$IFDEF SUPPORTS_ENHANCED_RECORDS} + private + function GetTopLeft: TPoint; + procedure SetTopLeft(_TopLeft: TPoint); + function GetBottomLeft: TPoint; + procedure SetBottomLeft(const _BottomLeft: TPoint); + public +{$ENDIF} + Left: Integer; + Top: Integer; + Width: Integer; + Height: Integer; +{$IFDEF SUPPORTS_ENHANCED_RECORDS} + procedure Assign(_Left, _Top, _Width, _Height: Integer); overload; + procedure Assign(_a: TRect); overload; + procedure AssignTLRB(_Left, _Top, _Right, _Bottom: Integer); + ///<summary> + /// Gets and sets the top left coordinates keeping the size </summary> + property TopLeft: TPoint read GetTopLeft write SetTopLeft; + ///<summary> + /// Gets and sets the bottom left coordinates keeping the size </summary> + property BottomLeft: TPoint read GetBottomLeft write SetBottomLeft; + function GetCenter: TPoint; + function Right: Integer; + function Bottom: Integer; + class operator Implicit(_a: TRect): TRectLTWH; + class operator Implicit(_a: TRectLTWH): TRect; + class function FromLTWH(_Left, _Top, _Width, _Height: Integer): TRectLTWH; static; +{$ENDIF} + end; + +procedure TRectLTWH_Assign(var _LTWH: TRectLTWH; _Left, _Top, _Width, _Height: Integer); overload; +procedure TRectLTWH_Assign(var _LTWH: TRectLTWH; _a: TRect); overload; +procedure TRectLTWH_AssignTLRB(var _LTWH: TRectLTWH; _Left, _Top, _Right, _Bottom: Integer); + implementation +{$IFDEF SUPPORTS_ENHANCED_RECORDS} +{ TRectLTWH } + +procedure TRectLTWH.Assign(_Left, _Top, _Width, _Height: Integer); +begin + Left := _Left; + Top := _Top; + Width := _Width; + Height := _Height; +end; + +procedure TRectLTWH.Assign(_a: TRect); +begin + AssignTLRB(_a.Left, _a.Top, _a.Right, _a.Bottom); +end; + +procedure TRectLTWH.AssignTLRB(_Left, _Top, _Right, _Bottom: Integer); +begin + Assign(_Left, _Top, _Right - _Left, _Bottom - _Top); +end; + +class function TRectLTWH.FromLTWH(_Left, _Top, _Width, _Height: Integer): TRectLTWH; +begin + Result.Assign(_Left, _Top, _Width, _Height); +end; + +function TRectLTWH.Right: Integer; +begin + Result := Left + Width; +end; + +function TRectLTWH.Bottom: Integer; +begin + Result := Top + Height; +end; + +function TRectLTWH.GetBottomLeft: TPoint; +begin + Result := Point(Left, Top + Height); +end; + +function TRectLTWH.GetCenter: TPoint; +begin + Result := Point(Left + Width div 2, Top + Height div 2); +end; + +procedure TRectLTWH.SetBottomLeft(const _BottomLeft: TPoint); +begin + Left := _BottomLeft.X; + Top := _BottomLeft.Y - Height; +end; + +function TRectLTWH.GetTopLeft: TPoint; +begin + Result.X := Left; + Result.Y := Top; +end; + +procedure TRectLTWH.SetTopLeft(_TopLeft: TPoint); +begin + Left := _TopLeft.X; + Top := _TopLeft.Y; +end; + +class operator TRectLTWH.Implicit(_a: TRectLTWH): TRect; +begin + Result := Rect(_a.Left, _a.Top, _a.Left + _a.Width, _a.Top + _a.Height); +end; + +class operator TRectLTWH.Implicit(_a: TRect): TRectLTWH; +begin + Result.Assign(_a); +end; +{$ENDIF} + +procedure TRectLTWH_Assign(var _LTWH: TRectLTWH; _Left, _Top, _Width, _Height: Integer); +begin + _LTWH.Left := _Left; + _LTWH.Top := _Top; + _LTWH.Width := _Width; + _LTWH.Height := _Height; +end; + +procedure TRectLTWH_Assign(var _LTWH: TRectLTWH; _a: TRect); +begin + TRectLTWH_AssignTLRB(_LTWH, _a.Left, _a.Top, _a.Right, _a.Bottom); +end; + +procedure TRectLTWH_AssignTLRB(var _LTWH: TRectLTWH; _Left, _Top, _Right, _Bottom: Integer); +begin + TRectLTWH_Assign(_LTWH, _Left, _Top, _Right - _Left, _Bottom - _Top); +end; + end. Modified: trunk/ExternalSource/dzlib/u_dzVclUtils.pas =================================================================== --- trunk/ExternalSource/dzlib/u_dzVclUtils.pas 2021-02-20 11:51:37 UTC (rev 3435) +++ trunk/ExternalSource/dzlib/u_dzVclUtils.pas 2021-02-20 16:47:13 UTC (rev 3436) @@ -85,7 +85,20 @@ end; {$IFEND} +{$IFDEF SUPPORTS_ENHANCED_RECORDS} type + TDpiScaler = record + private + FDesignDpi: Integer; + FCurrentDpi: Integer; + public + procedure Init(_frm: TCustomForm); inline; + procedure SetCurrentDpi(_frm: TCustomForm); inline; + function Calc(_Value: Integer): Integer; inline; + end; +{$ENDIF SUPPORTS_ENHANCED_RECORDS} + +type ///<summary> This is a copy of the TFileFormatsList class from Graphics which /// is unfortunately only declaread in the implementation section </summary> TFileFormatsList = class(TList) @@ -1152,6 +1165,8 @@ /// Warning: The result might be nil if the form is outside the visible area. </summary> function TForm_GetMonitor(_frm: TForm): TMonitor; +function TForm_GetDesignDPI(_frm: TForm): Integer; + ///<summary> centers a form on the given point, but makes sure the form is fully visible </summary> procedure TForm_CenterOn(_frm: TForm; _Center: TPoint); overload; ///<summary> centers a form on the given component, but makes sure the form is fully visible </summary> @@ -1496,6 +1511,13 @@ function TMenuItem_FindSelectedRadioItem(_mi: TMenuItem; _GroupIndex: Integer; out _miFound: TMenuItem): Boolean; ///<summary> +/// Assigns an OnAdvancedDrawItem event for all menu items that forces drawing the accelerator char +/// @returns a TCompnent which contains the event's implementation. It is added to the menu, so +/// it will automatically be freed with the menu. It is safe to simply ignore this +/// result as it is only returned for debugging purposes. </summary> +function TMainMenu_ForceAcceleratorChar(_mnu: TMainMenu): TComponent; + +///<summary> /// Sets Screen.Cursor to NewCursor and restores it automatically when the returned interface /// goes out of scope </summary> function TCursor_TemporaryChange(_NewCursor: TCursor = crHourGlass): IInterface; @@ -1552,43 +1574,6 @@ end; {$ENDIF} -type - TRectLTWH = record -{$IFDEF SUPPORTS_ENHANCED_RECORDS} - private - function GetTopLeft: TPoint; - procedure SetTopLeft(_TopLeft: TPoint); - function GetBottomLeft: TPoint; - procedure SetBottomLeft(const _BottomLeft: TPoint); - public -{$ENDIF} - Left: Integer; - Top: Integer; - Width: Integer; - Height: Integer; -{$IFDEF SUPPORTS_ENHANCED_RECORDS} - procedure Assign(_Left, _Top, _Width, _Height: Integer); overload; - procedure Assign(_a: TRect); overload; - procedure AssignTLRB(_Left, _Top, _Right, _Bottom: Integer); - ///<summary> - /// Gets and sets the top left coordinates keeping the size </summary> - property TopLeft: TPoint read GetTopLeft write SetTopLeft; - ///<summary> - /// Gets and sets the bottom left coordinates keeping the size </summary> - property BottomLeft: TPoint read GetBottomLeft write SetBottomLeft; - function GetCenter: TPoint; - function Right: Integer; - function Bottom: Integer; - class operator Implicit(_a: TRect): TRectLTWH; - class operator Implicit(_a: TRectLTWH): TRect; - class function FromLTWH(_Left, _Top, _Width, _Height: Integer): TRectLTWH; static; -{$ENDIF} - end; - -procedure TRectLTWH_Assign(var _LTWH: TRectLTWH; _Left, _Top, _Width, _Height: Integer); overload; -procedure TRectLTWH_Assign(var _LTWH: TRectLTWH; _a: TRect); overload; -procedure TRectLTWH_AssignTLRB(var _LTWH: TRectLTWH; _Left, _Top, _Right, _Bottom: Integer); - ///<summary> /// deprecated version of TForm_StorePlacement /// @param Bounds is a TRectLTWH whose placement is to be stored @@ -1637,13 +1622,50 @@ procedure TMonitor_MakeFullyVisible(_Monitor: TMonitor; var _Rect: TRectLTWH); overload; procedure TMonitor_MakeFullyVisible(_Monitor: TMonitor; _frm: TForm); overload; +///<summary> +/// Tries to get the primary monitor. +/// @param Monitor returns the primary monitor, only valid if Result = True +/// @returns True, if the primary monitor could be determined +/// False, if not +/// @NOTE: It is possible for this function to return False. I have observed this when switching +/// between Remote Destkop access and local monitors on Windows XP. </summary> function TScreen_TryGetPrimaryMonitor(out _Monitor: TMonitor): Boolean; +///<summary> +/// Gge the primary monitor. +/// @returns the primary monitor if there is one +/// NIL if not +/// @NOTE: It is possible for this function to return NIL. I have observed this when switching +/// between Remote Destkop access and local monitors on Windows XP. </summary> function TScreen_GetPrimaryMonitor: TMonitor; +///<summary> +/// Trys to determine the monitor for the given point or the primary monitor if the point is +/// outside the visible area of any attached monitor +/// @param pnt is the point to check +/// @param Monitor returns the monitor for the given point or the primary monitor +/// only valid if Result = True +/// @returns True, Monitor is valid +/// False, if not +/// @NOTE: It is possible for this function to return False. I have observed this when switching +/// between Remote Destkop access and local monitors on Windows XP. </summary> function TScreen_TryGetMonitorFromPointOrPrimary(_pnt: TPoint; out _Monitor: TMonitor): Boolean; +///<summary> +/// Trys to determine the monitor for the given point +/// @param pnt is the point to check +/// @param Monitor returns the monitor for the given point, only valid if Result = True +/// @returns True, if the monitor could be determined +/// False, if not (e.g. the point is outside the visible area of any monitor </summary> function TScreen_TryGetMonitorFromPoint(_pnt: TPoint; out _Monitor: TMonitor): Boolean; +///<summary> +/// Gets the monitor for the given point +/// @param pnt is the point to check +/// @param Monitor returns the monitor for the given point, only valid if Result = True +/// @returns the monitor for the given point or NIL if it could not be determined </summary> function TScreen_MonitorFromPoint(_pnt: TPoint): TMonitor; +function TScreen_GetDpiForPoint(_pnt: TPoint): Integer; +function TScreen_GetDpiForForm(_frm: TCustomForm): Integer; + procedure TScreen_MakeFullyVisible(_frm: TForm); overload; procedure TScreen_MakeFullyVisible(var _Left, _Top, _Width, _Height: Integer); overload; procedure TScreen_MakeFullyVisible(var _Rect: TRect); overload; @@ -4170,6 +4192,49 @@ Result := nil; end; +function TScreen_GetDpiForPoint(_pnt: TPoint): Integer; +{$IFDEF HAS_TMONITOR_PIXELSPERINCH} +var + Monitor: TMonitor; +{$ENDIF} +begin +{$IFDEF HAS_TMONITOR_PIXELSPERINCH} + if TScreen_TryGetMonitorFromPoint(_pnt, Monitor) then + Result := Monitor.PixelsPerInch + else +{$ENDIF} + Result := Screen.PixelsPerInch; +end; + +function TScreen_GetDpiForForm(_frm: TCustomForm): Integer; +{$IFDEF HAS_TMONITOR_PIXELSPERINCH} +var + Monitor: TMonitor; +{$ENDIF} +begin + Result := Screen.PixelsPerInch; +{$IFDEF HAS_TMONITOR_PIXELSPERINCH} + if _frm is TForm then begin + Monitor := TForm_GetMonitor(TForm(_frm)); + if Assigned(Monitor) then + Result := Monitor.PixelsPerInch + end; +{$ENDIF} +end; + +type + TFormHack = class(TForm) + end; + +function TForm_GetDesignDPI(_frm: TForm): Integer; +begin +{$IFDEF HAS_TMONITOR_PIXELSPERINCH} + Result := TFormHack(_frm).GetDesignDpi; +{$ELSE} + Result := 96; +{$ENDIF} +end; + function TForm_GetMonitor(_frm: TForm): TMonitor; var Center: TPoint; @@ -5127,6 +5192,80 @@ Result := False; end; +type + TMenuItemHack = class(TMenuItem) + // to get access to the protected TMenuItem.AdvancedDrawItem method + end; + +type + TForceAcceleratorCharHandlerComponent = class(TComponent) + private + procedure HandleAdvancedDrawItem(_Sender: TObject; _Canvas: TCanvas; _Rect: TRect; + _State: TOwnerDrawState); + procedure HandleMeasureItem(_Sender: TObject; _Canvas: TCanvas; var _Width, _Height: Integer); + end; + +procedure TForceAcceleratorCharHandlerComponent.HandleAdvancedDrawItem(_Sender: TObject; + _Canvas: TCanvas; _Rect: TRect; _State: TOwnerDrawState); +var + TopLevel: Boolean; +begin + // force accelerator char to be underlined + _State := _State - [odnoAccel]; + TMenuItem(_Sender).OnAdvancedDrawItem := nil; + TopLevel := TMenuItem(_Sender).GetParentComponent is TMainMenu; + TMenuItemHack(_Sender).AdvancedDrawItem(_Canvas, _Rect, _State, TopLevel); + TMenuItem(_Sender).OnAdvancedDrawItem := HandleAdvancedDrawItem; +end; + +procedure TForceAcceleratorCharHandlerComponent.HandleMeasureItem(_Sender: TObject; _Canvas: TCanvas; + var _Width, _Height: Integer); +begin + // the size of the main menu items doesn't really seem right in per Monitor high DPI mode + // todo: Fix it here +end; + +function TMainMenu_ForceAcceleratorChar(_mnu: TMainMenu): TComponent; + + function TryFindHandlerCoponent(_Owner: TComponent; out _HandlerCmp: TForceAcceleratorCharHandlerComponent): Boolean; + var + cmp: TComponent; + i: Integer; + begin + for i := 0 to _Owner.ComponentCount - 1 do begin + cmp := _Owner.Components[i]; + if cmp is TForceAcceleratorCharHandlerComponent then begin + _HandlerCmp := TForceAcceleratorCharHandlerComponent(cmp); + Result := True; + Exit; //==> + end; + end; + Result := False; + end; + + procedure AssignDrawingHandler(_mi: TMenuItem; _HandlerCmp: TForceAcceleratorCharHandlerComponent); + var + i: Integer; + begin + _mi.OnAdvancedDrawItem := _HandlerCmp.HandleAdvancedDrawItem; + _mi.OnMeasureItem := _HandlerCmp.HandleMeasureItem; + for i := 0 to _mi.Count - 1 do + AssignDrawingHandler(_mi[i], _HandlerCmp); + end; + +var + HandlerCmp: TForceAcceleratorCharHandlerComponent; + i: Integer; +begin + if not TryFindHandlerCoponent(_mnu, HandlerCmp) then begin + HandlerCmp := TForceAcceleratorCharHandlerComponent.Create(_mnu); + HandlerCmp.Name := ''; + end; + for i := 0 to _mnu.Items.Count - 1 do + AssignDrawingHandler(_mnu.Items[i], HandlerCmp); + Result := HandlerCmp; +end; + function TPopupMenu_FindSelectedRadioItem(_pm: TPopupMenu; _GroupIndex: Integer; out _miFound: TMenuItem): Boolean; begin Result := TMenuItem_FindSelectedRadioItem(_pm.Items, _GroupIndex, _miFound); @@ -5839,7 +5978,7 @@ fn: string; i: Integer; sl: TStringList; - cnt: Cardinal; + cnt: Integer; begin sl := TStringList.Create; try @@ -6353,99 +6492,6 @@ TMonitor_MakeFullyVisible(Monitor, _Rect); end; -{$IFDEF SUPPORTS_ENHANCED_RECORDS} -{ TRectLTWH } - -procedure TRectLTWH.Assign(_Left, _Top, _Width, _Height: Integer); -begin - Left := _Left; - Top := _Top; - Width := _Width; - Height := _Height; -end; - -procedure TRectLTWH.Assign(_a: TRect); -begin - AssignTLRB(_a.Left, _a.Top, _a.Right, _a.Bottom); -end; - -procedure TRectLTWH.AssignTLRB(_Left, _Top, _Right, _Bottom: Integer); -begin - Assign(_Left, _Top, _Right - _Left, _Bottom - _Top); -end; - -class function TRectLTWH.FromLTWH(_Left, _Top, _Width, _Height: Integer): TRectLTWH; -begin - Result.Assign(_Left, _Top, _Width, _Height); -end; - -function TRectLTWH.Right: Integer; -begin - Result := Left + Width; -end; - -function TRectLTWH.Bottom: Integer; -begin - Result := Top + Height; -end; - -function TRectLTWH.GetBottomLeft: TPoint; -begin - Result := Point(Left, Top + Height); -end; - -function TRectLTWH.GetCenter: TPoint; -begin - Result := Point(Left + Width div 2, Top + Height div 2); -end; - -procedure TRectLTWH.SetBottomLeft(const _BottomLeft: TPoint); -begin - Left := _BottomLeft.X; - Top := _BottomLeft.Y - Height; -end; - -function TRectLTWH.GetTopLeft: TPoint; -begin - Result.X := Left; - Result.Y := Top; -end; - -procedure TRectLTWH.SetTopLeft(_TopLeft: TPoint); -begin - Left := _TopLeft.X; - Top := _TopLeft.Y; -end; - -class operator TRectLTWH.Implicit(_a: TRectLTWH): TRect; -begin - Result := Rect(_a.Left, _a.Top, _a.Left + _a.Width, _a.Top + _a.Height); -end; - -class operator TRectLTWH.Implicit(_a: TRect): TRectLTWH; -begin - Result.Assign(_a); -end; -{$ENDIF} - -procedure TRectLTWH_Assign(var _LTWH: TRectLTWH; _Left, _Top, _Width, _Height: Integer); -begin - _LTWH.Left := _Left; - _LTWH.Top := _Top; - _LTWH.Width := _Width; - _LTWH.Height := _Height; -end; - -procedure TRectLTWH_Assign(var _LTWH: TRectLTWH; _a: TRect); -begin - TRectLTWH_AssignTLRB(_LTWH, _a.Left, _a.Top, _a.Right, _a.Bottom); -end; - -procedure TRectLTWH_AssignTLRB(var _LTWH: TRectLTWH; _Left, _Top, _Right, _Bottom: Integer); -begin - TRectLTWH_Assign(_LTWH, _Left, _Top, _Right - _Left, _Bottom - _Top); -end; - procedure TForm_MoveTo(_frm: TCustomForm; _Position: TdzWindowPositions); procedure ToTop(var _Re: TRect; _MinHeight, _MaxHeight: Integer); @@ -6846,6 +6892,46 @@ end; {$ENDIF} +{$IFDEF SUPPORTS_ENHANCED_RECORDS} +{ TDpiScaler } + +function TDpiScaler.Calc(_Value: Integer): Integer; +begin + Result := MulDiv(_Value, FCurrentDpi, FDesignDpi); +end; + +procedure TDpiScaler.Init(_frm: TCustomForm); +begin + if not Assigned(_frm) then begin + FDesignDpi := 96; + FCurrentDpi := 96; + end else begin +// todo: adjust as needed +{$IFDEF DELPHIX_TOKYO_UP} + FDesignDpi := TForm_GetDesignDPI(TForm(_frm)); + FCurrentDpi := TScreen_GetDpiForForm(_frm); +{$ELSE ~DELPHIX_TOKYO_UP} + FDesignDpi := TForm(_frm).PixelsPerInch; + FCurrentDpi := TForm(_frm).PixelsPerInch; +{$ENDIF DELPHIX_TOKYO_UP} + end; +end; + +procedure TDpiScaler.SetCurrentDpi(_frm: TCustomForm); +begin + if not Assigned(_frm) then begin + FCurrentDpi := 96; + end else begin +// todo: adjust as needed +{$IFDEF DELPHIX_TOKYO_UP} + FCurrentDpi := TScreen_GetDpiForForm(_frm) +{$ELSE ~DELPHIX_TOKYO_UP} + FCurrentDpi := TForm(_frm).PixelsPerInch; +{$ENDIF DELPHIX_TOKYO_UP} + end; +end; +{$ENDIF SUPPORTS_ENHANCED_RECORDS} + initialization InitializeCustomMessages; finalization Modified: trunk/ExternalSource/dzlib/u_dzVersionInfo.pas =================================================================== --- trunk/ExternalSource/dzlib/u_dzVersionInfo.pas 2021-02-20 11:51:37 UTC (rev 3435) +++ trunk/ExternalSource/dzlib/u_dzVersionInfo.pas 2021-02-20 16:47:13 UTC (rev 3436) @@ -419,7 +419,7 @@ szOffset := SizeOf(UInt16) * 3; Move(_Buffer[_Offset], _StringTable, szOffset); if _StringTable.wValueLength <> 0 then - raise EdzException.CreateFmt(_('StringTable.wValueLength must bei 0 but is %d'), [_StringTable.wValueLength]); + raise EdzException.CreateFmt(_('StringTable.wValueLength must be 0 but is %d'), [_StringTable.wValueLength]); _StringTable.szKey := ReadNullTerminatedWideString(_Buffer, _Offset + szOffset); // _StringTable.szKey is the language code @@ -446,11 +446,11 @@ szOffset := SizeOf(UInt16) * 3; Move(_Buffer[_Offset], _StringFileInfo, szOffset); if _StringFileInfo.wValueLength <> 0 then - raise EdzException.CreateFmt(_('StringFileInfo.wValueLength must bei 0 but is %d'), [_StringFileInfo.wValueLength]); + raise EdzException.CreateFmt(_('StringFileInfo.wValueLength must be 0 but is %d'), [_StringFileInfo.wValueLength]); _StringFileInfo.szKey := ReadNullTerminatedWideString(_Buffer, _Offset + szOffset); if _StringFileInfo.szKey <> 'StringFileInfo' then - raise EdzException.CreateFmt(_('StringFileInfo.szKey "StringFileInfo" but is "%s"'), [_StringFileInfo.szKey]); + raise EdzException.CreateFmt(_('StringFileInfo.szKey must be "StringFileInfo" but is "%s"'), [_StringFileInfo.szKey]); SetLength(_StringFileInfo.Children, 0); Offset := (_Offset + szOffset + (Length(_StringFileInfo.szKey) + 1) * SizeOf(WideChar) + 3) and (not 3); This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |