unawinclasses.pas

Voice Commnucation Components for Delphi

    function onDrawFrame(): bool; virtual;
    function onRunEnterLeave(enter: bool): bool; override;
    function doCreateWindow(): hWnd; override;
    procedure skipFrame();
  public
    constructor create(fps: unsigned = 20; frameWidth: unsigned = 700; frameHeight: unsigned = 500; bgColor: COLORREF = 0; const title: string = ''; canResize: bool = true; canMinimize: bool = true; x: int = 50; y: int = 20; icon: int = -1; windowFlags: int = -1; windowExFlags: int = -1; memWidth: int = -1; memHeight: int = -1); overload;
    constructor create(wnd: hWnd; fps: unsigned = 20; bgColor: COLORREF = 0; const title: string = ''; canResize: bool = true; memWidth: int = -1; memHeight: int = -1); overload;
    destructor Destroy(); override;
    //
    function setBits(x, y: int; data: pointer; size: unsigned): unsigned;
    //
    property grDC: hDC read f_grDC;
    property memDC: hDC read f_memDC;
    //
    property memDIB: hBITMAP read f_memDIB;
    property memDIBInfo: BITMAPINFO read f_memBmpInfo;
    property memXSize: int read f_memXSize;
    property memYSize: int read f_memYSize;
    //
    property fps: unsigned read f_fps;
    property actualFps: unsigned read f_actualFps;
    property frameWidth: unsigned read f_frameWidth;
    property frameHeight: unsigned read f_frameHeight;
    property bgColor: unsigned read f_bgColor;
    //
    property eraseBg: bool read f_eraseBg write f_eraseBg;
  end;


  //
  // -- unaWinBitmap --
  //
  {DP:CLASS
    Windows bitmap.
  }
  unaWinBitmap = class
  private
    //f_bitmap: hBITMAP;
    //f_dc: hDC;
  public
  end;


const
  btnCmdExit	= 1004;
  btnCmdStart	= 1005;
  btnCmdStop	= 1006;

  btnCmdFirstAvail	= 1100;

type
  //
  // -- unaWinConsoleApp --
  //
  {DP:CLASS
    Simple console-like application main window class.
  }
  unaWinConsoleApp = class(unaWinApp)
  private
    f_ini: unaIniAbstractStorage;
    f_memo: unaWinMemo;
    f_btnExit: unaWinButton;
    f_btnStart: unaWinButton;
    f_btnStop: unaWinButton;
    f_captionHeight: unsigned;
    f_hasGUI: bool;
    //
  protected
    {DP:METHOD
      WM_COMMAND message handler. cmd values below 10 are reserved for internal usage.
    }
    function onCommand(cmd, wnd: int): bool; override;
    {DP:METHOD
      WM_DESTROY message handler.
    }
    function onDestroy(): bool; override;
    {DP:METHOD
      Called on the start of application.
    }
    procedure onStart(); virtual;
    {DP:METHOD
      Called on the end of application.
    }
    procedure onStop(); virtual;
    {DP:METHOD
      This method can be used to perform additional initialization.
    }
    function doInit(): bool; virtual;
    {DP:METHOD
      This method is used to display "console" memo messages.
    }
    procedure idle(); override;
  public
    {DP:METHOD
      Creates console-like window.
    }
    constructor create(hasGUi: bool; const caption, copy: string; const iniFile: string = ''; icon: hIcon = 0; captionHeight: unsigned = 32; btnExit: bool = true; btnStart: bool = false; btnStop: bool = false; style: unsigned = WS_OVERLAPPEDWINDOW; exStyle: unsigned = WS_EX_CONTROLPARENT);
    {DP:METHOD
    }
    destructor Destroy(); override;
    //
    {DP:METHOD
      Exit button.
    }
    property btnExit: unaWinButton read f_btnExit;
    {DP:METHOD
      Start button.
    }
    property btnStart: unaWinButton read f_btnStart;
    {DP:METHOD
      Stop button.
    }
    property btnStop: unaWinButton read f_btnStop;
    {DP:METHOD
      Height of upper panel with buttons.
    }
    property captionHeight: unsigned read f_captionHeight;
    //
    property hasGUI: bool read f_hasGUI;
  end;


{DP:METHOD
  Returns Windows class encapsulation instance by given class name.
  Class will be created and registered if necessary.
}
// -- getClass() --
function getClass(const className: string = ''; isStdClass: bool =  false; style: unsigned = 0; icon: hIcon = 0; smallIcon: hIcon = 0; cursor: hCursor = 0; brBrush: hBrush = COLOR_WINDOW; menuName: int = 0; instance: hModule = 0; force: bool = true): unaWinClass;


implementation


uses
  unaUtils;

function ChooseFont;  external 'comdlg32.dll'  name 'ChooseFontA';
function ChooseFontA; external 'comdlg32.dll'  name 'ChooseFontA';
function ChooseFontW; external 'comdlg32.dll'  name 'ChooseFontW';

type
  //
  // --  --
  //
  unaWinList = class(unaIdList)
  protected
    function getId(item: pointer): int64; override;
  public
    function callWndProc(index: int; message: int; wParam: int; lParam: int; window: hWnd = 0): int;
  end;


{ unaWinList }

// --  --
function unawinList.callWndProc(index, message, wParam, lParam: int; window: hWnd): int;
var
  w: unaWinWindow;
begin
  w := unaWinWindow(get(index));
  //
  if (nil <> w) then
    result := w.wndProc(message, wParam, lParam)
  else
    result := DefWindowProc(window, message, wParam, lParam);
end;

// --  --
function unaWinList.getId(item: pointer): int64;
begin
  if (nil <> item) then
    result := unaWinWindow(item).wnd
  else
    result := 0;
end;




var
  g_winList: unaWinList;
  g_winCreateClass: unaWinWindow;
  g_winClasses: unaList;
  g_winFonts: unaList;
  g_winCreateGate: unaInProcessGate;

// -- --
function getClass(const className: string; isStdClass: bool; style: unsigned; icon, smallIcon: hIcon; cursor: hCursor; brBrush: hBrush; menuName: int; instance: hModule; force: bool): unaWinClass;
var
  i: unsigned;
begin
  result := nil;
  i := 0;
  //
  if (nil <> g_winClasses) then begin
    //
    while (i < g_winClasses.count) do begin
      //
      result := g_winClasses.get(i);
      if ((0 <> result.atom) or result.isCommon) then begin
	//
	if (result.f_wndClass.lpszClassName = className) then
	  break
	else
	  result := nil;
	//
      end
      else
	result := nil;
      //
      inc(i);
    end;
  end;
  //
  if (nil = result) then
    if (isStdClass) then
      result := unaWinClass.createStdClass(className)
    else
      result := unaWinClass.create(className, style, icon, smallIcon, cursor, brBrush, menuName, instance, force);
end;

// --  --
function unaWndProc(window: hWnd; message, wParam, lParam: int): int; stdcall;
var
  i: int;
  long: unsigned;
begin
  // 1. try to locate this window in our winList
  long := GetWindowLong(window, 0);
  if ($19730000 = long and $FFFF0000) then
    // looks like our window
    i := long and $FFFF
  else
    // could be standard class window
    i := g_winList.locateById(window);

  //
  if (0 > i) then begin
    //
    if (nil <> g_winCreateClass) then begin
      //
      g_winCreateClass.setWinHandle(window);
      //
      i := g_winList.add(g_winCreateClass);
      g_winCreateClass.setWinListIndex(i);
    end;
  end;

  // 2. call wndProc
  if (0 <= i) then
    result := g_winList.callWndProc(i, message, wParam, lParam, window)
  else
    result := DefWindowProc(window, message, wParam, lParam);
end;

// --  --
function unaCreateWindow(window: unaWinWindow): hWnd;
var
  parent: hWnd;
  params: punaWinCreateParams;
begin
  params := window.getCreateParams();
  parent := window.getParent();
  //
  if (g_winCreateGate.enter(1000)) then begin
    //
    try
      g_winCreateClass := window;
      if (params.r_class.isCommon) then
	//
	// subclassing works, but kills standard controls on system dialog boxes, for example
	// I have no time now to investigate what is wrong, so I will disable that, since most
	// importan messages are sent to parent anywhay
	//
	//params.r_class.createSubclass(parent, @unaWndProc);
	;

      result := CreateWindowEx(params.r_exStyle, params.r_class.getWndClass().lpszClassName, pChar(params.r_caption), params.r_style, params.r_x, params.r_y, params.r_width, params.r_height, parent, params.r_menu, 0, nil);
      //
    finally
      g_winCreateClass := nil;
      g_winCreateGate.leave();
    end;
  end
  else
    result := 0;
end;

{ unaWinClass }

// --  --
function unaWinClass.callSubClassedWndProc(window: hWnd; message, wParam, lParam: int): int;
begin
  if (f_wasSubClassed and (0 <> f_oldClassWndProc)) then
    //
    result := CallWindowProc(pointer(f_oldClassWndProc), window, message, wParam, lParam)
  else
    result := -1;
end;

// --  --
class function unaWinClass.classIsRegistered(const className: string; instance: hModule): bool;
var
  info: TWNDCLASS;
begin
  result := GetClassInfo(instance, pChar(className), info);
end;

// --  --
constructor unaWinClass.create(const name: string; style: unsigned; icon, smallIcon: hIcon; cursor: hCursor; brBrush: hBrush; menuName: int; instance: hModule; force: bool);
begin
  inherited create();
  //
  if ('' = name) then
    f_name := strNew(className)
  else
    f_name := strNew(name);
  //
  f_wndClass.cbSize := sizeOf(f_wndClass);
  f_wndClass.style := style;
  f_wndClass.lpfnWndProc := @unaWndProc;
  f_wndClass.cbClsExtra := 0;
  f_wndClass.cbWndExtra := 4;	// stores pointer to window (Delphi) class instance
  if (0 = instance) then
    f_wndClass.hInstance := GetModuleHandle(nil)
  else
    f_wndClass.hInstance := instance;
  //
  f_wndClass.hIcon := icon;
  //
  if (0 = cursor) then
    f_wndClass.hCursor := LoadCursor(instance, IDC_ARROW)
  else
    f_wndClass.hCursor := cursor;
  //
  f_wndClass.hbrBackground := brBrush;
  f_wndClass.lpszMenuName := pChar(menuName);
  f_wndClass.lpszClassName := f_name;
  f_wndClass.hIconSm := smallIcon;
  //
  if (nil <> g_winClasses) then
    g_winClasses.add(self);
  //
  registerClass(force);
end;

// --  --
constructor unaWinClass.createStdClass(const name: string; instance: hModule);
begin
  inherited create();
  //
  if (GetClassInfoEx(instance, pChar(name), f_wndClass)) then begin
    //
    f_name := strNew(name);
    f_classOwner := false;
    f_isCommon := true;
  end
  else
    create(name, 0, 0, 0, 0, 0, 0, instance);
  //
  if (nil <> g_winClasses) then
    g_winClasses.add(self);
end;

// --  --
function unaWinClass.createSubclass(mainWnd: hWnd; newWndProc: pointer): bool;
var
  oldProc: int;
begin
  if (not f_wasSubclassed) then begin
    // try to subclass a class

    // 1. create a window of that class
    f_subClassWnd := CreateWindow(f_wndClass.lpszClassName, nil, WS_CHILD, 0, 0, 50, 50, mainWnd, 0, f_wndClass.hInstance, nil);

    if (0 <> f_subClassWnd) then begin
      // 2. check if class is not already subclassed to this wndProc
      oldProc := GetClassLong(f_subClassWnd, GCL_WNDPROC);
      if (int(newWndProc) <> oldProc) then begin

	// 3. do subclass
	f_oldClassWndProc := oldProc;	// just in case some message will be passed while f_oldClassWndProc is not set (i.e. SetClassLong() is not returned)
	f_wasSubClassed := true;
	f_oldClassWndProc := SetClassLong(f_subClassWnd, GCL_WNDPROC, int(newWndProc));
      end
      else
	// remove the window - its class is already subclassed to given wndProc
	DestroyWindow(f_subClassWnd);
    end;
  end;
  //
  result := f_wasSubclassed;
end;

// --  --
destructor unaWinClass.destroy();
begin
  if (nil <> g_winClasses) then
    g_winClasses.removeItem(self);
  //
  inherited;
  //
  removeSubclass();
  //
  if (f_classOwner) then
    unregister();
  //
  mrealloc(f_name);
end;

// --  --
function unaWinClass.getAtom(): ATOM;
begin
  result := registerClass();
end;

// --  --
function unaWinClass.getWndClass(): pWNDCLASSEX;
begin
  result := @f_wndClass;
end;

// --  --
function unaWinClass.registerClass(force: bool): atom;
var
  info: TWNDCLASSEX;
  name: string;
begin
  if (0 = f_atom) then begin
    //
    if (force) then begin
      //
      while (GetClassInfoEx(f_wndClass.hInstance, f_name, info)) do begin
	name := f_name;
	name := name + 'a';
	mrealloc(f_name);
	f_name := strNew(name);
	f_wndClass.lpszClassName := f_name;
      end;
    end;
    //
    result := RegisterClassEx(f_wndClass);
    f_atom := result;
  end
  else
    result := f_atom;
end;

// --  --
procedure unaWinClass.removeSubclass();
begin
  if (f_wasSubclassed) then begin
    // remove the subclass, restore old wndProc
    SetClassLong(f_subClassWnd, GWL_WNDPROC, f_oldClassWndProc);
    // and destroy subclass window
    DestroyWindow(f_subClassWnd);
    //
    f_wasSubclassed := false;
  end;
end;

// --  --
procedure unaWinClass.unregister();
begin
  if ((0 <> f_atom) and not isCommon) then begin
    //
    if (UnregisterClass(pChar(f_atom), f_wndClass.hInstance)) then
      f_atom := 0;
    //  
  end;
end;

{ unaWinFont }

// --  --
class function unaWinFont.chooseScreenFont(var font: LOGFONT; owner: hWnd;
  dc: hDC; flags, sizeMin, sizeMax: unsigned): bool;
var
  cf: TCHOOSEFONT;
begin
  cf.lStructSize := sizeOf(cf);
  cf.hWndOwner := owner;
  cf.hDC := dc;
  cf.lpLogFont := @font;
  cf.iPointSize := 0;
  cf.Flags := flags;
  cf.rgbColors := RGB(0, 0, 0);
  cf.lCustData := 0;
  cf.lpfnHook := nil;