New attempt to fix menu and buttons flicker on Win10, this time by wi…

…th the help of Delphi Detours library. See https://www.heidisql.com/forum.php?t=19141
HeidiSQL · Nov 1, 2017 · ef13e15 · ef13e15
1 parent b5765c9
commit ef13e15
Show file tree

Hide file tree

Showing 50 changed files with 13,399 additions and 14 deletions.
diff --git a/components/detours/Clean.bat b/components/detours/Clean.bat
@@ -0,0 +1,35 @@
+rem *****************************************
+rem *        Delphi CleanUp Batch.          *
+rem *                                       *
+rem * Clean identcache,local,dcu,exe,       *
+rem * map,drc files.                        *
+rem * Clean hidden __history folder.        *
+rem *                                       *
+rem *        Author: Mahdi Safsafi          *
+rem *****************************************
+
+@echo off
+Setlocal EnableDelayedExpansion
+
+Del "*.identcache" /s/q
+Del "*.local" /s/q
+Del "*.dcu" /s/q
+Del "*.exe" /s/q
+Del "*.drc" /s/q
+Del "*.map" /s/q
+
+set mustdel=false
+For /r %%f in (.) do (
+    set "mustdel=false"
+	if %%~nf==Win32 (
+		if exist "%%~ff\Debug\" set "mustdel=true"
+		if exist "%%~ff\Release\" set "mustdel=true"
+) else if %%~nf==Win64 (
+		if exist "%%~ff\Debug\" set "mustdel=true"
+		if exist "%%~ff\Release\" set "mustdel=true" 
+		)
+if %%~nf==__history set "mustdel=true"
+if !mustdel!==true (
+	if exist "%%~ff" rd /s/q "%%~ff"
+        )
+)
diff --git a/components/detours/Demo/DetoursDemo/COM/Demo1/Demo1.dpr b/components/detours/Demo/DetoursDemo/COM/Demo1/Demo1.dpr
@@ -0,0 +1,18 @@
+// JCL_DEBUG_EXPERT_GENERATEJDBG OFF
+program Demo1;
+
+uses
+  Vcl.Forms,
+  uMain in 'uMain.pas' {Main},
+  CPUID in '..\..\..\..\Source\CPUID.pas',
+  DDetours in '..\..\..\..\Source\DDetours.pas',
+  InstDecode in '..\..\..\..\Source\InstDecode.pas';
+
+{$R *.res}
+
+begin
+  Application.Initialize;
+  Application.MainFormOnTaskbar := True;
+  Application.CreateForm(TMain, Main);
+  Application.Run;
+end.
diff --git a/components/detours/Demo/DetoursDemo/COM/Demo1/Demo1.dproj b/components/detours/Demo/DetoursDemo/COM/Demo1/Demo1.dproj
diff --git a/components/detours/Demo/DetoursDemo/COM/Demo1/Demo1.res b/components/detours/Demo/DetoursDemo/COM/Demo1/Demo1.res
diff --git a/components/detours/Demo/DetoursDemo/COM/Demo1/uMain.dfm b/components/detours/Demo/DetoursDemo/COM/Demo1/uMain.dfm
@@ -0,0 +1,54 @@
+object Main: TMain
+  Left = 0
+  Top = 0
+  BorderStyle = bsSizeToolWin
+  Caption = 'Hooking IFileOpenDialog.Show Method'
+  ClientHeight = 196
+  ClientWidth = 447
+  Color = clBtnFace
+  Font.Charset = DEFAULT_CHARSET
+  Font.Color = clWindowText
+  Font.Height = -11
+  Font.Name = 'Tahoma'
+  Font.Style = []
+  OldCreateOrder = False
+  PixelsPerInch = 96
+  TextHeight = 13
+  object BtnOpenDialog: TButton
+    Left = 304
+    Top = 97
+    Width = 121
+    Height = 25
+    Caption = 'Open File Dialog'
+    TabOrder = 0
+    OnClick = BtnOpenDialogClick
+  end
+  object MemLog: TMemo
+    Left = 0
+    Top = 0
+    Width = 447
+    Height = 81
+    Align = alTop
+    Lines.Strings = (
+      'MemLog')
+    TabOrder = 1
+  end
+  object BtnEnableHook: TButton
+    Left = 304
+    Top = 128
+    Width = 121
+    Height = 25
+    Caption = 'Enable Hook'
+    TabOrder = 2
+    OnClick = BtnEnableHookClick
+  end
+  object BtnDisableHook: TButton
+    Left = 304
+    Top = 159
+    Width = 121
+    Height = 25
+    Caption = 'Disable Hook'
+    TabOrder = 3
+    OnClick = BtnDisableHookClick
+  end
+end
diff --git a/components/detours/Demo/DetoursDemo/COM/Demo1/uMain.pas b/components/detours/Demo/DetoursDemo/COM/Demo1/uMain.pas
@@ -0,0 +1,78 @@
+unit uMain;
+
+interface
+
+uses
+  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
+  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, DDetours;
+
+type
+  TMain = class(TForm)
+    BtnOpenDialog: TButton;
+    MemLog: TMemo;
+    BtnEnableHook: TButton;
+    BtnDisableHook: TButton;
+    procedure BtnOpenDialogClick(Sender: TObject);
+    procedure BtnEnableHookClick(Sender: TObject);
+    procedure BtnDisableHookClick(Sender: TObject);
+  private
+    { Private declarations }
+  public
+    { Public declarations }
+  end;
+
+var
+  Main: TMain;
+
+implementation
+
+uses ShlObj, ComObj;
+{$R *.dfm}
+
+var
+  Trampoline_FileOpenDialog_Show: function(const Self; hwndParent: HWND): HRESULT; stdcall;
+  Trampoline_FileOpenDialog_SetTitle: function(const Self; pszTitle: LPCWSTR): HRESULT; stdcall;
+
+function FileOpenDialog_SetTitle_Hook(const Self; pszTitle: LPCWSTR): HRESULT; stdcall;
+begin
+  Result := Trampoline_FileOpenDialog_SetTitle(Self, 'Hooked');
+end;
+
+function FileOpenDialog_Show_Hook(const Self; hwndParent: HWND): HRESULT; stdcall;
+begin
+  Main.MemLog.Lines.Add('Execution FileOpenDialog.Show ..');
+  Result := Trampoline_FileOpenDialog_Show(Self, hwndParent);
+end;
+
+var
+  FileOpenDialog: IFileOpenDialog;
+
+procedure TMain.BtnOpenDialogClick(Sender: TObject);
+begin
+  MemLog.Clear;
+  FileOpenDialog.SetTitle('Open..');
+  FileOpenDialog.Show(Handle);
+end;
+
+procedure TMain.BtnEnableHookClick(Sender: TObject);
+begin
+  if not Assigned(Trampoline_FileOpenDialog_Show) then
+    @Trampoline_FileOpenDialog_Show := InterceptCreate(FileOpenDialog, 3, @FileOpenDialog_Show_Hook);
+  Trampoline_FileOpenDialog_SetTitle := InterceptCreate(FileOpenDialog, 17, @FileOpenDialog_SetTitle_Hook);
+end;
+
+procedure TMain.BtnDisableHookClick(Sender: TObject);
+begin
+  if Assigned(Trampoline_FileOpenDialog_Show) then
+  begin
+    InterceptRemove(@Trampoline_FileOpenDialog_Show);
+    Trampoline_FileOpenDialog_Show := nil;
+  end;
+  InterceptRemove(@Trampoline_FileOpenDialog_SetTitle)
+end;
+
+initialization
+
+FileOpenDialog := CreateComObject(CLSID_FileOpenDialog) as IFileOpenDialog;
+
+end.
diff --git a/components/detours/Demo/DetoursDemo/Delphi/Hook_Overloaded_Method/Hook_Overloaded_Method.dpr b/components/detours/Demo/DetoursDemo/Delphi/Hook_Overloaded_Method/Hook_Overloaded_Method.dpr
@@ -0,0 +1,47 @@
+program Hook_Overloaded_Method;
+
+{$APPTYPE CONSOLE}
+{$R *.res}
+
+uses
+  System.SysUtils,
+  CPUID in '..\..\..\..\Source\CPUID.pas',
+  DDetours in '..\..\..\..\Source\DDetours.pas',
+  InstDecode in '..\..\..\..\Source\InstDecode.pas';
+
+type
+  TShowMsg = procedure(Value: Integer);
+
+var
+
+  TrampoShowMsg: TShowMsg;
+  { When hooking overloaded method ,
+    Delphi does not reconize the desired method .
+    So we need to use this trick!
+  }
+  MyMethodPtr: TShowMsg;
+
+procedure ShowMsg(const S: String); overload;
+begin
+  Writeln(S);
+end;
+
+procedure ShowMsg(Value: Integer); overload;
+begin
+  Writeln(Value);
+end;
+
+procedure ShowMsgHooked(Value: Integer);
+begin
+  Writeln('Method hooked successfully!');
+  TrampoShowMsg(Value + 1);
+end;
+
+begin
+  MyMethodPtr := ShowMsg;
+  @TrampoShowMsg := InterceptCreate(@MyMethodPtr, @ShowMsgHooked);
+  ShowMsg('Hi');
+  ShowMsg(2015);
+  ReadLn;
+
+end.