Subversion Repositories userdetect2

unit VTSCompat;

{$IF CompilerVersion >= 25.0}

{$LEGACYIFEND ON}

{$IFEND}

{$WARN UNSAFE_CODE OFF}

{$WARN UNSAFE_TYPE OFF}

{$WARN UNSAFE_CAST OFF}

interface

uses

  Dialogs, Windows, Controls, Graphics, SysUtils, CommDlg, Classes;

function AddTransparentIconToImageList(ImageList: TImageList; Icon: TIcon): integer;

function CompatOpenDialogExecute(OpenDialog: TOpenDialog): boolean;

function CompatSaveDialogExecute(SaveDialog: TSaveDialog): boolean;

implementation

uses

  PatchU, ShlObj, ShellAPI;

var

  pp: TPatchMethod;

// --- CompatOpenDialogExecute

type

  TExtOpenDialogAccessor = class(TOpenDialog);

  TExtOpenDialog = class(TOpenDialog)

  protected

    function TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool; override;

  end;

function TExtOpenDialog.TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool;

begin

  TOpenFileName(DialogData).Flags :=

  TOpenFileName(DialogData).Flags and not OFN_ENABLETEMPLATE;

  TOpenFileName(DialogData).Flags :=

  TOpenFileName(DialogData).Flags and not OFN_ENABLEHOOK;

  if pp.IsPatched then pp.Restore;

  result := inherited TaskModalDialog(DialogFunc, DialogData);

end;

function CompatOpenDialogExecute(OpenDialog: TOpenDialog): boolean;

{$IF CompilerVersion < 18.5} // prior to Delphi 2007

var

  x: TExtOpenDialog;

  MethodPtr, MethodPtr2: function(DialogFunc: Pointer; var DialogData): Bool of object;

begin

  MethodPtr := TExtOpenDialogAccessor(OpenDialog).TaskModalDialog;

  x := TExtOpenDialog.Create(nil);

  try

    MethodPtr2 := x.TaskModalDialog;

    pp := TPatchMethod.Create(@MethodPtr, @MethodPtr2);

    try

      result := OpenDialog.Execute;

      if pp.IsPatched then pp.Restore;

    finally

      pp.Free;

    end;

  finally

    x.Free;

  end;

{$ELSE}

begin

  result := OpenDialog.Execute;

{$IFEND}

end;

// --- CompatSaveDialogExecute

type

  TExtSaveDialogAccessor = class(TSaveDialog);

  TExtSaveDialog = class(TSaveDialog)

  protected

    function TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool; override;

  end;

function TExtSaveDialog.TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool;

begin

  // Remove the two flags which let the File Dialog GUI fall back to the old design.

  TOpenFileName(DialogData).Flags :=

  TOpenFileName(DialogData).Flags and not OFN_ENABLETEMPLATE;

  TOpenFileName(DialogData).Flags :=

  TOpenFileName(DialogData).Flags and not OFN_ENABLEHOOK;

  // It is important to restore TaskModalDialog, so we don't get a stack

  // overflow when calling the inherited method.

  if pp.IsPatched then pp.Restore;

  result := inherited TaskModalDialog(DialogFunc, DialogData);

end;

function CompatSaveDialogExecute(SaveDialog: TSaveDialog): boolean;

{$IF CompilerVersion < 18.5} // prior to Delphi 2007

var

  x: TExtSaveDialog;

  MethodPtr, MethodPtr2: function(DialogFunc: Pointer; var DialogData): Bool of object;

begin

  MethodPtr := TExtSaveDialogAccessor(SaveDialog).TaskModalDialog;

  x := TExtSaveDialog.Create(nil);

  try

    MethodPtr2 := x.TaskModalDialog;

    pp := TPatchMethod.Create(@MethodPtr, @MethodPtr2);

    try

      result := SaveDialog.Execute;

    finally

      pp.Free;

    end;

  finally

    x.Free;

  end;

{$ELSE}

begin

  result := OpenDialog.Execute;

{$IFEND}

end;

// --- AddTransparentIconToImageList

function RealIconSize(H: HIcon): TPoint;

// http://www.delphipages.com/forum/showthread.php?t=183999

var

  IconInfo: TIconInfo;

  bmpmask: TBitmap;

begin

  result := Point(0, 0);

  if H <> 0 then

  begin

    bmpmask := TBitmap.Create;

    try

      IconInfo.fIcon := true;

      try

        GetIconInfo(H, IconInfo);

        bmpmask.Handle := IconInfo.hbmMask;

        bmpmask.Dormant; //lets us free the resource without 'losing' the bitmap

      finally

        DeleteObject(IconInfo.hbmMask);

        DeleteObject(IconInfo.hbmColor)

      end;

      result := Point(bmpmask.Width, bmpmask.Height);

    finally

      bmpmask.Free;

    end;

  end;

end;

function AddTransparentIconToImageList(ImageList: TImageList; Icon: TIcon): integer;

// http://www.delphipages.com/forum/showthread.php?t=183999

var

  buffer, mask: TBitmap;

  p: TPoint;

begin

  // result := ImageList.AddIcon(ico);

  // --> In Delphi 6, Icons with half-transparency have a black border (e.g. in ListView)

  p := RealIconSize(icon.handle);

  buffer := TBitmap.Create;

  mask := TBitmap.Create;

  try

    buffer.PixelFormat := pf24bit;

    mask.PixelFormat := pf24bit;

    buffer.Width := p.X;

    buffer.Height := p.Y;

    buffer.Canvas.Draw(0, 0, icon);

    buffer.Transparent := true;

    buffer.TransparentColor := buffer.Canvas.Pixels[0,0];

    if (ImageList.Width <> p.X) or (ImageLIst.Height <> p.Y) then

    begin

      ImageList.Width := p.X;

      ImageList.Height := p.Y;

    end;

    // create a mask for the icon.

    mask.Assign(buffer);

    mask.Canvas.Brush.Color := buffer.Canvas.Pixels[0, buffer.Height -1];

    mask.Monochrome := true;

    result := ImageList.Add(buffer, mask);

  finally

    mask.Free;

    buffer.Free;

  end;

end;

end.