www.pudn.com > xpbarmenu.rar > BarPopupMenu.pas

{ Component: TBarPopupMenu 
  =========================================================================== 
  Bluecave Software 
                  (C) Copyright 2000, Jouni Airaksinen (Mintus@Codefield.com) 
  =========================================================================== 
  Last Updated date: 2000-06-24 (yyyy-mm-dd) 
  --------------------------------------------------------------------------- 
 
 
              << LOOK COPYRIGHT, FEES & DISCLAIMER SECTION >> 
 
 
  -- Version 1.0.3 -- (2000-06-24) 
     - Support for my Expanding menu component system ( ignores items with 
       caption as '#' ) 
 
  -- Version 1.0.2 -- (2000-06-24) 
     - property BarVisible: Boolean 
 
  -- Version 1.0.1 -- (2000-06-23) 
     - Fixed font assignment AV using elipses (...) button 
 
  -- Version 1.0.0 -- (2000-06-22) 
 
    This is continued part of my article at www.delphi3000.com. Article 
    ID 1133, http://www.delphi3000.com/article.asp?id=1133 
 
    TBarPopupMenu component for Delphi 5. Be my guest and use it where-ever 
    you like, just mention my name and e-mail somewhere in your software. 
 
    Copy/Paste here, 
     "TBarPopupMenu, © Copyright 2000: Jouni Airaksinen, Mintus@Codefield.com" 
 
    There is demo program at Demo\ directory. 
 
    New properties in TBarPopupMenu: 
 
    property Bitmap: TBitmap 
      Bitmap to be positioned somewhere in the popupmenu (e.g. application 
      logo) 
 
    property BarWidth: Integer 
      Width of bar on the left side of popupmenu 
 
    property BarVisible: Boolean 
      Toggles bar visibility. If it's false, menu looks like normal menu. 
 
    property BitmapOffsetX: Integer 
    property BitmapOffsetY: Integer 
      Offset values to position bitmap 
 
    property BitmapVertAlignment: TBitmapVertAlignment 
    property BitmapHorzAlignment: TBitmapHorzAlignment 
      Alignment values to position bitmap, fine tune position with Offsets 
 
    property GradientEnd: TColor 
    property GradientStart: TColor 
      Gradient colors, if set to same color is drawn with one FillRect call 
 
    property Transparent: Boolean 
      Transparency of Bitmap 
 
    property VerticalFont: TFont 
    property VerticalText: string 
      Vertical text and it's font on the bar 
 
    property VerticalTextOffsetY: Integer 
      Offset for vertical text, normally you want it to be negative e.g. 
      defaults to -6. 
 
 
    Notes about root Items: 
 
      You can't assign (well you can, but events don't get executed) 
      OnMeasureItem nor OnAdvancedDrawItem events to root items. 
      Maybe I fix this later, if someone really needs those.. 
 
      Otherwise, you can use Actions and other stuff normally. 
 
  --------------------------------------------------------------------------- 
  Questions to, 
 
    Jouni Airaksinen, (programming: Mintus@Codefield.com; personal: virgin@sci.fi) 
    Bluecave Software, (http://www.bluecave.net/) 
    Codefield.com, (http://Codefield.com/) 
 
  == COPYRIGHT, FEES & DISCLAIMER ============================================ 
 
   YOU MUST include my name and e-mail address somewhere in your application; 
   Splash screen, About screen, readme file or something else. Place where 
   it's readable by normal user. 
 
  "TBarPopupMenu, © Copyright 2000: Jouni Airaksinen, Mintus@Codefield.com" 
 
 
   THIS CODE is free. Yes, free. I'm not going to ask any money from you. 
   Remember to mention my name and you are ready to go. You may use this 
   in your products which are: freeware, shareware, commericalware, 
   whateverware. 
 
   ------------------------------------------------------------------------- 
 
   COPYRIGHT remains with me. If you are going to use my code as base for 
   your own component(s), please ask permission first. I want to know how my 
   code is used. 
 
   IF YOU USE you agree to accept my changes into the component(s). Even if 
   it would cause work for you (please contact me if amount of work goes 
   into another millennium, maybe we can have peaceful some solution). 
 
   IF I DECIDE to make my component(s)/code commercial, it's my decision. 
   Also if I want to stop developing my component any further, I'm allowed 
   to do so (Most likely, if component(s)/code is commercial, I will develope 
   it as long as there is need for it). 
 
   FINANCIAL LOST caused by my component(s)/code (not including possible 
   registration fee of my component(s)/code) is not my headache. You cover 
   your loss. 
 
                                      Jouni Airaksinen (Mintus@Codefield.com) 
                                      Web: http://Codefield.com/home/mintus 
  =========================================================================== } 
 
Unit BarPopupMenu; 
 
interface 
 
uses 
  Windows, SysUtils, Classes, Graphics, Menus, Forms; 
 
const 
  BarSpace = 2; 
  ExpandChar = '#'; 
type 
  TBitmapVertAlignment = (bvaTop, bvaBottom, bvaMiddle); 
  TBitmapHorzAlignment = (bhaLeft, bhaRight, bhaCenter); 
 
  TBarPopupMenu = class(TPopupMenu) 
  private 
    { Private declarations } 
    FBitmap: TBitmap; 
    FBitmapOffsetX, 
    FBitmapOffsetY: Integer; 
    FBitmapVertAlignment: TBitmapVertAlignment; 
    FBitmapHorzAlignment: TBitmapHorzAlignment; 
 
    FclStart, 
    FclEnd: TColor; 
 
    FVerticalText: string; 
    FVerticalFont: TFont; 
{    FVerticalTextOffsetX,} 
    FVerticalTextOffsetY: Integer; 
    FBarWidth: Integer; 
    FBarVisible: Boolean; 
 
    PopupHeight: Integer; 
    Drawn: Boolean; 
  protected 
    { Protected declarations } 
    procedure ExpandItemWidth(Sender: TObject; ACanvas: TCanvas; var Width, 
      Height: Integer); 
    procedure AdvancedDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; 
      State: TOwnerDrawState); 
 
    procedure SetTransparent(Value: Boolean); 
    function GetTransparent: Boolean; 
 
    function GetBitmap: TBitmap; 
    procedure SetBitmap(Value: TBitmap); 
 
    procedure SetVerticalFont(Value: TFont); 
  public 
    { Public declarations } 
    constructor Create(AOwner: TComponent); override; 
    destructor Destroy; override; 
 
    procedure Popup(X, Y: Integer); override; 
//    property OwnerDraw; 
  published 
    { Published declarations } 
    property Bitmap: TBitmap read GetBitmap write SetBitmap; 
    property BarWidth: Integer read FBarWidth write FBarWidth default 31; 
    property BitmapOffsetX: Integer read FBitmapOffsetX write FBitmapOffsetX default 0; 
    property BitmapOffsetY: Integer read FBitmapOffsetY write FBitmapOffsetY default 0; 
    property BitmapVertAlignment: TBitmapVertAlignment read FBitmapVertAlignment 
      write FBitmapVertAlignment default bvaBottom; 
    property BitmapHorzAlignment: TBitmapHorzAlignment read FBitmapHorzAlignment 
      write FBitmapHorzAlignment default bhaLeft; 
    property BarVisible: Boolean read FBarVisible write FBarVisible default True; 
    property GradientEnd: TColor read FclEnd write FclEnd default clBlack; 
    property GradientStart: TColor read FclStart write FclStart default clBlue; 
    property Transparent: Boolean read GetTransparent write SetTransparent default True; 
    property VerticalFont: TFont read FVerticalFont write SetVerticalFont; 
    property VerticalText: string read FVerticalText write FVerticalText; 
    property VerticalTextOffsetY: Integer read FVerticalTextOffsetY 
      write FVerticalTextOffsetY default -6; 
  end; 
 
procedure Register; 
 
implementation 
 
procedure Register; 
begin 
  RegisterComponents('XP', [TBarPopupMenu]); 
end; 
 
constructor TBarPopupMenu.Create(AOwner: TComponent); 
begin 
  inherited Create(AOwner); 
 
  OwnerDraw := True; 
 
  FBitmapOffsetX := 0; 
  FBitmapOffsetY := 0; 
  FBitmapVertAlignment := bvaBottom; 
  FBitmapHorzAlignment := bhaLeft; 
 
  FVerticalFont := TFont.Create; 
  with FVerticalFont do 
  begin 
    Name := 'Tahoma'; 
    Size := 14; 
    Color := clWhite; 
    Style := [fsBold, fsItalic]; 
  end; 
 
  FVerticalTextOffsetY := -6; 
 
  FclStart := clBlue; 
  FclEnd := clBlack; 
 
  FBarWidth := 31; 
 
  FBarVisible := True; 
 
  if (Application.Handle <> 0) then 
    FVerticalText := Application.Title; { some defaults } 
end; 
 
destructor TBarPopupMenu.Destroy; 
begin 
  FVerticalFont.Free; 
  if Assigned(FBitmap) then FBitmap.Free; 
  inherited Destroy; 
end; 
 
procedure TBarPopupMenu.SetTransparent(Value: Boolean); 
begin 
  if FBitmap = nil then Exit; 
  if (Value <> FBitmap.Transparent) then 
    FBitmap.Transparent := Value; 
end; 
 
function TBarPopupMenu.GetTransparent: Boolean; 
begin 
  if FBitmap = nil then 
    Result := False 
  else 
    Result := FBitmap.Transparent; 
end; 
 
procedure TBarPopupMenu.SetBitmap(Value: TBitmap); 
begin 
  if FBitmap = nil then 
  begin 
    FBitmap := TBitmap.Create; 
    FBitmap.Transparent := True; 
  end; 
{  if Value = nil then 
    FBitmap.Free 
  else} 
    FBitmap.Assign(Value); 
end; 
 
function TBarPopupMenu.GetBitmap: TBitmap; 
begin 
  if FBitmap = nil then 
  begin 
    FBitmap := TBitmap.Create; 
    FBitmap.Transparent := True; 
  end; 
  Result := FBitmap; 
end; 
 
procedure TBarPopupMenu.SetVerticalFont(Value: TFont); 
begin 
  FVerticalFont.Assign(Value); 
end; 
 
{ ============================================================================ 
  CreateRotatedFont 
  Date: 2000-06-22 
  Description: Creates rotated font, returns handle to it 
  Parameters: 
    F: TFont, where to copy styles 
    Angle: Integer, font angle 
  ---------------------------------------------------------------------------- } 
function CreateRotatedFont(F: TFont; Angle: Integer): hFont; 
var 
  LF : TLogFont; 
begin 
  FillChar(LF, SizeOf(LF), #0); 
  with LF do 
  begin 
    lfHeight := F.Height; 
    lfWidth := 0; 
    lfEscapement := Angle*10; 
    lfOrientation := 0; 
    if fsBold in F.Style then 
      lfWeight := FW_BOLD 
    else 
      lfWeight := FW_NORMAL; 
    lfItalic := Byte(fsItalic in F.Style); 
    lfUnderline := Byte(fsUnderline in F.Style); 
    lfStrikeOut := Byte(fsStrikeOut in F.Style); 
    lfCharSet := DEFAULT_CHARSET; 
    StrPCopy(lfFaceName, F.Name); 
    lfQuality := DEFAULT_QUALITY; 
 
    lfOutPrecision := OUT_DEFAULT_PRECIS; 
    lfClipPrecision := CLIP_DEFAULT_PRECIS; 
    case F.Pitch of 
      fpVariable: lfPitchAndFamily := VARIABLE_PITCH; 
      fpFixed: lfPitchAndFamily := FIXED_PITCH; 
    else 
      lfPitchAndFamily := DEFAULT_PITCH; 
    end; 
  end; 
  Result := CreateFontIndirect(LF); 
end; 
{ ============================================================================ 
  TBarPopupMenu.Popup 
  Date: 2000-06-22 
  Description: 
    Set initial events for popup items. Currently just overwrites old events.. 
  ---------------------------------------------------------------------------- } 
procedure TBarPopupMenu.Popup(X, Y: Integer); 
var i: Integer; 
begin 
  PopupHeight := 0; 
  Drawn := False; 
 
  if (Items.Count > 0) then 
    for i := 0 to Items.Count-1 do 
    begin 
      Items[i].OnMeasureItem := ExpandItemWidth; 
      Items[i].OnAdvancedDrawItem := AdvancedDrawItem; 
    end; 
 
  inherited Popup(X, Y); 
end; 
 
procedure TBarPopupMenu.ExpandItemWidth(Sender: TObject; 
  ACanvas: TCanvas; var Width, Height: Integer); 
var 
  MenuItem: TMenuItem; 
begin 
  if not FBarVisible then Exit; 
 
  Width := Width + FBarWidth+10; { make space for graphical bar } 
 
  MenuItem := TMenuItem(Sender); 
 
  if MenuItem.Visible and (MenuItem.Caption <> ExpandChar) then 
    PopupHeight := PopupHeight + Height; 
end; 
 
procedure TBarPopupMenu.AdvancedDrawItem(Sender: TObject; 
  ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState); 
var 
  i, itmp, x, y: Integer; 
  r: TRect; 
  rc1, rc2, gc1, gc2, bc1, bc2: Byte; 
  ColorStart, ColorEnd: Longint; 
  OnAdvancedDrawItem: TAdvancedMenuDrawItemEvent; 
  MenuItem: TMenuItem; 
begin 
  MenuItem := TMenuItem(Sender); 
 
  if MenuItem.Caption = ExpandChar then Exit; { it has been already drawn } 
 
  { we need to remove draw event so DrawMenuItem won't generate infinite loop! 
    (Recursive) } 
  OnAdvancedDrawItem := MenuItem.OnAdvancedDrawItem; 
  MenuItem.OnAdvancedDrawItem := nil; 
 
  { align rect where item is draw so that vcl will leave bar for us } 
  r := ARect; 
  if FBarVisible then 
  begin 
    r.Right := r.Right - FBarWidth; { remove bar width } 
    OffsetRect(r, FBarWidth, 0); 
  end; 
 
  { draw item and restore event back } 
  DrawMenuItem(MenuItem, ACanvas, r, State); 
  MenuItem.OnAdvancedDrawItem := OnAdvancedDrawItem; 
 
  if not FBarVisible then Exit; 
 
  if not Drawn then 
  begin 
    ACanvas.Brush.Style := bsSolid; 
    if (FclStart = FclEnd) then { same color, just one fillrect required } 
      begin 
        ACanvas.Brush.Color := FclStart; 
        ACanvas.FillRect(Rect(0, ARect.Top, FBarWidth - BarSpace, ARect.Bottom{ + 1})); 
      end 
    else { draw smooth gradient bar part for this item } 
    begin 
      ColorStart := ColorToRGB(FclStart); 
      ColorEnd := ColorToRGB(FclEnd); 
 
      rc1 := GetRValue(ColorStart); 
      gc1 := GetGValue(ColorStart); 
      bc1 := GetBValue(ColorStart); 
      rc2 := GetRValue(ColorEnd); 
      gc2 := GetGValue(ColorEnd); 
      bc2 := GetBValue(ColorEnd); 
 
      for i := 0 to (ARect.Bottom - ARect.Top) do 
      begin 
        ACanvas.Brush.Color := RGB( 
          (rc1 + (((rc2 - rc1) * (ARect.Top + i)) div PopupHeight)), 
          (gc1 + (((gc2 - gc1) * (ARect.Top + i)) div PopupHeight)), 
          (bc1 + (((bc2 - bc1) * (ARect.Top + i)) div PopupHeight))); 
        ACanvas.FillRect(Rect(0, ARect.Top + i, FBarWidth - BarSpace, ARect.Top + i + 1)); 
      end; 
    end; 
 
    { vertical text to gradient bar } 
    with ACanvas.Font do 
    begin 
      Assign(FVerticalFont); 
 
      itmp := Handle; { store old } 
      Handle := CreateRotatedFont(ACanvas.Font, 90); 
 
      x := Round((FBarWidth - ACanvas.TextHeight('X')) / 2 - 0.5); { gives much better centering } 
//      x := (FBarWidth - ACanvas.TextHeight('X')) div 2; 
    end; 
 
    ACanvas.Brush.Style := bsClear; 
 
    r := Rect(ARect.Left, ARect.Top, ARect.Right, ARect.Bottom + 1); 
 
    y := PopupHeight + FVerticalTextOffsetY; 
    if Assigned(FBitmap) and (FBitmapVertAlignment = bvaBottom) then 
      y := y - FBitmap.Height; 
 
    ExtTextOut(ACanvas.Handle, x - 1, y, ETO_CLIPPED, 
      @r, PChar(VerticalText), Length(VerticalText), nil); 
 
    { delete created font and restore old handle } 
    DeleteObject(ACanvas.Font.Handle); 
    ACanvas.Font.Handle := itmp; 
 
    if PopupHeight = ARect.Bottom {MenuItem = MenuItem.Parent.Items[MenuItem.Parent.Count-1]} then 
      begin 
        Drawn := True; 
 
        { draw bitmap } 
        if Assigned(FBitmap) then 
        begin 
          y := 0; x := 0; 
          case FBitmapVertAlignment of 
            bvaTop:    y := FBitmapOffsetY; 
            bvaBottom: y := PopupHeight + FBitmapOffsetY - FBitmap.Height; 
            bvaMiddle: y := ((PopupHeight - Fbitmap.Height) div 2) + FBitmapOffsetY; 
          end; 
 
          case FBitmapHorzAlignment of 
            bhaLeft:   x := FBitmapOffsetX; 
            bhaRight:  x := (FBarWidth - BarSpace) + FBitmapOffsetX - FBitmap.Width; 
            bhaCenter: x := ((FBarWidth - BarSpace - FBitmap.Width) div 2) + FBitmapOffsetX; 
          end; 
 
          ACanvas.Draw(x, y, FBitmap); 
        end; 
      end; 
  end; 
end; 
 
end.