(************************************************************************
*    This File is Part of the AHM Triton Tools                          *
*    for Borland Delphi and C++ Builder.                                *
*************************************************************************
* Copyright © 1995-1999 Alexander H. Mehlhorn (AHM) and Tritontools.com *
* All Rights reserved.                                                  *
*                                                                       *
*    For more Information contact us at                                 *
*    E-Mail : support@tritontools.com                                   *
*    URL : http://www.tritontools.com                                   *
*                                                                       *
*    AHM is copyright by Alexander H. Mehlhorn                          *
*    All Parts of this Collection were developed,                       *
*    designed and implemented by AHM                                    *
*                                                                       *
*    Under no Circumstances may you distribute this file                *
*    in this or any other format. This File is supplied                 *
*    as Evaluation of Source only. No Delphi Components may be developed*
*    using extracts or subsets of this code without expressed permission*
*    by AHM.                                                            *
*                                                                       *
*************************************************************************)
unit AHMControls;

interface
{$I AHM.INC}
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  stdctrls,AHMTBackground,AHMEnhancedClass;

type
  TAHMSectionChange = procedure(Sender: TObject; ASection, AWidth: Integer) of object;
  TAHMCustomControl = class(TWinControl)
  private
    FAHMAboutStr : TAHMAboutEnhancedStr;
    FCanvas: TCanvas;
    FBack : TAHMBackground;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure SetBack(Value : TAHMBackground);
  protected
    procedure Notification(AComponent: TComponent;Operation: TOperation); override;
    procedure Paint; virtual;
    procedure PaintWindow(DC: HDC); override;
    property Canvas: TCanvas read FCanvas;
  public
    property About : TAHMAboutEnhancedStr read FAHMAboutStr write FAHMAboutStr stored False;
    {$IFDEF AHMONLY4}
    property Anchors;
    property BiDiMode;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property ParentBiDiMode;
    {$ENDIF}
    property Background : TAHMBackground read fback write Setback stored true;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Loaded; override;
  published
   {$IFDEF AHMONLY4}
    Property OnDockDrop;
    Property OnDockOver;
    Property OnMouseWheel;
    Property OnMouseWheelDown;
    Property OnMouseWheelUp;
    Property OnUnDock;
    Property OnGetSiteInfo;    
    {$ENDIF}
    Property OnEnter;
    Property OnExit;
    Property OnKeyDown;
    Property OnKeyPress;
    Property OnKeyUp;
  end;
  TAHMHeader = class(TAHMCustomControl)
  private
    FSections: TStrings;
    FMouse : TPoint;
    FHitTest: TPoint;
    FClick : Boolean;
    f3D : TAHMFont3D;
    FCanResize: Boolean;
    FAllowResize: Boolean;
    FBorderStyle: TBorderStyle;
    FResizeSection: Integer;
    FMouseOffset: Integer;
    FOnSizing: TAHMSectionChange;
    FOnSized: TAHMSectionChange;
    procedure Set3D(value : TAHMFont3D);
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure FreeSections;
    procedure SetSections(Strings: TStrings);
    function GetWidth(X: Integer): Integer;
    procedure SetWidth(X: Integer; Value: Integer);
    procedure WMSetCursor(var Msg: TWMSetCursor); message WM_SETCURSOR;
    procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
    procedure WMSize(var Msg: TWMSize); message WM_SIZE;
  protected
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure Paint; override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Sizing(ASection, AWidth: Integer); dynamic;
    procedure Sized(ASection, AWidth: Integer); dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property SectionWidth[X: Integer]: Integer read GetWidth write SetWidth;
  published
    property About;
    {$IFDEF AHMONLY4}
    property Anchors;
    property BiDiMode;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property ParentBiDiMode;
    {$ENDIF}
    property Align;
    property AllowResize: Boolean read FAllowResize write FAllowResize default True;
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsNone;
    property Enabled;
    property Font;
    property Font3D : TAHMFont3D read f3d write Set3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property Sections: TStrings read FSections write SetSections;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnSizing: TAHMSectionChange read FOnSizing write FOnSizing;
    property OnSized: TAHMSectionChange read FOnSized write FOnSized;
    property Background;
  end;
  TAHMGraphicControl = class(TGraphicControl)
  private
    FAHMAboutStr : TAHMAboutEnhancedStr;
  protected
  public
  published
    property About : TAHMAboutEnhancedStr read FAHMAboutStr write FAHMAboutStr stored False;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDrag;
    {$IFDEF AHMONLY4}
    property OnResize;
    property OnStartDock;
    property OnCanResize;
    property OnConstrainedResize;
    property OnEndDock;
    property Anchors;
    property BiDiMode;
    property Constraints;
    property DragCursor;
    property DragKind;
    property DragMode;
    property ParentBiDiMode;
    {$ENDIF}
  end;

implementation

const
  DefaultSectionWidth = 75;

type
  PHeaderSection = ^TAHMHeaderSection;
  TAHMHeaderSection = record
    FObject: TObject;
    Width: Integer;
    Title: string;
  end;

type
  TAHMHeaderStrings = class(TStrings)
  private
    FHeader: TAHMHeader;
    FList: TList;
    procedure ReadData(Reader: TReader);
    procedure WriteData(Writer: TWriter);
  protected
    procedure DefineProperties(Filer: TFiler); override;
    function Get(Index: Integer): string; override;
    function GetCount: Integer; override;
    function GetObject(Index: Integer): TObject; override;
    procedure Put(Index: Integer; const S: string); override;
    procedure PutObject(Index: Integer; AObject: TObject); override;
    procedure SetUpdateState(Updating: Boolean); override;
  public
    constructor Create;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure Delete(Index: Integer); override;
    procedure Insert(Index: Integer; const S: string); override;
    procedure Clear; override;
  end;

procedure FreeSection(Section: PHeaderSection);
begin
  if Section <> nil then Dispose(Section);
end;

function NewSection(const ATitle: string; AWidth: Integer; AObject: TObject): PHeaderSection;
begin
  System.New(Result);
  with Result^ do
  begin
    Title := ATitle;
    Width := AWidth;
    FObject := AObject;
  end;
end;

constructor TAHMHeaderStrings.Create;
begin
  inherited Create;
  FList := TList.Create;
end;

destructor TAHMHeaderStrings.Destroy;
begin
  if FList <> nil then
  begin
    Clear;
    FList.Destroy;
  end;
  inherited Destroy;
end;

procedure TAHMHeaderStrings.Assign(Source: TPersistent);
var
  I, J: Integer;
  Strings: TStrings;
  NewList: TList;
  Section: PHeaderSection;
  TempStr: string;
  Found: Boolean;
begin
  if Source is TStrings then
  begin
    Strings := TStrings(Source);
    BeginUpdate;
    try
      NewList := TList.Create;
      try
        { Delete any sections not in the new list }
        I := FList.Count - 1;
        Found := False;
        while I >= 0 do
        begin
          TempStr := Get(I);
          for J := 0 to Strings.Count - 1 do
          begin
            Found := CompareStr(Strings[J], TempStr) = 0;
            if Found then Break;
          end;
          if not Found then Delete(I);
          Dec(I);
        end;

        { Now iterate over the lists and maintain section widths of sections in
          the new list }
        I := 0;
        for J := 0 to Strings.Count - 1 do
        begin
          if (I < FList.Count) and (CompareStr(Strings[J], Get(I)) = 0) then
          begin
            Section := NewSection(Get(I), PHeaderSection(FList[I])^.Width, GetObject(I));
            Inc(I);
          end else
            Section := NewSection(Strings[J],
              FHeader.Canvas.TextWidth(Strings[J]) + 8, Strings.Objects[J]);
          NewList.Add(Section);
        end;
        Clear;
        FList.Destroy;
        FList := NewList;
        FHeader.Invalidate;
      except
        for I := 0 to NewList.Count - 1 do
          FreeSection(NewList[I]);
        NewList.Destroy;
        raise;
      end;
    finally
      EndUpdate;
    end;
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TAHMHeaderStrings.DefineProperties(Filer: TFiler);
begin
  if Filer is TReader then inherited DefineProperties(Filer);
  Filer.DefineProperty('Sections', ReadData, WriteData, Count > 0);
end;

procedure TAHMHeaderStrings.Clear;
var
  I: Integer;
begin
  for I := 0 to FList.Count - 1 do
    FreeSection(FList[I]);
  FList.Clear;
end;

procedure TAHMHeaderStrings.Delete(Index: Integer);
begin
  FreeSection(FList[Index]);
  FList.Delete(Index);
  if FHeader <> nil then FHeader.Invalidate;
end;

function TAHMHeaderStrings.Get(Index: Integer): string;
begin
  Result := PHeaderSection(FList[Index])^.Title;
end;

function TAHMHeaderStrings.GetCount: Integer;
begin
  Result := FList.Count;
end;

function TAHMHeaderStrings.GetObject(Index: Integer): TObject;
begin
  Result := PHeaderSection(FList[Index])^.FObject;
end;

procedure TAHMHeaderStrings.Insert(Index: Integer; const S: string);
var
  Width: Integer;
begin
  if FHeader <> nil then
    Width := FHeader.Canvas.TextWidth(S) + 8
  else Width := DefaultSectionWidth;
  FList.Expand.Insert(Index, NewSection(S, Width, nil));
  if FHeader <> nil then FHeader.Invalidate;
end;

procedure TAHMHeaderStrings.Put(Index: Integer; const S: string);
var
  P: PHeaderSection;
  Width: Integer;
begin
  P := FList[Index];
  if FHeader <> nil then
    Width := FHeader.Canvas.TextWidth(S) + 8
  else Width := DefaultSectionWidth;
  FList[Index] := NewSection(S, Width, P^.FObject);
  FreeSection(P);
  if FHeader <> nil then FHeader.Invalidate;
end;

procedure TAHMHeaderStrings.PutObject(Index: Integer; AObject: TObject);
begin
  PHeaderSection(FList[Index])^.FObject := AObject;
  if FHeader <> nil then FHeader.Invalidate;
end;

procedure TAHMHeaderStrings.ReadData(Reader: TReader);
var
  Width, I: Integer;
  Str: string;
begin
  Reader.ReadListBegin;
  Clear;
  while not Reader.EndOfList do
  begin
    Str := Reader.ReadString;
    Width := DefaultSectionWidth;
    I := 1;
    if Str[1] = #0 then
    begin
      repeat
        Inc(I);
      until (I > Length(Str)) or (Str[I] = #0);
      Width := StrToIntDef(Copy(Str, 2, I - 2), DefaultSectionWidth);
      System.Delete(Str, 1, I);
    end;
    FList.Expand.Insert(FList.Count, NewSection(Str, Width, nil));
  end;
  Reader.ReadListEnd;
end;

procedure TAHMHeaderStrings.SetUpdateState(Updating: Boolean);
begin
  if FHeader <> nil then
  begin
    SendMessage(FHeader.Handle, WM_SETREDRAW, Ord(not Updating), 0);
    if not Updating then FHeader.Refresh;
  end;
end;

procedure TAHMHeaderStrings.WriteData(Writer: TWriter);
var
  I: Integer;
  HeaderSection: PHeaderSection;
begin
  Writer.WriteListBegin;
  for I := 0 to Count - 1 do
  begin
    HeaderSection := FList[I];
    with HeaderSection^ do
      Writer.WriteString(Format(#0'%d'#0'%s', [Width, Title]));
  end;
  Writer.WriteListEnd;
end;


constructor TAHMHeader.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FClick:=false;
  f3d:=TAHMFont3D.create(self);
  ControlStyle := ControlStyle + [csDesignInteractive, csOpaque];
  Width := 250;
  Height := 25;
  FSections := TAHMHeaderStrings.Create;
  TAHMHeaderStrings(FSections).FHeader := Self;
  FAllowResize := True;
  FBorderStyle := bsNone
end;

destructor TAHMHeader.Destroy;
begin
  FreeSections;
  FSections.Free;
  f3d.free;
  inherited Destroy;
end;

procedure TAHMHeader.CreateParams(var Params: TCreateParams);
const
  BorderStyles: array[TBorderStyle] of DWord = (0, WS_BORDER);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    Style := Style or BorderStyles[FBorderStyle];
    WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
  end;
end;

procedure TAHMHeader.Paint;
var
  I, W: Integer;
  S: string;
  R: TRect;
  myrect : TRect;
begin
  canvas.brush.style:=bsSolid;
  R := Rect(0, 0, 0, ClientHeight);
  Canvas.Fillrect(r);
  inherited Paint;
  with Canvas do
  begin
    Font := Self.Font;
    I := 0;
    R := Rect(0, 0, 0, ClientHeight);
    W := 0;
    S := '';
    repeat
      if I < FSections.Count then
      begin
        with PHeaderSection(TAHMHeaderStrings(FSections).FList[I])^ do
        begin
          W := Width;
          S := Title;
        end;
        Inc(I);
      end;
      R.Left := R.Right;
      Inc(R.Right, W);
      if (ClientWidth - R.Right < 2) or (I = FSections.Count) then
        R.Right := ClientWidth;
      Canvas.Brush.Style:=bsclear;
      f3d.write(Canvas.font,canvas.handle,R,S,
       DT_Center or DT_VCenter or DT_End_Ellipsis or DT_SingleLine or DT_Noclip,enabled);
      myrect:=r;
      inflaterect(myrect,0,0);
      if (FClick) and PtInRect(myrect,FMouse) then
      begin
        DrawEdge(Canvas.Handle,myrect,EDGE_SUNKEN,BF_TOPLEFT);
        DrawEdge(Canvas.Handle,myrect,EDGE_SUNKEN,BF_BOTTOMRight);
      end else
      begin
        DrawEdge(Canvas.Handle,myrect,EDGE_RAISED,BF_TOPLEFT);
        DrawEdge(Canvas.Handle,myrect,EDGE_RAISED,BF_BOTTOMRight);
      end;
    until R.Right = ClientWidth;
  end;
  canvas.brush.style:=bsclear;
end;

procedure TAHMHeader.Set3D(value : TAHMFont3D);
begin
  f3d.assign(value);
  invalidate;
end;

procedure TAHMHeader.FreeSections;
begin
  if FSections <> nil then
    FSections.Clear;
end;

procedure TAHMHeader.SetBorderStyle(Value: TBorderStyle);
begin
  if Value <> FBorderStyle then
  begin
    FBorderStyle := Value;
    RecreateWnd;
  end;
end;

procedure TAHMHeader.SetSections(Strings: TStrings);
begin
  FSections.Assign(Strings);
end;

function TAHMHeader.GetWidth(X: Integer): Integer;
var
  I, W: Integer;
begin
  if X = FSections.Count - 1 then
  begin
    W := 0;
    for I := 0 to X - 1 do
      Inc(W, PHeaderSection(TAHMHeaderStrings(FSections).FList[I])^.Width);
    Result := ClientWidth - W;
  end
  else if (X >= 0) and (X < FSections.Count) then
    Result := PHeaderSection(TAHMHeaderStrings(FSections).FList[X])^.Width
  else
    Result := 0;
end;

procedure TAHMHeader.SetWidth(X: Integer; Value: Integer);
begin
  if X < 0 then Exit;
  PHeaderSection(TAHMHeaderStrings(FSections).FList[X])^.Width := Value;
  Invalidate;
end;

procedure TAHMHeader.WMNCHitTest(var Msg: TWMNCHitTest);
begin
  inherited;
  FHitTest := SmallPointToPoint(Msg.Pos);
end;

procedure TAHMHeader.WMSetCursor(var Msg: TWMSetCursor);
var
  Cur: HCURSOR;
  I: Integer;
  X: Integer;
begin
  Cur := 0;
  FResizeSection := 0;
  FHitTest := ScreenToClient(FHitTest);
  X := 2;
  with Msg do
    if HitTest = HTCLIENT then
      for I := 0 to FSections.Count - 2 do
      begin
        Inc(X, PHeaderSection(TAHMHeaderStrings(FSections).FList[I])^.Width);
        FMouseOffset := X - (FHitTest.X + 2);
        if Abs(FMouseOffset) < 4 then
        begin
          Cur := LoadCursor(0, IDC_SIZEWE);
          FResizeSection := I;
          Break;
        end;
      end;
  FCanResize := (FAllowResize or (csDesigning in ComponentState)) and (Cur <> 0);
  if FCanResize then SetCursor(Cur)
  else inherited;
end;

procedure TAHMHeader.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  if ((csDesigning in ComponentState) and (Button = mbRight)) or (Button = mbLeft) then
    if FCanResize then SetCapture(Handle);
  if (Button = mbLeft) and not(FClick) then
  begin
    FClick:=True;
    FMouse.X:=X;
    FMouse.Y:=Y;
    Paint;
  end;
end;

procedure TAHMHeader.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  I: Integer;
  AbsPos: Integer;
  MinPos: Integer;
  MaxPos: Integer;
begin
  inherited MouseMove(Shift, X, Y);
  if (GetCapture = Handle) and FCanResize then
  begin
    AbsPos := 2;
    for I := 0 to FResizeSection do
      Inc(AbsPos, PHeaderSection(TAHMHeaderStrings(FSections).FList[I])^.Width);

    if FResizeSection > 0 then MinPos := AbsPos -
      PHeaderSection(TAHMHeaderStrings(FSections).FList[FResizeSection])^.Width + 2
    else MinPos := 2;
    MaxPos := ClientWidth - 2;
    if X < MinPos then X := MinPos;
    if X > MaxPos then X := MaxPos;

    Dec(PHeaderSection(TAHMHeaderStrings(FSections).FList[FResizeSection])^.Width,
      (AbsPos - X - 2) - FMouseOffset);
    Sizing(FResizeSection,
      PHeaderSection(TAHMHeaderStrings(FSections).FList[FResizeSection])^.Width);
    Refresh;
  end;
end;

procedure TAHMHeader.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if FCanResize then
  begin
    ReleaseCapture;
    Sized(FResizeSection,
      PHeaderSection(TAHMHeaderStrings(FSections).FList[FResizeSection])^.Width);
    FCanResize := False;
  end;
  if (Button = mbLeft) and (FClick) then
  begin
    FClick:=False;
    Paint;
  end;
  inherited MouseUp(Button, Shift, X, Y);
end;

procedure TAHMHeader.Sizing(ASection, AWidth: Integer);
begin
  if Assigned(FOnSizing) then FOnSizing(Self, ASection, AWidth);
end;

procedure TAHMHeader.Sized(ASection, AWidth: Integer);
var {$IFDEF AHMINPRISE3}
   Form: TCustomForm {$ELSE} Form: TForm {$ENDIF};
begin
  if Assigned(FOnSized) then FOnSized(Self, ASection, AWidth);
  if csDesigning in ComponentState then
  begin
    Form := GetParentForm(Self);
    if Form <> nil then
      Form.Designer.Modified;
  end;
end;

procedure TAHMHeader.WMSize(var Msg: TWMSize);
begin
  inherited;
  Invalidate;
end;



constructor TAHMCustomcontrol.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self;
end;

procedure TAHMCustomControl.SetBack(value : TAHMBackground);
begin
  if fback<>nil then fback.OList.remove(self);
  if value<>nil then value.additem(self);
  fback:=value;
  if Fback <> nil then Fback.FreeNotification(Self);
  invalidate;
end;

procedure TAHMCustomcontrol.Loaded;
begin
  inherited Loaded;
end;

procedure TAHMCustomcontrol.Notification(AComponent: TComponent;Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and  (AComponent = Background) then SetBack(nil);
end;

destructor TAHMCustomcontrol.Destroy;
begin
  FCanvas.Free;
  if fback<>nil then fback.OList.remove(self);
  inherited Destroy;
end;

procedure TAHMCustomcontrol.WMPaint(var Message: TWMPaint);
begin
  PaintHandler(Message);
end;

procedure TAHMCustomcontrol.PaintWindow(DC: HDC);
begin
{$IFDEF AHMINPRISE3}  FCanvas.Lock; {$ENDIF}
  try
    FCanvas.Handle := DC;
    try
      Paint;
    finally
      FCanvas.Handle := 0;
    end;
  finally
    {$IFDEF AHMINPRISE3}  FCanvas.Unlock; {$ENDIF}
  end;
end;

procedure TAHMCustomcontrol.Paint;
begin
  canvas.brush.color:=clbtnface;
  canvas.brush.style:=bssolid;
  if assigned(fback) then fback.draw(fcanvas.Handle,width,height,true)
  else canvas.fillrect(rect(0,0,width,height));
end;

end.
