{ *********************************************************************** }
{                                                                         }
{ Delphi Visual Component Library                                         }
{                                                                         }
{ Copyright (c) 2001-2004 Borland Software Corporation                    }
{                                                                         }
{ *********************************************************************** }

unit Borland.Vcl.WinUtils platform;

interface

uses
  SysUtils, Windows, Messages;

{ NativeBufToArray copies an array of valuetyes from an unmanaged
  memory buffer to a managed array }

function NativeBufToArray(Buffer: IntPtr; Data: System.Array): System.Array;

{ ArrayToNativeBuf copies an array of valuetypes to an unmanaged
  memory buffer. The buffer must be deallocated using
  Marshal.FreeHGlobal }

function ArrayToNativeBuf(Data: System.Array; Buffer: IntPtr = nil): IntPtr;

type
  TWndMethod = procedure(var Message: TMessage) of object;

function MakeObjectInstance(Method: TWndMethod): TFNWndProc;
procedure FreeObjectInstance(ObjectInstance: TFNWndProc);

function AllocateHWnd(Method: TWndMethod): HWND;
procedure DeallocateHWnd(Wnd: HWND);

function PointToLParam(P: TPoint): LPARAM;

function GetCmdShow: Integer;

procedure SafeArrayCheck(AResult: HRESULT);

{ BytesToStructure copies a structure stored in an array of bytes
  into a structure }

function BytesToStructure(const Bytes: TBytes; AType: System.Type): TObject;

{ StructureToBytes copies a structure into an array of bytes }

function StructureToBytes(const Struct: TObject): TBytes;

{ Return the handle of the module/instance }

function HInstance: HINST;

{ Return the handle of the main(.EXE) HInstance }

function MainInstance: HINST;

implementation

uses
  SysConst, System.Text, System.Collections, System.Runtime.InteropServices,
  System.Reflection;

function NativeBufToArray(Buffer: IntPtr; Data: System.Array): System.Array;
var
  I, LowerBound: Integer;
  Size: Longint;
begin
  Result := Data;
  LowerBound := Data.GetLowerBound(0);
  Size := Marshal.SizeOf(Data.GetType.GetElementType);

  for I := 0 to Data.Length - 1 do
  begin
    Result.SetValue(Marshal.PtrToStructure(IntPtr(Longint(Buffer) + (I * Size)),
      Data.GetType.GetElementType), I + LowerBound);
  end;
end;

function ArrayToNativeBuf(Data: System.Array; Buffer: IntPtr = nil): IntPtr;
var
  I, LowerBound: Integer;
  Size: Longint;
begin
  LowerBound := Data.GetLowerBound(0);
  Size := Marshal.SizeOf(Data.GetType.GetElementType);
  with Marshal do
  begin
    if Buffer = nil then
      Result := AllocHGlobal(Size * Data.Length)
    else
      Result := Buffer;
    try
      for I := 0 to Data.Length - 1 do
        StructureToPtr(TObject(Data.GetValue(I + LowerBound)),
          IntPtr(Longint(Result) + (I * Size)), False);
    except
      if Buffer = nil then FreeHGlobal(Result);
      raise;
    end;
  end;
end;

const
  InstanceCount = 313;

{ Object instance management }

type
  TObjectInstance = class
    FWndMethod: TWndMethod;
    function WndProc(Handle: HWND; Msg: UINT; WParam: WPARAM; LParam: LPARAM): LRESULT;
    constructor Create(WndMethod: TWndMethod);
  end;

constructor TObjectInstance.Create(WndMethod: TWndMethod);
begin
  inherited Create;
  FWndMethod := WndMethod;
end;

function TObjectInstance.WndProc(Handle: HWND; Msg: UINT; WParam: WPARAM; LParam: LPARAM): LRESULT;
var
  Message: TMessage;
begin
  Message := TMessage.Create(Msg, WParam, LParam);
  FWndMethod(Message);
  Result := Message.Result;
end;

function MakeObjectInstance(Method: TWndMethod): TFNWndProc;
var
  Instance: TObjectInstance;
begin
  Instance := TObjectInstance.Create(Method);
  Result := Instance.WndProc;
end;

procedure FreeObjectInstance(ObjectInstance: TFNWndProc);
begin
 // Nothing to do
end;

var
  UtilWindowClass: TWndClass = (
    style: 0;
    lpfnWndProc: @DefWindowProc;
    cbClsExtra: 0;
    cbWndExtra: 0;
    hInstance: 0;
    hIcon: 0;
    hCursor: 0;
    hbrBackground: 0;
    lpszMenuName: '';
    lpszClassName: 'TPUtilWindow');
  Instances: Hashtable;

function AllocateHWnd(Method: TWndMethod): HWND;
var
  TempClassInfo: TWndClassInfo;
  //TempClass: TWndClass;
  ClassRegistered: Boolean;
  Instance: TFNWndProc;
begin
  UtilWindowClass.hInstance := HInstance;
  ClassRegistered := GetClassInfo(HInstance, UtilWindowClass.lpszClassName,
    TempClassInfo);
  if not ClassRegistered {or (TempClass.lpfnWndProc <> @DefWindowProc)} then
    RegisterClass(UtilWindowClass);
  Result := CreateWindowEx(WS_EX_TOOLWINDOW, UtilWindowClass.lpszClassName,
    '', WS_POPUP {+ 0}, 0, 0, 0, 0, 0, 0, HInstance, nil);
  if Assigned(Method) then
  begin
    Instance := MakeObjectInstance(Method);
    if not Assigned(Instances) then
      Instances := Hashtable.Create;
    Instances[TObject(Result)] := @Instance;
    SetWindowLong(Result, GWL_WNDPROC, @Instance);
  end;
end;

procedure DeallocateHWnd(Wnd: HWND);
begin
  if Instances <> nil then
    Instances[TObject(Wnd)] := nil;
  DestroyWindow(Wnd);
end;

function PointToLParam(P: TPoint): LPARAM;
begin
  Result := LongInt((P.X and $0000ffff) or (P.Y shl 16))
end;

function GetCmdShow: Integer;
var
  SI: TStartupInfo;
begin
  Result := 10;                  { SW_SHOWDEFAULT }
  GetStartupInfo(SI);
  if SI.dwFlags and 1 <> 0 then  { STARTF_USESHOWWINDOW }
    Result := SI.wShowWindow;
end;

{ SafeArray Utility Functions }

type
  ESafeArrayError = class(Exception)
  private
    FErrorCode: HRESULT;
  public
    constructor CreateHResult(AResult: HRESULT; const AMessage: string = '');
    property ErrorCode: HRESULT read FErrorCode write FErrorCode;
  end;

  ESafeArrayBoundsError = class(ESafeArrayError);
  ESafeArrayLockedError = class(ESafeArrayError);

const
  VAR_BADINDEX      = HRESULT($8002000B); // = Windows.DISP_E_BADINDEX
  VAR_ARRAYISLOCKED = HRESULT($8002000D); // = Windows.DISP_E_ARRAYISLOCKED

constructor ESafeArrayError.CreateHResult(AResult: HRESULT; const AMessage: string);
var
  S: string;
begin
  S := AMessage;
  if S = '' then
    S := Format(SVarArrayWithHResult, [AResult]);
  Create(S);
  FErrorCode := AResult;
end;

procedure SafeArrayError(AResult: HRESULT);
begin
  case AResult of
    VAR_BADINDEX:      raise ESafeArrayBoundsError.CreateHResult(AResult, SVarArrayBounds);
    VAR_ARRAYISLOCKED: raise ESafeArrayLockedError.CreateHResult(AResult, SVarArrayLocked);
  else
    raise ESafeArrayError.CreateHResult(AResult);
  end;
end;

procedure SafeArrayCheck(AResult: HRESULT);
begin
  if AResult and $80000000 <> 0 then
    SafeArrayError(AResult);
end;

function BytesToStructure(const Bytes: TBytes; AType: System.Type): TObject;
var
  Size: Integer;
  Buffer: IntPtr;
begin
  Size := Marshal.SizeOf(AType);
  Buffer := Marshal.AllocHGlobal(Size);
  try
    Marshal.Copy(Bytes, 0, Buffer, Size);
    Result := Marshal.PtrToStructure(Buffer, AType);
  finally
    Marshal.FreeHGlobal(Buffer);
  end;
end;

function StructureToBytes(const Struct: TObject): TBytes;
var
  Buffer: IntPtr;
begin
  Buffer := Marshal.AllocHGlobal(Marshal.SizeOf(TypeOf(Struct)));
  try
    Marshal.StructureToPtr(Struct, Buffer, False);
    SetLength(Result, Marshal.SizeOf(TypeOf(Struct)));
    Marshal.Copy(Buffer, Result, 0, Length(Result));
  finally
    Marshal.FreeHGlobal(Buffer);
  end;
end;

function HInstance: HINST;
begin
  Result := HINST(Marshal.GetHInstance(Assembly.GetCallingAssembly.GetModules[0]));
end;

function MainInstance: HINST;
begin
  if not IsLibrary then
    Result := HINST(Marshal.GetHInstance(Assembly.GetEntryAssembly.GetModules[0]))
  else
    Result := 0;
end;

end.
