From da570a2380ecc1ceecbf23718da576cb1a2500a9 Mon Sep 17 00:00:00 2001
From: david <darranz@rodax-software.com>
Date: Wed, 27 Feb 2008 18:39:57 +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.Tecsitel_FactuGES2/trunk@304 0c75b7a4-871f-7646-8a2f-f78d34cc349f
---
 Source/Cliente/FactuGES.dpr                |   3 +-
 Source/Cliente/FactuGES.dproj              |   1 +
 Source/Cliente/FactuGES.rc                 |   9 +-
 Source/Cliente/FactuGES.res                | Bin 172156 -> 171984 bytes
 Source/Cliente/Utiles/VCLFlickerReduce.pas | 392 +++++++++++++++++++++
 5 files changed, 400 insertions(+), 5 deletions(-)
 create mode 100644 Source/Cliente/Utiles/VCLFlickerReduce.pas

diff --git a/Source/Cliente/FactuGES.dpr b/Source/Cliente/FactuGES.dpr
index ce8466be..c09588ae 100644
--- a/Source/Cliente/FactuGES.dpr
+++ b/Source/Cliente/FactuGES.dpr
@@ -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}
 
diff --git a/Source/Cliente/FactuGES.dproj b/Source/Cliente/FactuGES.dproj
index af337700..3e33a725 100644
--- a/Source/Cliente/FactuGES.dproj
+++ b/Source/Cliente/FactuGES.dproj
@@ -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
diff --git a/Source/Cliente/FactuGES.rc b/Source/Cliente/FactuGES.rc
index 4be492fe..b92ede00 100644
--- a/Source/Cliente/FactuGES.rc
+++ b/Source/Cliente/FactuGES.rc
@@ -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"
diff --git a/Source/Cliente/FactuGES.res b/Source/Cliente/FactuGES.res
index eeef62019759718b5f18c693b8414822bf3f87ca..ec67bce1491723847aadd1a93e5d62d87aa96eff 100644
GIT binary patch
delta 284
zcmY+9u?m7v6o$Wh(^8WVS{#K48XA0oK$;vI+AC=2Eplk^0fIYeYeQpujg3A-b3+dh
z)D=bPhr{9HKj(1%&)q3*PI3@eX=MA*b6gq;Ts#j1K0CAQ4H+Qu{mOfEq0>-mgFz5f
z-q`}PC4H?+7}nkZdM%AvVG%`@Ihlh^99NVs!C}3w7mv^<N$N?fd=%aS0^Pq~PnQO*
ikT%d;sAneQp`nBPYoTVj9Eqvg<Z`86x!kJaBriX8)F%)C

delta 454
zcmY+9F-yZx6otR{Olum81Y9}>ilR>W142=e41!DdHmD>;tEIX)HG@NcfRLrFYZf<G
z(b3V-+22v9H+iYW1NYr`IOp8^-q*V`|8SB=^{TDu$aS4Me^AtMT~OG>mAo6~5nG^X
zG>rCHg|(7-jB8-wc}B}@sFchjlWA3aztlEiy=0<o(~(83RxWz%9zu;EFl^ighi=!f
z><KnVlG17C4~2<Fa<EvqQc7;%v-;3Pr$192Y~`u{n5PFb-BjOcIMbcIebE&s^tk4d
zW2rmN844e8FXt^cCZ4{{bTry2?5ARj2qkhPh5-*nAR?BCff>8<wZ#!~A-TTvAy=|y
Z3FAF0XY^!YK6&}1ob@GFAZ<SDmtSO^Km`B*

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.