program ToolBar;
{$R ToolBar.RES}
uses WinTypes, WinProcs, WObjects, StdDlgs,Strings,StdWnds,Icons;
const
  TB_Name =  'ToolBar Demo';
  idm_TBChange = 301;
  idm_TBShowHide=302;
  um_ReSize    = 401;
  id_IG1  =      600;
  id_Icon1 =      601;
  id_Icon2 =      602;
  id_Icon3 =      603;
  id_Icon4 =      604;
  id_Icon5 =      605;
  id_Icon6 =      606;
  id_Icon7 =      607;
  id_Icon8 =      608;
  bs_Custom =      99;
  IWidth     =     32;
{**********************  TYPES      ******************************}
type
  TTBApp = object(TApplication)
  procedure InitMainWindow; virtual;
end;

PTBToolBar = ^TTBToolBar;
TTBToolBar = object(TWindow)
  Icon:Array[0..8] of PIcon;
  IG1:PIconGroup;
  Orientation:Integer;
  constructor Init(AParent:PWindowsObject;ATitle:PChar);
  destructor Done;virtual;
  procedure WMDrawItem(var Msg:TMessage);virtual wm_First+wm_DrawItem;
  procedure UMReSize(var Msg: TMessage); virtual wm_User + um_ReSize;
  procedure WMCommand(Var Msg:TMessage);virtual wm_First+wm_Command;
  procedure WMNCLButtonDblClk(var Msg:TMessage);virtual wm_First+
    wm_NCLButtonDblClk;
  procedure ToggleOrientation;
end;

PTBWindow = ^TTBWindow;
TTBWindow = object(TWindow)
  ToolBar:PTBToolBar;
  TheBrush:HBrush;
  lbColor:TColorRef;
  ColorIndx:Integer;
  lbStyle,lbHatch:Integer;
  constructor Init(ATitle: PChar);
  destructor Done; virtual;
  procedure SetupWindow;virtual;
  procedure WMSize(var Msg: TMessage); virtual wm_First + wm_Size;
  procedure IDIcon1(Var Msg:TMessage);virtual wm_User+id_Icon1;
  procedure IDIcon2(Var Msg:TMessage);virtual wm_User+id_Icon2;
  procedure IDIcon3(Var Msg:TMessage);virtual wm_User+id_Icon3;
  procedure IDIcon4(Var Msg:TMessage);virtual wm_User+id_Icon4;
  procedure IDIcon5(Var Msg:TMessage);virtual wm_User+id_Icon5;
  procedure IDIcon6(Var Msg:TMessage);virtual wm_User+id_Icon6;
  procedure IDIcon7(Var Msg:TMessage);virtual wm_User+id_Icon7;
  procedure IDIcon8(Var Msg:TMessage);virtual wm_User+ID_Icon8;
  procedure RedrawBkGnd;virtual;
  procedure  WMSysCommand(var Msg:TMessage);virtual wm_First+wm_SysCommand;
end;
{**********************  GLOBALS   ******************************}
var
  MainWin:PTBWindow;
{**********************  METHODS    ******************************}
procedure TTBApp.InitMainWindow;
begin
  MainWindow := New(PTBWindow, Init(TB_Name));
  MainWin := PTBWindow(MainWindow);
end;
{**********************  TTBWindow  *******************************}
constructor TTBWindow.Init(ATitle: PChar);
begin
  TWindow.Init(nil, ATitle);
  with Attr do
    begin
    X := 50; Y := 50; W := 500; H := 300;
    end;
  ToolBar := New(PTBToolBar,Init(@Self,'Tools'));
  TheBrush := 0;
  lbColor := RGB(0,0,0);
  lbStyle := bs_Solid;
  lbHatch := hs_Vertical;
  ColorIndx := 0;
end;

destructor TTBWindow.Done;
var
  Msg:TMessage;
begin
  TWindow.Done;
  if TheBrush <> 0  then
    DeleteObject(TheBrush);
end;

procedure TTBWindow.SetupWindow;
var
  SysMenu:HMenu;
begin
  TWindow.SetupWindow;
  SetClassWord(HWindow,GCW_HIcon,LoadIcon(HInstance,'TB_Icon'));
  Sysmenu := GetSystemMenu(hWindow,false);
  AppendMenu(SysMenu,MF_Separator,0,nil);
  AppendMenu(Sysmenu,0,idm_TBChange,'Flip Toolbar');
  AppendMenu(Sysmenu,0,idm_TBShowHide,'Hide Toolbar');
  if ToolBar <> nil then
    SendMessage(ToolBar^.HWindow,wm_User+um_ReSize,0,0);
end;

procedure TTBWindow.WMSize(var Msg: TMessage);
begin
  TWindow.WMSize(Msg);
  if ToolBar <> nil then    {optional follow-along}
    SendMessage(ToolBar^.HWindow,wm_User+um_ReSize,0,0);
end;

procedure TTBWindow.IDIcon1(var Msg:TMessage);
begin
  lbHatch := hs_Vertical;
  lbStyle := bs_Hatched;
  RedrawBkgnd;
end;

procedure TTBWindow.IDIcon2(var Msg:TMessage);
begin
  lbHatch := hs_BDiagonal;
  lbStyle := bs_Hatched;
  RedrawBkgnd;
end;

procedure TTBWindow.IDIcon3(var Msg:TMessage);
begin
  lbHatch := hs_Cross;
  lbStyle := bs_Hatched;
  RedrawBkgnd;
end;

procedure TTBWindow.IDIcon4(var Msg:TMessage);
begin
  lbHatch := hs_DiagCross;
  lbStyle := bs_Hatched;
  RedrawBkgnd;
end;

procedure TTBWindow.IDIcon5(var Msg:TMessage);
var
LogBrush:TLogBrush;
begin
  lbStyle := bs_Solid;
  RedrawBkGnd;
end;

procedure TTBWindow.IDIcon6(var Msg:TMessage);
var
  DC,MemDC:HDC;
  NewBmp,Bmp,OldBmp:HBitmap;
  NewBrush,OldBrush,MonoBrush:HBrush;
begin
   if TheBrush > 0 then
      DeleteObject(TheBrush);
  Bmp :=LoadBitmap(HInstance,'TB_Brush');
  MonoBrush :=CreatePatternBrush(Bmp);
  DC := GetDC(HWindow);
  NewBMP := CreateCompatibleBitmap(DC,8,8);
  MemDC := CreateCompatibleDC(DC);
  SetTextColor(MemDC,lbColor);
  OldBrush := SelectObject(MemDC,MonoBrush);
  OldBmp := SelectObject(MemDC,NewBmp);
  PatBlt(MemDC,0,0,8,8,PatCopy); 
  SelectObject(MemDC,OldBmp);
  SelectObject(MemDC,OldBrush);
  DeleteObject(MonoBrush);
  TheBrush := CreatePatternBrush(NewBMP);
  DeleteObject(Bmp);
  DeleteObject(NewBmp);
  DeleteDC(MemDC);
  ReleaseDC(HWindow,DC);
  lbStyle := bs_Custom;
  SetClassWord(HWindow,GCW_HBrBackGround,TheBrush);
  InvalidateRect(HWindow,nil,True);
end;

procedure TTBWindow.IDIcon7(var Msg:TMessage);
begin
  Inc(ColorIndx);
  If ColorIndx > 9 then ColorIndx := 0;
  case ColorIndx of
      0:lbColor := RGB(0,0,0);
      1:lbColor := RGB(0,0,255);
      2:lbColor := RGB(255,0,0);
      3:lbColor := RGB(255,0,255);
      4:lbColor := RGB(0,255,0);
      5:lbColor := RGB(0,255,255);
      6:lbColor := RGB(255,255,0);
      7:lbColor := RGB(255,255,255);
      8:lbColor := RGB(192,192,192);
      9:lbColor := RGB(128,128,128);
  end;
  RedrawBkGnd;
end;

procedure TTBWindow.IDIcon8(var Msg:TMessage);
begin
  CloseWindow;
end;

procedure TTBWindow.RedrawBkGnd;
var
LogBrush:TLogBrush;
begin
  if lbStyle = bs_Custom then
    begin
    SendMessage(HWindow,wm_User+id_Icon6,0,0);
    exit;
    end;
  if TheBrush > 0 then
    DeleteObject(TheBrush);
  LogBrush.lbStyle := lbStyle;
  LogBrush.lbColor := lbColor;
  LogBrush.lbHatch := lbHatch;
  TheBrush := CreateBrushIndirect(LogBrush);
  SetClassWord(HWindow,GCW_HBrBackGround,TheBrush);
  InvalidateRect(HWindow,nil,True);
end;

procedure  TTBWindow.WMSysCommand(var Msg:TMessage);
var
  Ret:Boolean;
  SysMenu:HMenu;
begin
  case Msg.Wparam of
    idm_TBChange:
      begin
      ToolBar^.ToggleOrientation;
      if ToolBar <> nil then
      SendMessage(ToolBar^.HWindow,wm_User+um_ReSize,0,0);
      end;
    idm_TBShowHide:
      begin
      Sysmenu := GetSystemMenu(hWindow,false);
      if IsWindowVisible(ToolBar^.HWindow) then
        begin
        ShowWindow(Toolbar^.HWindow,sw_Hide);
        ModifyMenu(Sysmenu,idm_TBShowHide,mf_ByCommand+mf_String,
           idm_TBShowHide,'Show Toolbar');
        end
      else
        begin
        ShowWindow(ToolBar^.HWindow,sw_Normal);
        ModifyMenu(Sysmenu,idm_TBShowHide,mf_ByCommand+mf_String,
           idm_TBShowHide,'Hide Toolbar');
        end;
      end;
    else
      DefWndProc(Msg);
  end;
end;
{***********************  TTBToolBar   ****************************}
constructor TTBToolBar.Init(AParent:PWindowsObject;ATitle:PChar);
Const
  BMP:Array[0..8] of PChar = ('','TB_Tool1','TB_Tool2','TB_Tool3','TB_Tool4',
  'TB_Tool5',  'TB_Tool6','TB_Tool7','TB_Tool8');
var
  Indx:Integer;
  Buf:Array[0..8] of Char;
begin
  TWindow.Init(AParent,Atitle);
  Attr.Style :=  ws_PopUpWindow or ws_Visible or ws_Caption;
  Orientation := 0;
  For Indx := 0 to 8 do Icon[Indx] := nil;
  IG1 := New(PIconGroup,Init(@Self,id_IG1,'',0,0,IWidth*4,IWidth*2));
  For Indx := 1 to 8 do
    Icon[Indx] := New(PIcon,Init(@Self,Indx+600,'',0,0,IWidth,IWidth,IG1,BMP[Indx]));
end;

destructor TTBToolBar.Done;
begin
  TWindow.Done;
  MainWin^.ToolBar := nil;
end;

procedure TTBToolBar.UMReSize(var Msg:TMessage);
var
  CR:TRect;
  aPt:TPoint;
  Indx:Integer;
begin
  GetClientRect(Parent^.HWindow,CR);
  aPt.X := CR.Right;aPt.Y := CR.Top;
  ClientToScreen(Parent^.HWindow,aPt);
  if Orientation = 0 then
    begin
    SetWindowPos(HWindow,0,aPt.X-129,aPt.Y,129,
    GetSystemMetrics(sm_CYSize)+67,swp_NoZOrder);
    for Indx := 1  to 4 do
      MoveWindow(Icon[Indx]^.HWindow,IWidth*(Indx-1),0,IWidth,IWidth,False);
    for Indx := 5  to 8 do
      MoveWindow(Icon[Indx]^.HWindow,IWidth*(Indx-5),IWidth,IWidth,IWidth,False);
    MoveWindow(IG1^.HWindow,0,0,IWidth*(4),IWidth*2,True);
    end
  else
    begin
    SetWindowPos(HWindow,0,aPt.X-66,aPt.Y,66,
    GetSystemMetrics(sm_CYSize)+129,swp_NoZOrder);
    for Indx := 1  to 2 do
      MoveWindow(Icon[Indx]^.HWindow,IWidth*(Indx-1),0,IWidth,IWidth,False);
    for Indx := 3  to 4 do
      MoveWindow(Icon[Indx]^.HWindow,IWidth*(Indx-3),IWidth,IWidth,IWidth,False);
    for Indx := 5  to 6 do
      MoveWindow(Icon[Indx]^.HWindow,IWidth*(Indx-5),IWidth*2,IWidth,IWidth,False);
    for Indx := 7  to 8 do
      MoveWindow(Icon[Indx]^.HWindow,IWidth*(Indx-7),IWidth*3,IWidth,IWidth,False);
    MoveWindow(IG1^.HWindow,0,0,IWidth*2,IWidth*4,True);
    end;
  SetFocus(Parent^.HWindow);
end;

procedure TTBToolBar.WMDrawItem(var Msg:TMessage);
var
  PDIS : ^TDrawItemStruct;
begin
  PDIS := Pointer(Msg.lParam);
  case PDIS^.CtlType of
    odt_Button:
      case PDIS^.CtlID of
        id_Icon1..id_Icon8:Icon[PDIS^.CtlID-600]^.DrawItem(Msg);
     end;
  end;
end;

procedure TTBToolBar.WMCommand(var Msg:TMessage);
begin
  TWindow.WMCommand(Msg);
  case Msg.WParam of
    id_Icon1..id_Icon8:SendMessage(Parent^.HWindow,
        wm_User+Msg.Wparam,0,0);
  end;
end;

procedure TTBToolBar.WMNCLButtonDblClk(var Msg:TMessage);
begin
  ToggleOrientation;
  SendMessage(HWindow,wm_User+um_ReSize,0,0);
end;

procedure TTBToolBar.ToggleOrientation;
begin
  If Orientation = 1 then Orientation := 0 else Orientation := 1;
end;
{**********************  MainLine   *******************************}
var
  TBApp: TTBApp;
begin
  TBApp.Init(TB_Name);
  TBApp.Run;
  TBApp.Done;
end.
