unit UtilFunc;

interface

uses
  windows,
  messages;

//
//--------------- Global Types, Constants and Variables ----------
//
const
  IDM_EXIT = 200;
  IDM_TEST = 201;
  IDM_ABOUT = 202;

type
  TTestProc = procedure(hWnd:HWND);


//
//--------------- window support functions ------------------------
//
function GetExeName: string;
function MakeMainWindow(WndProc:TFNWndProc): HWND;
function MessageLoopNormal: integer;

function ChangeWindowPos(hWindow: HWND; x,y: integer):Boolean;
function ChangeWindowSize(hWindow: HWND; cx,cy: integer):Boolean;
function ChangeWindowZOrder(hWindow: HWND; hWndInsertAfter: HWND):Boolean;

function CenterWindow(hWindow: HWND): Boolean;
function EraseBkGnd(hWindow: HWND;Clr:COLORREF;DC: HDC):LRESULT;

procedure MakeInitMenu(hWindow: HWND);
procedure InitMenuCommand(var Msg: TMessage;OnTest:TTestProc);


//
//--------------- utility functions -------------------------------
//
function wsprintf1(Output,Format: PChar;pr1: integer): Integer; cdecl;
function wsprintf2(Output,Format: PChar;pr1,pr2: integer): Integer; cdecl;
function wsprintf3(Output,Format: PChar;pr1,pr2,pr3: integer): Integer; cdecl;
function wsprintf4(Output,Format: PChar;pr1,pr2,pr3,pr4: integer): Integer; cdecl;

function AIntToStr(value: integer):string;
function AIntToHex(value: Integer; digits: Integer): string;


implementation                                       

//
//--------------- window support functions ------------------------
//
function GetLowDir(var Path: string): Boolean;
var
  p,Len: integer;
begin
  result := false;
  p := Pos('\',Path);
  if p <> 0 then begin
    result := true;
    Len := Length(Path)-p;
    Path := Copy(Path,p+1,Len);
    SetLength(Path,Len);
  end;
end;

function GetExeName: string;
var
  s,t: string;
  buf: array[0..MAX_PATH] of Char;
  Len: integer;
begin
  Len := GetModuleFileName(0,buf,SizeOf(buf));
  SetString(s,buf,Len);
  t := s;
  while GetLowDir(t) do s := t;
  Len := Pos('.',s);
  result := Copy(s,0,Len-1);
end;

function MakeMainWindow(WndProc:TFNWndProc): HWND;
var
  wc: TWndClass;
  hWindow: HWND;
  s: string;
begin
  s := GetExeName;

  wc.lpszClassName   := PChar(s);
  wc.lpfnWndProc     := WndProc;
  wc.style           := CS_VREDRAW or CS_HREDRAW;
  wc.hInstance       := hInstance;
  wc.hIcon           := LoadIcon(0,IDI_APPLICATION);
  wc.hCursor         := LoadCursor(0,IDC_ARROW);
  wc.hbrBackground   := (COLOR_WINDOW+1);
  wc.lpszMenuName    := nil;
  wc.cbClsExtra      := 0;
  wc.cbWndExtra      := 0;

  RegisterClass( wc );

  hWindow := CreateWindowEx(WS_EX_CONTROLPARENT or WS_EX_WINDOWEDGE,
                          PChar(s),
                          PChar(s),
                          WS_VISIBLE or WS_OVERLAPPEDWINDOW,
                          200,100,
                          300,200,
                          0,
                          0,
                          hInstance,
                          nil);

  ShowWindow(hWindow,CmdShow);
  UpDateWindow(hWindow);
  result := hWindow;
end;

function MessageLoopNormal: integer;
var
  Msg: TMsg;
begin
  while GetMessage(Msg, 0, 0, 0) do begin
    TranslateMessage(Msg);
    DispatchMessage(Msg);
  end;
  result := Msg.wParam;
end;

function ChangeWindowPos(hWindow: HWND; x,y: integer):Boolean;
begin
  result := SetWindowPos(hWindow,0,x,y,0,0,SWP_NOSIZE or SWP_NOZORDER);
end;

function ChangeWindowSize(hWindow: HWND; cx,cy: integer):Boolean;
begin
  result := SetWindowPos(hWindow,0,0,0,cx,cy,SWP_NOMOVE or SWP_NOZORDER);
end;

function ChangeWindowZOrder(hWindow: HWND; hWndInsertAfter: HWND):Boolean;
begin
  result := SetWindowPos(hWindow,hWndInsertAfter,0,0,0,0,SWP_NOSIZE or SWP_NOMOVE);
end;

function CenterWindow(hWindow: HWND): Boolean;
var
  r:TRect;
  CSX,CSY,w,h: integer;
begin
  CSX := GetSystemMetrics(SM_CXSCREEN);
  CSY := GetSystemMetrics(SM_CYSCREEN);
  GetWindowRect(hWindow,r);
  w := r.Right-r.Left;
  h := r.Bottom-r.Top;
  result := ChangeWindowPos(hWindow,(CSX-w) div 2, (CSY-h) div 2);
end;

function EraseBkGnd(hWindow: HWND;Clr:COLORREF;DC: HDC):LRESULT;
var
  hBr: hBrush;
  r: TRect;
begin
  hBr := CreateSolidBrush(Clr);
  GetClientRect(hWindow,r);
  FillRect(DC,r,hBr);
  DeleteObject(hBr);
  result := 1;
end;

procedure MakeInitMenu(hWindow: HWND);
var
  hM, hMp: HMENU;
begin
  hM := CreateMenu;

  hMp := CreateMenu;
  AppendMenu(hMp,MF_STRING,IDM_EXIT, 'E&xit');
  AppendMenu(hM,MF_POPUP,hMp,'&File');

  AppendMenu(hM, MF_STRING, IDM_TEST, '&Test!');

  hMp := CreateMenu;
  AppendMenu(hMp,MF_STRING,IDM_ABOUT, '&About..');
  AppendMenu(hM,MF_POPUP,hMp,'&Help');

  SetMenu(hWindow,hM);
end;

procedure InitMenuCommand(var Msg: TMessage;OnTest:TTestProc);
var
  hWindow: HWND;
  s: string;
begin
  hWindow := Msg.Msg;
  if Msg.WParamHi=0 then // Menu=0,Accel=1,NotifyCode=Control
    case Msg.WParamLo of
      IDM_EXIT: DestroyWindow(hWindow);
      IDM_TEST: OnTest(hWindow);
      IDM_ABOUT:begin
        s := 'OBJECT PASCAL API PROGRAM '+#13#13+
             '          By  Delphian Inc.,'+#13#13+
             '         Created by Delphi 3    '+#13#13;
        MessageBox(hWindow,PChar(s),'About ...',MB_OK);
        end;
    end;
end;

//
//--------------- utility functions -------------------------------
//
function wsprintf1; external 'user32.dll' name 'wsprintfA';
function wsprintf2; external 'user32.dll' name 'wsprintfA';
function wsprintf3; external 'user32.dll' name 'wsprintfA';
function wsprintf4; external 'user32.dll' name 'wsprintfA';

function AIntToStr(value: integer):string;
var
  i: integer;
  pBuf: PChar;
begin
  GetMem(pBuf,20);
  i := wsprintf1(pBuf,'%d',value);
  SetString(result,pBuf,i);
  FreeMem(pBuf);
end;

function AIntToHex(value: Integer; digits: Integer): string;
var
  i: integer;
  s: string;
  pBuf: PChar;
begin
  GetMem(pBuf,20);
  i := wsprintf1(pBuf,'%d',digits);
  SetString(s,pBuf,i);
  s := '%.'+s+'X';
  i := wsprintf1(pBuf,PChar(s),value);
  SetString(result,pBuf,i);
  FreeMem(pBuf);
end;

end.