From 9b606faafa6dc21b5fdf7bfd137fec663a729419 Mon Sep 17 00:00:00 2001
From: david <darranz@rodax-software.com>
Date: Wed, 27 Feb 2008 12:29:59 +0000
Subject: [PATCH] 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.Acana_FactuGES2/trunk@158 f4e31baf-9722-1c47-927c-6f952f962d4b
---
 Source/Cliente/FactuGES.dpr                |   5 +-
 Source/Cliente/FactuGES.dproj              |  73 ++++
 Source/Cliente/Utiles/VCLFlickerReduce.pas | 392 +++++++++++++++++++++
 3 files changed, 467 insertions(+), 3 deletions(-)
 create mode 100644 Source/Cliente/Utiles/VCLFlickerReduce.pas

diff --git a/Source/Cliente/FactuGES.dpr b/Source/Cliente/FactuGES.dpr
index ce8466be..476de4b4 100644
--- a/Source/Cliente/FactuGES.dpr
+++ b/Source/Cliente/FactuGES.dpr
@@ -14,14 +14,13 @@ 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}
 
 begin
   Application.Initialize;
-  Application.ShowMainForm := False;
-
 
   //ReportMemoryLeaksOnShutdown := True;
 
diff --git a/Source/Cliente/FactuGES.dproj b/Source/Cliente/FactuGES.dproj
index 8e41013f..506cc325 100644
--- a/Source/Cliente/FactuGES.dproj
+++ b/Source/Cliente/FactuGES.dproj
@@ -62,6 +62,78 @@
       
       
       
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
+      
       <Excluded_Packages Name="C:\Documents and Settings\All Users\Documentos\RAD Studio\5.0\Bpl\dxPSCoreD10.bpl">ExpressPrinting System by Developer Express Inc.</Excluded_Packages>
       <Excluded_Packages Name="C:\Documents and Settings\All Users\Documentos\RAD Studio\5.0\Bpl\PluginSDK_D10R.bpl">PluginSDK for Delphi 10 (Runtime)</Excluded_Packages>
       <Excluded_Packages Name="$(BDS)\bin\dcloffice2k100.bpl">Microsoft Office 2000 Sample Automation Server Wrapper Components</Excluded_Packages>
@@ -86,6 +158,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
diff --git a/Source/Cliente/Utiles/VCLFlickerReduce.pas b/Source/Cliente/Utiles/VCLFlickerReduce.pas
new file mode 100644
index 00000000..d5290115
--- /dev/null
+++ b/Source/Cliente/Utiles/VCLFlickerReduce.pas
@@ -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.