VCLFlickerReduce: unidad que se encarga de reducir el parpadeo en las pantallas (no afecta a los componentes DevExpress)
git-svn-id: https://192.168.0.254/svn/Proyectos.Tecsitel_FactuGES2/trunk@304 0c75b7a4-871f-7646-8a2f-f78d34cc349f
This commit is contained in:
parent
ee75a9b28e
commit
da570a2380
@ -14,7 +14,8 @@ uses
|
||||
uNavPaneUtils in 'Utiles\uNavPaneUtils.pas',
|
||||
uMainMenuController in 'uMainMenuController.pas',
|
||||
uClienteUtils in 'Utiles\uClienteUtils.pas',
|
||||
uBootStrap in 'uBootStrap.pas';
|
||||
uBootStrap in 'uBootStrap.pas',
|
||||
VCLFlickerReduce in 'Utiles\VCLFlickerReduce.pas';
|
||||
|
||||
{$R *.res}
|
||||
|
||||
|
||||
@ -82,6 +82,7 @@
|
||||
<DCCReference Include="Utiles\uClienteUtils.pas" />
|
||||
<DCCReference Include="Utiles\uMenuUtils.pas" />
|
||||
<DCCReference Include="Utiles\uNavPaneUtils.pas" />
|
||||
<DCCReference Include="Utiles\VCLFlickerReduce.pas" />
|
||||
</ItemGroup>
|
||||
</Project>
|
||||
<!-- EurekaLog First Line
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
MAINICON ICON "C:\Codigo Tecsitel\Resources\Iconos\Factuges.ico"
|
||||
1 VERSIONINFO
|
||||
FILEVERSION 1,0,0,0
|
||||
PRODUCTVERSION 1,0,0,0
|
||||
FILEVERSION 1,0,2,0
|
||||
PRODUCTVERSION 1,0,2,0
|
||||
FILEFLAGSMASK 0x3FL
|
||||
FILEFLAGS 0x00L
|
||||
FILEOS 0x40004L
|
||||
@ -13,9 +13,10 @@ BEGIN
|
||||
BLOCK "0C0A04E4"
|
||||
BEGIN
|
||||
VALUE "CompanyName", "Rodax Software S.L.\0"
|
||||
VALUE "FileVersion", "1.0.0.0\0"
|
||||
VALUE "FileVersion", "1.0.2.0\0"
|
||||
VALUE "InternalName", "FactuGES\0"
|
||||
VALUE "ProductVersion", "1.0.0.0\0"
|
||||
VALUE "ProductName", "FactuGES\0"
|
||||
VALUE "ProductVersion", "1.0.2.0\0"
|
||||
END
|
||||
END
|
||||
BLOCK "VarFileInfo"
|
||||
|
||||
Binary file not shown.
392
Source/Cliente/Utiles/VCLFlickerReduce.pas
Normal file
392
Source/Cliente/Utiles/VCLFlickerReduce.pas
Normal file
@ -0,0 +1,392 @@
|
||||
{$A+,B-,C+,D-,E-,F-,G+,H+,I+,J-,K-,L+,M-,N+,O+,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+,Z1}
|
||||
(*************************************************************************
|
||||
|
||||
Copyright (c) 2006 Andreas Hausladen (http://unvclx.sourceforge.net)
|
||||
|
||||
|
||||
This software is provided 'as-is', without any express or implied
|
||||
warranty. In no event will the author be held liable for any damages
|
||||
arising from the use of this software.
|
||||
|
||||
Permission is granted to anyone to use this software for any purpose,
|
||||
including commercial applications, and to alter it and redistribute it
|
||||
freely, subject to the following restrictions:
|
||||
|
||||
1. The origin of this software must not be misrepresented, you must
|
||||
not claim that you wrote the original software. If you use this
|
||||
software in a product, an acknowledgment in the product documentation
|
||||
would be appreciated but is not required.
|
||||
|
||||
2. Altered source versions must be plainly marked as such, and must not
|
||||
be misrepresented as being the original software.
|
||||
|
||||
3. This notice may not be removed or altered from any source distribution.
|
||||
|
||||
*************************************************************************)
|
||||
|
||||
(*************************************************************************
|
||||
History:
|
||||
2006-10-03:
|
||||
- fixed RangeChecks disabled
|
||||
*************************************************************************)
|
||||
|
||||
unit VCLFlickerReduce;
|
||||
|
||||
{$IFDEF CONDITIONALEXPRESSIONS}
|
||||
{$IF RTLVersion >= 15.00}
|
||||
{$DEFINE HAS_THEMES_UNIT}
|
||||
{$IFEND}
|
||||
{$ENDIF CONDITIONALEXPRESSIONS}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Windows, Messages, SysUtils, Classes,
|
||||
{$IFDEF HAS_THEMES_UNIT}
|
||||
Themes,
|
||||
{$ENDIF HAS_THEMES_UNIT}
|
||||
Controls, StdCtrls, ExtCtrls, ComCtrls, Forms, Grids, Buttons;
|
||||
|
||||
implementation
|
||||
|
||||
// ------- BEGIN Memory manipulation functions ----------
|
||||
|
||||
type
|
||||
PPointer = ^Pointer; // Delphi 5
|
||||
|
||||
type
|
||||
TRedirectCode = packed record
|
||||
Code: packed record
|
||||
PushEBP: Byte; // $55
|
||||
PopEBP: Byte; // $5D
|
||||
Jump: Byte;
|
||||
Offset: Integer;
|
||||
end;
|
||||
// additional data
|
||||
RealProc: Pointer;
|
||||
Count: Integer;
|
||||
end;
|
||||
|
||||
function WriteProtectedMemory(BaseAddress, Buffer: Pointer; Size: Cardinal;
|
||||
out WrittenBytes: Cardinal): Boolean;
|
||||
var
|
||||
OldProt: Cardinal;
|
||||
begin
|
||||
VirtualProtect(BaseAddress, Size, PAGE_EXECUTE_READWRITE, OldProt);
|
||||
Result := WriteProcessMemory(GetCurrentProcess, BaseAddress, Buffer, Size, WrittenBytes);
|
||||
VirtualProtect(BaseAddress, Size, OldProt, nil);
|
||||
FlushInstructionCache(GetCurrentProcess, BaseAddress, WrittenBytes);
|
||||
end;
|
||||
|
||||
function ReadProtectedMemory(BaseAddress, Buffer: Pointer; Size: Cardinal;
|
||||
out ReadBytes: Cardinal): Boolean;
|
||||
begin
|
||||
Result := ReadProcessMemory(GetCurrentProcess, BaseAddress, Buffer, Size, ReadBytes);
|
||||
end;
|
||||
|
||||
procedure CodeRedirectEx(Proc: Pointer; NewProc: Pointer; out Data: TRedirectCode);
|
||||
type
|
||||
PPointer = ^Pointer;
|
||||
TRelocationRec = packed record
|
||||
Jump: Word;
|
||||
Address: PPointer;
|
||||
end;
|
||||
|
||||
var
|
||||
Code: TRedirectCode;
|
||||
Relocation: TRelocationRec;
|
||||
n: Cardinal;
|
||||
begin
|
||||
if Proc = nil then
|
||||
begin
|
||||
Data.RealProc := nil;
|
||||
Exit;
|
||||
end;
|
||||
if Data.Count = 0 then // do not overwrite an already backuped code
|
||||
begin
|
||||
ReadProtectedMemory(Proc, @Data.Code, SizeOf(Data.Code), n);
|
||||
if (Data.Code.PushEBP = $FF) and (Data.Code.PopEBP = $25) then // Proc is in a dll/so or package
|
||||
begin
|
||||
ReadProtectedMemory(Proc, @Relocation, SizeOf(Relocation), n);
|
||||
Data.RealProc := Relocation.Address^;
|
||||
Proc := Data.RealProc;
|
||||
ReadProtectedMemory(Proc, @Data.Code, SizeOf(Data.Code), n);
|
||||
end
|
||||
else
|
||||
Data.RealProc := Proc;
|
||||
Code.Code.PushEBP := $55;
|
||||
Code.Code.PopEBP := $5D;
|
||||
Code.Code.Jump := $E9;
|
||||
Code.Code.Offset := Integer(NewProc) - Integer(Proc) - SizeOf(Data.Code);
|
||||
WriteProtectedMemory(Proc, @Code.Code, SizeOf(Data.Code), n);
|
||||
end;
|
||||
Inc(Data.Count);
|
||||
end;
|
||||
|
||||
function CodeRedirect(Proc: Pointer; NewProc: Pointer): TRedirectCode;
|
||||
begin
|
||||
Result.Count := 0;
|
||||
Result.RealProc := nil;
|
||||
CodeRedirectEx(Proc, NewProc, Result);
|
||||
end;
|
||||
|
||||
procedure CodeRestore(var Data: TRedirectCode);
|
||||
var
|
||||
n: Cardinal;
|
||||
begin
|
||||
if (Data.RealProc <> nil) and (Data.Count = 1) then
|
||||
WriteProtectedMemory(Data.RealProc, @Data.Code, SizeOf(Data.Code), n);
|
||||
Dec(Data.Count);
|
||||
end;
|
||||
|
||||
function GetDynamicMethod(AClass: TClass; Index: Integer): Pointer; assembler;
|
||||
asm
|
||||
CALL System.@FindDynaClass
|
||||
end;
|
||||
|
||||
// ------- END Memory manipulation functions ----------
|
||||
|
||||
type
|
||||
TOpenWinControl = class(TWinControl);
|
||||
TOpenCustomControl = class(TCustomControl);
|
||||
|
||||
procedure WinControlWMEraseBkgnd(Control: TWinControl; var Message: TWMEraseBkgnd);
|
||||
var
|
||||
SaveIndex, Clip, I: Integer;
|
||||
R: TRect;
|
||||
H, Flags: Integer;
|
||||
begin
|
||||
with TOpenWinControl(Control) do
|
||||
begin
|
||||
if (ClassName = 'TGroupButton') then
|
||||
ControlStyle := ControlStyle + [csOpaque];
|
||||
|
||||
{$IFDEF HAS_THEMES_UNIT}
|
||||
with ThemeServices do
|
||||
{$ENDIF HAS_THEMES_UNIT}
|
||||
begin
|
||||
{$IFDEF HAS_THEMES_UNIT}
|
||||
if ThemesEnabled and Assigned(Parent) and (csParentBackground in ControlStyle) then
|
||||
begin
|
||||
{ Get the parent to draw its background into the control's background. }
|
||||
if (TMessage(Message).wParam <> TMessage(Message).lParam) and (Control is TCustomPanel) then
|
||||
begin
|
||||
R := Control.ClientRect;
|
||||
AdjustClientRect(R);
|
||||
IntersectClipRect(Message.DC, R.Left, R.Top, R.Right, R.Bottom);
|
||||
end;
|
||||
DrawParentBackground(Handle, Message.DC, nil, False);
|
||||
end
|
||||
else
|
||||
{$ENDIF HAS_THEMES_UNIT}
|
||||
begin
|
||||
{ Only erase background if we're not doublebuffering or painting to memory. }
|
||||
if not DoubleBuffered or (TMessage(Message).wParam = TMessage(Message).lParam) then
|
||||
begin
|
||||
if TMessage(Message).wParam <> TMessage(Message).lParam then
|
||||
begin
|
||||
if (Control is TCustomPanel) or
|
||||
(Control is TCustomGrid) then
|
||||
begin
|
||||
Message.Result := 1;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
if (Control is TCustomEdit) or
|
||||
(Control is TCustomStaticText) or
|
||||
(Control is TCustomFrame) or
|
||||
(Control is TCustomListControl) or
|
||||
(Control is TCustomTreeView) or
|
||||
(Control is TButtonControl) or
|
||||
(Control is TCommonCalendar) or
|
||||
(Control is TCustomHotKey) or
|
||||
(Control is TProgressBar) or
|
||||
(Control is TAnimate) then
|
||||
begin
|
||||
{ These controls do not need to paint their own background because
|
||||
the WM_PAINT handler fills the whole area. }
|
||||
DefaultHandler(Message);
|
||||
Exit;
|
||||
end;
|
||||
|
||||
{ Paint the background only where no opaque control is }
|
||||
SaveIndex := SaveDC(Message.DC);
|
||||
|
||||
if Control is TCustomGroupBox then
|
||||
begin
|
||||
GetWindowRect(Handle, R);
|
||||
OffsetRect(R, -R.Left, -R.Top);
|
||||
H := TOpenCustomControl(Control).Canvas.TextHeight('0');
|
||||
Inc(R.Top, H div 2 - 1);
|
||||
ExcludeClipRect(Message.DC, R.Left, R.Top, R.Left + 2, R.Bottom);
|
||||
ExcludeClipRect(Message.DC, R.Right, R.Top, R.Right - 2, R.Bottom);
|
||||
ExcludeClipRect(Message.DC, R.Left, R.Bottom - 2, R.Right, R.Bottom);
|
||||
ExcludeClipRect(Message.DC, R.Left, R.Top, R.Right, R.Top + 2);
|
||||
|
||||
if Text <> '' then
|
||||
begin
|
||||
if not UseRightToLeftAlignment then
|
||||
R := Rect(8, 0, 0, H)
|
||||
else
|
||||
R := Rect(R.Right - TOpenCustomControl(Control).Canvas.TextWidth(Text) - 8, 0, 0, H);
|
||||
Flags := DrawTextBiDiModeFlags(DT_SINGLELINE);
|
||||
Windows.DrawText(TOpenCustomControl(Control).Canvas.Handle, PChar(Text), Length(Text), R, Flags or DT_CALCRECT);
|
||||
ExcludeClipRect(Message.DC, R.Left, R.Top, R.Right, R.Bottom);
|
||||
end;
|
||||
end;
|
||||
|
||||
Clip := SimpleRegion;
|
||||
for I := 0 to ControlCount - 1 do
|
||||
with Controls[I] do
|
||||
if (Visible or (csDesigning in ComponentState) and
|
||||
not (csNoDesignVisible in ControlStyle)) and
|
||||
(csOpaque in ControlStyle) then
|
||||
begin
|
||||
Clip := ExcludeClipRect(Message.DC, Left, Top, Left + Width, Top + Height);
|
||||
if Clip = NullRegion then
|
||||
Break;
|
||||
end;
|
||||
if Clip <> NullRegion then
|
||||
FillRect(Message.DC, ClientRect, Brush.Handle);
|
||||
RestoreDC(Message.DC, SaveIndex);
|
||||
end
|
||||
else
|
||||
FillRect(Message.DC, ClientRect, Brush.Handle);
|
||||
end;
|
||||
end;
|
||||
Message.Result := 1;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
type
|
||||
TOpenTabSheet = class(TTabSheet);
|
||||
|
||||
procedure TabSheetCreateParams(TabSheet: TTabSheet; var Params: TCreateParams);
|
||||
var
|
||||
Inherit: procedure(TabSheet: TTabSheet; var Params: TCreateParams);
|
||||
begin
|
||||
Inherit := @TOpenWinControl.CreateParams;
|
||||
Inherit(TabSheet, Params);
|
||||
with TabSheet do
|
||||
begin
|
||||
ControlStyle := ControlStyle + [csOpaque]; // add the missing csOpaque style
|
||||
{$IFDEF HAS_THEMES_UNIT}
|
||||
if not ThemeServices.ThemesAvailable then
|
||||
{$ENDIF HAS_THEMES_UNIT}
|
||||
with Params.WindowClass do
|
||||
style := style and not (CS_HREDRAW or CS_VREDRAW);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure WinControlWMPaint(Control: TWinControl; var Message: TWMPaint);
|
||||
var
|
||||
DC, MemDC: HDC;
|
||||
MemBitmap, OldBitmap: HBITMAP;
|
||||
PS: TPaintStruct;
|
||||
begin
|
||||
with TOpenWinControl(Control) do
|
||||
begin
|
||||
if not DoubleBuffered or (Message.DC <> 0) then
|
||||
begin
|
||||
if not (csCustomPaint in ControlState) and (ControlCount = 0) then
|
||||
begin
|
||||
{ Paint ListControl background here to keep flickering short }
|
||||
DC := 0;
|
||||
if Assigned(Parent) and (
|
||||
((Control is TCustomListControl) and not (Control is TCustomCombo)) or
|
||||
(Control is TCommonCalendar) or
|
||||
(Control is TCustomHotKey) or
|
||||
(Control is TProgressBar) or
|
||||
((Control is TCustomMemo) and not (Control is TCustomRichEdit))
|
||||
) then
|
||||
begin
|
||||
if Message.DC = 0 then
|
||||
begin
|
||||
DC := BeginPaint(Handle, PS);
|
||||
Message.DC := DC;
|
||||
end;
|
||||
FillRect(Message.DC, ClientRect, Brush.Handle);
|
||||
end;
|
||||
DefaultHandler(Message);
|
||||
if DC <> 0 then
|
||||
EndPaint(Handle, PS);
|
||||
end
|
||||
else
|
||||
PaintHandler(Message);
|
||||
end
|
||||
else
|
||||
begin
|
||||
DC := GetDC(0);
|
||||
MemBitmap := CreateCompatibleBitmap(DC, ClientRect.Right, ClientRect.Bottom);
|
||||
ReleaseDC(0, DC);
|
||||
MemDC := CreateCompatibleDC(0);
|
||||
OldBitmap := SelectObject(MemDC, MemBitmap);
|
||||
try
|
||||
DC := BeginPaint(Handle, PS);
|
||||
Perform(WM_ERASEBKGND, Integer(MemDC), Integer(MemDC));
|
||||
Message.DC := MemDC;
|
||||
Message.Result := Perform(WM_PAINT, Integer(Message.DC), Integer(Message.Unused));
|
||||
Message.DC := 0;
|
||||
BitBlt(DC, 0, 0, ClientRect.Right, ClientRect.Bottom, MemDC, 0, 0, SRCCOPY);
|
||||
EndPaint(Handle, PS);
|
||||
finally
|
||||
SelectObject(MemDC, OldBitmap);
|
||||
DeleteDC(MemDC);
|
||||
DeleteObject(MemBitmap);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
type
|
||||
TOpenButtonControl = class(TButtonControl);
|
||||
TOpenButton = class(TButton);
|
||||
|
||||
procedure ButtonCreateParams(Button: TButton; var Params: TCreateParams);
|
||||
const
|
||||
ButtonStyles: array[Boolean] of DWORD = (BS_PUSHBUTTON, BS_DEFPUSHBUTTON);
|
||||
var
|
||||
Inherit: procedure(Button: TButton; var Params: TCreateParams);
|
||||
begin
|
||||
Inherit := @TOpenButtonControl.CreateParams;
|
||||
Inherit(Button, Params);
|
||||
with TOpenButton(Button) do
|
||||
begin
|
||||
{$IFDEF HAS_THEMES_UNIT}
|
||||
if not ThemeServices.ThemesAvailable then
|
||||
{$ENDIF HAS_THEMES_UNIT}
|
||||
ControlStyle := ControlStyle + [csOpaque]; // add the missing csOpaque style
|
||||
CreateSubClass(Params, 'BUTTON');
|
||||
Params.Style := Params.Style or ButtonStyles[Default];
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure ButtonWMEraseBkgnd(Control: TWinControl; var Message: TWMEraseBkgnd);
|
||||
begin
|
||||
Message.Result := 1
|
||||
end;
|
||||
|
||||
var
|
||||
WinControlWMEraseBkgndHook: TRedirectCode;
|
||||
WinControlWMPaintHook: TRedirectCode;
|
||||
TabSheetCreateParamsHook: TRedirectCode;
|
||||
ButtonCreateParamsHook: TRedirectCode;
|
||||
ButtonWMEraseBkgndHook: TRedirectCode;
|
||||
|
||||
initialization
|
||||
WinControlWMEraseBkgndHook := CodeRedirect(GetDynamicMethod(TWinControl, WM_ERASEBKGND), @WinControlWMEraseBkgnd);
|
||||
WinControlWMPaintHook := CodeRedirect(GetDynamicMethod(TWinControl, WM_PAINT), @WinControlWMPaint);
|
||||
TabSheetCreateParamsHook := CodeRedirect(@TOpenTabSheet.CreateParams, @TabSheetCreateParams);
|
||||
ButtonCreateParamsHook := CodeRedirect(@TOpenButton.CreateParams, @ButtonCreateParams);
|
||||
ButtonWMEraseBkgndHook := CodeRedirect(GetDynamicMethod(TButton, WM_ERASEBKGND), @ButtonWMEraseBkgnd);
|
||||
|
||||
|
||||
finalization
|
||||
CodeRestore(WinControlWMEraseBkgndHook);
|
||||
CodeRestore(WinControlWMPaintHook);
|
||||
CodeRestore(TabSheetCreateParamsHook);
|
||||
CodeRestore(ButtonCreateParamsHook);
|
||||
CodeRestore(ButtonWMEraseBkgndHook);
|
||||
|
||||
end.
|
||||
Loading…
Reference in New Issue
Block a user