Chip 1999 March/Chip_1999-03_cd.bin/zkuste/delphi/D/XBALOON.ZIP/xbaloon.pas

Pascal/Delphi Source File | 1999-01-24 | 14KB | 469 lines

{*************************************************************}
{            XBaloon Component for Delphi 16/32               }
{ Version:   1.01                                             }
{ Author:    Aleksey Kuznetsov, Kiev, Ukraine                 }
{            └δσΩ±σΘ ╩≤τφσ÷εΓ (Xacker), ╩ΦσΓ, ╙Ω≡αΦφα         }
{ E-Mail:    [e-mail]                              }
{ Created:   January, 20, 1999                                }
{ Modified:  January, 24, 1999                                }
{ Legal:     Copyright (c) 1999 by Xacker from Droids Clan    }
{                             http://droids.virtualave.net    }
{*************************************************************}
{                    IMPORTANT NOTE:                          }
{  This code may be used and modified by anyone so long as    }
{ this header and copyright information remains intact. By    }
{ using this code you agree to indemnify Aleksey Xacker from  }
{ any liability that might arise from its use. You must       }
{ obtain written consent before selling or redistributing     }
{ this code.                                                  }
{*************************************************************}
{  Methods:                                                   }
{       Show(Point: TPoint; Text: String);                    }
{       Hide                                                  }
{ See demonstration program.                                  }
{*************************************************************}
{ Thanks for using XBaloon component.                         }
{ If at occurrence of any questions concerning these          }
{ components, mail me: [e-mail].                   }
{*************************************************************}
{ 24.I.1999: Added IsShowing, GetX and GetY public functions. }
{*************************************************************}
unit XBaloon;

interface

uses
  {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  SysUtils, Messages, Classes, Graphics, Controls, Forms;

{$IFDEF WIN32}
{$R XBALOON.R32}
{$ELSE}
{$R XBALOON.R16}
{$ENDIF}

type
  TPShape = (sRoundRect, sRectangle);
  TTextAlign = (taCenter, taLeft, taRight);

  TBaloonWindow = class(TCustomControl)
  private
    Tail: TBitmap;
    Underground: TBitmap;

    procedure DrawTransparentBitmap(ahdc: HDC;
                                    xStart, yStart, x1,y1,x2,y2: Word);

    procedure Show(var Rect: TRect; x, y: Integer; Text: String; Shape: TPShape;
                   TextAlign: TTextAlign; DivChar: Char);
    procedure WMMouseMove(var Msg: TMessage); message wm_MouseMove;
    {$IFDEF WIN32}
    procedure WMMouseDown(var Msg: TMessage); message wm_LButtonDown;
    {$ENDIF}
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Paint; override;
  public
    Showing: Boolean;
    HideIfMouseMove: Boolean;
    {$IFDEF WIN32}
    HideIfMouseClick: Boolean;
    {$ENDIF}

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Activate(Point: TPoint; Text: String; Shape: TPShape;
                       TextAlign: TTextAlign; DivChar: Char); virtual;
    procedure Deactivate;
  end;

  TXBaloon = class(TComponent)
  private
    FColor: TColor;
    FFont: TFont;
    FDivisionChar: Char;
    FHideIfMouseMove: Boolean;
    {$IFDEF WIN32}
    FHideIfMouseClick: Boolean;
    {$ENDIF}
    FShape: TPShape;
    FTextAlign: TTextAlign;

    Baloon: TBaloonWindow;
    LastX, LastY: Integer;
  protected
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;

    procedure Show(Point: TPoint; Text: String);
    procedure Hide;
    function IsShowing: Boolean;
    function GetX: Integer;
    function GetY: Integer;
  published
    property Color: TColor read FColor write FColor;
    property Font: TFont read FFont write FFont;
    property DivisionChar: Char read FDivisionChar write FDivisionChar;
    property HideIfMouseMove: Boolean read FHideIfMouseMove write FHideIfMouseMove;
    {$IFDEF WIN32}
    property HideIfMouseClick: Boolean read FHideIfMouseClick write FHideIfMouseClick;
    {$ENDIF}
    property Shape: TPShape read FShape write FShape;
    property TextAlign: TTextAlign read FTextAlign write FTextAlign;
  end;


procedure Register;

implementation

procedure TBaloonWindow.DrawTransparentBitmap(ahdc: HDC;
                                 xStart, yStart, x1,y1,x2,y2: Word);
var
  TransparentColor: TColor;
  cColor          : TColorRef;
  bmAndBack,
  bmAndObject,
  bmAndMem,
  bmSave,
  bmBackOld,
  bmObjectOld,
  bmMemOld,
  bmSaveOld       : HBitmap;
  hdcMem,
  hdcBack,
  hdcObject,
  hdcTemp,
  hdcSave         : HDC;
  ptSize          : TPoint;
begin
  { set the transparent to black }
  TransparentColor := clYellow;
  TransparentColor := TransparentColor or $02000000;

  hdcTemp := CreateCompatibleDC (ahdc);
  SelectObject (hdcTemp, Tail.Handle); { select the bitmap }

  { convert bitmap dimensions from device to logical points }
  ptSize.x := x2-x1;
  ptSize.y := y2-y1;
  DPToLP (hdcTemp, ptSize, 1);  { convert from device logical points }

  { create some DCs to hold temporary data }
  hdcBack   := CreateCompatibleDC(ahdc);
  hdcObject := CreateCompatibleDC(ahdc);
  hdcMem    := CreateCompatibleDC(ahdc);
  hdcSave   := CreateCompatibleDC(ahdc);

  { create a bitmap for each DC }

  { monochrome DC }
  bmAndBack   := CreateBitmap (ptSize.x, ptSize.y, 1, 1, nil);
  bmAndObject := CreateBitmap (ptSize.x, ptSize.y, 1, 1, nil);

  bmAndMem    := CreateCompatibleBitmap (ahdc, ptSize.x, ptSize.y);
  bmSave      := CreateCompatibleBitmap (ahdc, ptSize.x, ptSize.y);

  { each DC must select a bitmap object to store pixel data }
  bmBackOld   := SelectObject (hdcBack, bmAndBack);
  bmObjectOld := SelectObject (hdcObject, bmAndObject);
  bmMemOld    := SelectObject (hdcMem, bmAndMem);
  bmSaveOld   := SelectObject (hdcSave, bmSave);

  { set proper mapping mode }
  SetMapMode (hdcTemp, GetMapMode (ahdc));

  { save the bitmap sent here, because it will be overwritten }
  BitBlt (hdcSave, 0, 0, ptSize.x, ptSize.y, hdcTemp, x1, y1, SRCCOPY);

  { set the background color of the source DC to the color.
    contained in the parts of the bitmap that should be transparent }
  cColor := SetBkColor (hdcTemp, TransparentColor);

  { create the object mask for the bitmap by performing a BitBlt()
    from the source bitmap to a monochrome bitmap }
  BitBlt (hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, x1, y1, SRCCOPY);

  { set the background color of the source DC back to the original color }
  SetBkColor (hdcTemp, cColor);

  { create the inverse of the object mask }
  BitBlt (hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, NOTSRCCOPY);

  { copy the background of the main DC to the destination }
  BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, ahdc, xStart, yStart, SRCCOPY);

  { mask out the places where the bitmap will be placed }
  BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, SRCAND);

  { mask out the transparent colored pixels on the bitmap }
  BitBlt (hdcTemp, x1, y1, ptSize.x, ptSize.y, hdcBack, 0, 0, SRCAND);

  { XOR the bitmap with the background on the destination DC }
  BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, hdcTemp, x1, y1, SRCPAINT);

  { copy the destination to the screen }
  BitBlt (ahdc, xStart, yStart, ptSize.x, ptSize.y, hdcMem, 0, 0, SRCCOPY);

  { place the original bitmap back into the bitmap sent here }
  BitBlt (hdcTemp, x1, y1, ptSize.x, ptSize.y, hdcSave, 0, 0, SRCCOPY);

  { delete the memory bitmaps }
  DeleteObject (SelectObject (hdcBack, bmBackOld));
  DeleteObject (SelectObject (hdcObject, bmObjectOld));
  DeleteObject (SelectObject (hdcMem, bmMemOld));
  DeleteObject (SelectObject (hdcSave, bmSaveOld));

  { delete the memory DCs }
  DeleteDC (hdcMem);
  DeleteDC (hdcBack);
  DeleteDC (hdcObject);
  DeleteDC (hdcSave);
  DeleteDC (hdcTemp);
end;

{ TBaloonWindow }

constructor TBaloonWindow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  HideIfMouseMove := TXBaloon(AOwner).HideIfMouseMove;
  {$IFDEF WIN32}
  HideIfMouseClick := TXBaloon(AOwner).HideIfMouseClick;
  {$ENDIF}
  Tail := TBitmap.Create;
  Tail.Handle := LoadBitmap(hInstance, 'TAIL');
  Underground := TBitmap.Create;
end;

destructor TBaloonWindow.Destroy;
begin
  Underground.Free;
  Tail.Free;
  inherited Destroy;
end;

procedure TBaloonWindow.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  {$IFDEF WIN32}
  with Params do
  begin
    Style := WS_POPUP;
    WindowClass.Style := WindowClass.Style or CS_SAVEBITS;
    if NewStyleControls then ExStyle := WS_EX_TOOLWINDOW;
  end;
  {$ELSE}
  with Params do
  begin
    if HideIfMouseMove then Style := WS_POPUP
    else Style := WS_POPUP or WS_DISABLED;
    WindowClass.Style := WindowClass.Style or CS_SAVEBITS;
  end;
  {$ENDIF}
end;

procedure TBaloonWindow.Show(var Rect: TRect; x, y: Integer; Text: String; Shape: TPShape;
                             TextAlign: TTextAlign; DivChar: Char);
var
  q, i: Integer;
  MaxWidth, FontHeight: Integer;
  SL: TStringList;
  h: Integer;
  DC: hDC;
begin
  if Length(Text) <> 0 then
   begin
    SL := TStringList.Create;
    with Underground.Canvas do
     begin
      q := 1;
      for i := 1 to Length(Text) do
       if Text[i] = '@' then
        begin
         SL.Add(Copy(Text, q, i - q));
         q := i + 1;
        end;
      SL.Add(Copy(Text, q, i));

      MaxWidth := 0;

      FontHeight := 0;
      for i := 0 to SL.Count - 1 do
       begin
        FontHeight := FontHeight + TextHeight(SL[i]);
        h := TextWidth(SL[i]);
        if MaxWidth < h then
         MaxWidth := h;
       end;

      Underground.Width := MaxWidth + 23;
      Underground.Height := y - (y - FontHeight - 2) + 18;
      DC := GetDC(0);
      BitBlt(Underground.Canvas.Handle, 0, 0, Underground.Width, Underground.Height, DC,
             x, y - FontHeight - 2, SrcCopy);
      ReleaseDC(0, DC);

      Brush.Color := clBlack;
      if Shape = sRoundRect then
       RoundRect(12, 2,
                 MaxWidth + 23, FontHeight + 5, 15, 15)
      else
       Rectangle(12, 2,
                 MaxWidth + 23, FontHeight + 5);
      Brush.Color := Color;
      if Shape = sRoundRect then
       RoundRect(10, 0,
                 MaxWidth + 21, FontHeight + 3, 15, 15)
      else
       Rectangle(10, 0,
                 MaxWidth + 21, FontHeight + 3);

      DrawTransparentBitmap(Underground.Canvas.Handle,
                            0, FontHeight - 2, 0, 0, 15, 21);

      FloodFill(12, FontHeight - 3, clBlack, fsBorder);
      Pixels[3, FontHeight + 13] := Color;
      Pixels[3, FontHeight + 14] := Color;
      Pixels[2, FontHeight + 15] := Color;

      h := 1;
      for i := 0 to SL.Count - 1 do
       begin
        if TextAlign = taLeft then
         TextOut(15, h, SL[i])
        else
         begin
          q := TextWidth(SL[i]);
          if TextAlign = taCenter then
           begin
            q := MaxWidth div 2 - q div 2;
            TextOut(q + 15, h, SL[i])
           end
          else
           TextOut(MaxWidth - q + 15, h, SL[i]);
         end;
        inc(h, TextHeight(SL[i]));
       end;
     end;
    SL.Free;
  with Rect do
   begin
    left := x;
    top := y - FontHeight - 2;
    right := x + MaxWidth + 23;
    bottom := y + 18;
   end;
  end;
end;

procedure TBaloonWindow.WMMouseMove(var Msg: TMessage);
begin
  {$IFDEF WIN32}
  if HideIfMouseMove then {$ENDIF}
   Deactivate;
end;

{$IFDEF WIN32}
procedure TBaloonWindow.WMMouseDown(var Msg: TMessage);
begin
  if HideIfMouseClick then Deactivate;
end;
{$ENDIF}

procedure TBaloonWindow.Paint;
begin
  Canvas.Draw(0, 0, Underground);
end;

procedure TBaloonWindow.Deactivate;
begin
  Showing := False;
  DestroyHandle;
end;

procedure TBaloonWindow.Activate(Point: TPoint; Text: String; Shape: TPShape;
                                                              TextAlign: TTextAlign;
                                                              DivChar: Char);
var
  Rect: TRect;
begin
  if Showing then DestroyHandle;
  Show(Rect, Point.x, Point.y - 15, Text, Shape, TextAlign, DivChar);
  BoundsRect := Rect;

  SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, 0,
    0, SWP_SHOWWINDOW or SWP_NOACTIVATE or SWP_NOSIZE);
  Showing := True;
end;

{ TXBaloon }

constructor TXBaloon.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  FDivisionChar := '@';
  FFont := TFont.Create;
  FFont.Name := 'MS Sans Serif';
  FFont.Size := 8;
  FColor := clWindow;
  FHideIfMouseMove := True;
end;

destructor TXBaloon.Destroy;
begin
  if Baloon <> nil then Hide;
  FFont.Free;
  inherited Destroy;
end;

procedure TXBaloon.Show(Point: TPoint; Text: String);
begin
  if Text <> '' then
   begin
    if Baloon <> nil then Hide;
    Baloon := TBaloonWindow.Create(Self);
    Baloon.Underground.Canvas.Font.Assign(Font);
    Baloon.Color := FColor;
    LastX := Point.x;
    LastY := Point.y;
    Baloon.Activate(Point, Text, FShape, FTextAlign, FDivisionChar);
   end;
end;

procedure TXBaloon.Hide;
begin
  if Baloon <> nil then
   Baloon.Deactivate;
end;

function TXBaloon.IsShowing: Boolean;
begin
  if Baloon <> nil then
   Result := Baloon.Showing
  else
   Result := False;
end;

function TXBaloon.GetX: Integer;
begin
  if IsShowing then Result := LastX
  else Result := -1;
end;

function TXBaloon.GetY: Integer;
begin
  if IsShowing then Result := LastY
  else Result := -1;
end;

{ -------- }

procedure Register;
begin
  RegisterComponents('Xacker', [TXBaloon]);
end;

end.