jvballoonhint.pas

East make Tray Icon in delphi

  const AHint, AHeader: string; const VisibleTime: Integer);
begin
  if not Assigned(ACtrl) then
    Exit;

  CancelHint;

  with FData do
  begin
    RHint := AHint;
    RHeader := AHeader;
    RVisibleTime := VisibleTime;
    RIconKind := ikNone;
  end;

  InternalActivateHint(ACtrl);
end;

procedure TJvBalloonHint.ActivateHint(ACtrl: TControl; const AHint: string;
  const AIconKind: TJvIconKind; const AHeader: string; const VisibleTime: Integer);
begin
  if not Assigned(ACtrl) then
    Exit;

  CancelHint;

  with FData do
  begin
    RHint := AHint;
    RIconKind := AIconKind;
    RImageIndex := -1;
    RHeader := AHeader;
    RVisibleTime := VisibleTime;
  end;

  InternalActivateHint(ACtrl);
end;

procedure TJvBalloonHint.ActivateHintPos(AAnchorWindow: TCustomForm;
  AAnchorPosition: TPoint; const AHeader, AHint: string;
  const VisibleTime: Integer; const AIconKind: TJvIconKind;
  const AImageIndex: TImageIndex);
begin
  CancelHint;

  with FData do
  begin
    RAnchorWindow := AAnchorWindow;
    RAnchorPosition := AAnchorPosition;
    RHeader := AHeader;
    RHint := AHint;
    RVisibleTime := VisibleTime;
    RIconKind := AIconKind;
    RImageIndex := AImageIndex;
    RSwitchHeight := 0;
  end;

  InternalActivateHintPos;
end;

procedure TJvBalloonHint.ActivateHintRect(ARect: TRect; const AHeader,
  AHint: string; const VisibleTime: Integer; const AIconKind: TJvIconKind;
  const AImageIndex: TImageIndex);
begin
  CancelHint;

  with FData do
  begin
    RAnchorWindow := nil;
    RAnchorPosition := Point((ARect.Left + ARect.Right) div 2, ARect.Bottom);
    RHeader := AHeader;
    RHint := AHint;
    RVisibleTime := VisibleTime;
    RIconKind := AIconKind;
    RImageIndex := AImageIndex;
    RSwitchHeight := ARect.Bottom - ARect.Top;
  end;

  InternalActivateHintPos;
end;

procedure TJvBalloonHint.CancelHint;
begin
  if not FActive then
    Exit;

  FActive := False;
  StopHintTimer;
  UnHook;

  if GetCapture = FHint.Handle then
    ReleaseCapture;
  { Ensure property Visible is set to False: }
  FHint.Hide;
  { If ParentWindow = 0, calling Hide won't trigger the CM_SHOWINGCHANGED message
    thus ShowWindow/SetWindowPos isn't called. We do it ourselfs: }
  if FHint.ParentWindow = 0 then
    ShowWindow(FHint.Handle, SW_HIDE);

  FHint.ParentWindow := 0;

  if Assigned(FOnClose) then
    FOnClose(Self);
end;

function TJvBalloonHint.GetHandle: THandle;
begin
  if FHandle = 0 then
    FHandle := AllocateHWndEx(WndProc);
  Result := FHandle;
end;

function TJvBalloonHint.GetUseBalloonAsApplicationHint: Boolean;
begin
  Result := TGlobalCtrl.Instance.UseBalloonAsApplicationHint;
end;

procedure TJvBalloonHint.HandleClick(Sender: TObject);
begin
  if Assigned(FOnBalloonClick) then
    FOnBalloonClick(Self);
end;

function TJvBalloonHint.HandleCloseBtnClick: Boolean;
begin
  Result := True;
  if Assigned(FOnCloseBtnClick) then
    FOnCloseBtnClick(Self, Result);
end;

procedure TJvBalloonHint.HandleDblClick(Sender: TObject);
begin
  if Assigned(FOnDblClick) then
    FOnDblClick(Self);
end;

procedure TJvBalloonHint.HandleMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnMouseDown) then
    FOnMouseDown(Self, Button, Shift, X, Y);
end;

procedure TJvBalloonHint.HandleMouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnMouseMove) then
    FOnMouseMove(Self, Shift, X, Y);
end;

procedure TJvBalloonHint.HandleMouseUp(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Assigned(FOnMouseUp) then
    FOnMouseUp(Self, Button, Shift, X, Y);
end;

procedure TJvBalloonHint.Hook;
begin
  if Assigned(FData.RAnchorWindow) then
    RegisterWndProcHook(FData.RAnchorWindow, HookProc, hoBeforeMsg);
end;

function TJvBalloonHint.HookProc(var Msg: TMessage): Boolean;
begin
  Result := False;
  case Msg.Msg of
    WM_MOVE:
      with FData do
        FHint.MoveWindow(RAnchorWindow.ClientToScreen(RAnchorPosition));
    WM_SIZE:
      with FData do
        { (rb) This goes wrong if the balloon is anchored to the window itself }
        if not PtInRect(RAnchorWindow.ClientRect, RStemPointPosition) then
          CancelHint;
    WM_SHOWWINDOW:
      ;
    WM_WINDOWPOSCHANGED:
      { Hide/Restore the balloon if the window is minimized }
      FHint.Visible :=
        not IsIconic(FData.RAnchorWindow.Handle) and
        not IsIconic(Application.Handle);
    WM_ACTIVATE:
      if Msg.WParam = WA_INACTIVE then
        { Remove HWND_TOPMOST flag }
        FHint.NormalizeTopMost
      else
        { Restore HWND_TOPMOST flag }
        FHint.RestoreTopMost;
    WM_CLOSE:
      CancelHint;
    WM_NCACTIVATE, WM_EXITSIZEMOVE:
      { (rb) Weird behaviour of windows ? }
      FHint.RestoreTopMost;
  end;
end;

procedure TJvBalloonHint.InternalActivateHint(ACtrl: TControl);
var
  LParentForm: TCustomForm;
begin
  if not Assigned(ACtrl) then
    Exit;

  LParentForm := GetParentForm(ACtrl);
  with ACtrl, FData do
  begin
    RAnchorWindow := LParentForm;
    if LParentForm = ACtrl then
      RAnchorPosition := Point(Width div 2, ClientHeight)
    else
      RAnchorPosition := InternalClientToParent(ACtrl, Point(Width div 2, Height), LParentForm);

    RSwitchHeight := ACtrl.Height;
  end;

  InternalActivateHintPos;
end;

procedure TJvBalloonHint.InternalActivateHintPos;
var
  Rect: TRect;
  Animate: BOOL;
begin
  with FData do
  begin
    { Use defaults if necessairy: }
    if boUseDefaultHeader in Options then
      RHeader := DefaultHeader;
    if boUseDefaultIcon in Options then
      RIconKind := DefaultIcon;
    if boUseDefaultImageIndex in Options then
      RImageIndex := DefaultImageIndex;
    RShowCloseBtn := boShowCloseBtn in Options;

    { Determine animation style }
    if not IsWinXP_UP then
      RAnimationStyle := atNone
    else
    if boCustomAnimation in Options then
    begin
      RAnimationStyle := FCustomAnimationStyle;
      RAnimationTime := FCustomAnimationTime;
    end
    else
    begin
      SystemParametersInfo(SPI_GETTOOLTIPANIMATION, 0, @Animate, 0);
      if Animate then
      begin
        SystemParametersInfo(SPI_GETTOOLTIPFADE, 0, @Animate, 0);
        if Animate then
          RAnimationStyle := atBlend
        else
          RAnimationStyle := atSlide;
      end
      else
        RAnimationStyle := atNone;
      RAnimationTime := 100;
    end;

    { Hook the anchor window }
    FActive := True;
    Hook;

    { Determine the size of the balloon rect, the stem point will be on
      position (0, 0) }
    Rect := FHint.CalcHintRect(Screen.Width, RHint, @FData);

    { Offset the rectangle to the anchor position }
    if Assigned(RAnchorWindow) then
      with RAnchorWindow.ClientToScreen(RAnchorPosition) do
        OffsetRect(Rect, X, Y)
    else
      with RAnchorPosition do
        OffsetRect(Rect, X, Y);

    if boPlaySound in Options then
      TGlobalCtrl.Instance.PlaySound(RIconKind);

    FHint.InternalActivateHint(Rect, RHint);

    { Now we can determine the actual anchor & stempoint position: }
    if Assigned(RAnchorWindow) then
    begin
      RAnchorPosition := RAnchorWindow.ScreenToClient(Rect.TopLeft);
      RStemPointPosition := RAnchorWindow.ScreenToClient(FHint.StemPointPosition);
    end
    else
    begin
      RAnchorPosition := Rect.TopLeft;
      RStemPointPosition := FHint.StemPointPosition;
    end;

    { Last call because of possible CancelHint call in StartHintTimer }
    if RVisibleTime > 0 then
      StartHintTimer(RVisibleTime);
    {if GetCapture = 0 then
      SetCapture(FHint.Handle);
    ReleaseCapture;}
  end;
end;

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

procedure TJvBalloonHint.SetImages(const Value: TCustomImageList);
begin
  FImages := Value;
  if Images <> nil then
    Images.FreeNotification(Self);
end;

procedure TJvBalloonHint.SetOptions(const Value: TJvBalloonOptions);
begin
  if Value <> FOptions then
    FOptions := Value;
end;

procedure TJvBalloonHint.SetUseBalloonAsApplicationHint(
  const Value: Boolean);
begin
  TGlobalCtrl.Instance.UseBalloonAsApplicationHint := Value;
end;

procedure TJvBalloonHint.StartHintTimer(Value: Integer);
begin
  StopHintTimer;
  if SetTimer(Handle, 1, Value, nil) = 0 then
    CancelHint
  else
    FTimerActive := True;
end;

procedure TJvBalloonHint.StopHintTimer;
begin
  if FTimerActive then
  begin
    KillTimer(Handle, 1);
    FTimerActive := True;
  end;
end;

procedure TJvBalloonHint.UnHook;
begin
  if Assigned(FData.RAnchorWindow) then
    UnRegisterWndProcHook(FData.RAnchorWindow, HookProc, hoBeforeMsg);
end;

procedure TJvBalloonHint.WndProc(var Msg: TMessage);
begin
  with Msg do
    if Msg = WM_TIMER then
    try
      CancelHint;
    except
      {$IFDEF COMPILER6_UP}
      if Assigned(ApplicationHandleException) then
        ApplicationHandleException(Self);
      {$ELSE}
      Application.HandleException(Self);
      {$ENDIF COMPILER6_UP}
    end
    else
      Result := DefWindowProc(Handle, Msg, WParam, LParam);
end;

//=== { TGlobalCtrl } ========================================================

constructor TGlobalCtrl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  FCtrls := TList.Create;

  if IsWinXP_UP then
  begin
    FDefaultImages := TImageList.Create(nil);
    { According to MSDN flag ILC_COLOR32 needs to be included (?) }
    FDefaultImages.Handle := ImageList_Create(16, 16, ILC_COLOR32 or ILC_MASK, 4, 4);
  end
  else
    FDefaultImages := TImageList.CreateSize(16, 16);

  { Only need to update the background color in XP when using pre v6.0 ComCtl32.dll
    image lists }
  FNeedUpdateBkColor := IsWinXP_UP and (GetComCtlVersion < $00060000);

  if FNeedUpdateBkColor then
    FDefaultImages.BkColor := Application.HintColor
  else
    FDefaultImages.BkColor := clNone;

  FBkColor := Application.HintColor;
  FUseBalloonAsApplicationHint := False;

  GetDefaultImages;
  GetDefaultSounds;
end;

destructor TGlobalCtrl.Destroy;
begin
  FDefaultImages.Free;
  FCtrls.Free;
  inherited Destroy;
end;

procedure TGlobalCtrl.Add(ABalloonHint: TJvBalloonHint);
begin
  FCtrls.Add(ABalloonHint);
  { Determine whether we are designing }
  if Assigned(ABalloonHint) then
    FDesigning := csDesigning in ABalloonHint.ComponentState;
end;

procedure TGlobalCtrl.DrawHintImage(Canvas: TCanvas; X, Y: Integer; const ABkColor: TColor);
begin
  DrawHintImage(Canvas, X, Y, MainCtrl.DefaultIcon, MainCtrl.DefaultImageIndex, ABkColor);
end;

procedure TGlobalCtrl.DrawHintImage(Canvas: TCanvas; X, Y: Integer;
  const AIconKind: TJvIconKind; const AImageIndex: TImageIndex; const ABkColor: TColor);
const
  CDefaultImages: array [TJvIconKind] of Integer = (-1, -1, 0, 1, 2, 3, 4);
begin
  case AIconKind of
    ikCustom:
      with MainCtrl do
        if not Assigned(Images) or (AImageIndex < 0) or (AImageIndex >= Images.Count) then
        begin
          BkColor := ABkColor;
          FDefaultImages.Draw(Canvas, X, Y, CDefaultImages[ikInformation]);
        end
        else
          Images.Draw(Canvas, X, Y, AImageIndex);
    ikNone:
      ;
  else
    begin
      BkColor := ABkColor;
      FDefaultImages.Draw(Canvas, X, Y, CDefaultImages[AIconKind]);
    end;
  end;
end;

procedure TGlobalCtrl.GetDefaultImages;
type
  TPictureType = (ptXP, ptNormal, ptSimple);
const
  { Get the images:

    For        From          ID   TJvIconKind    Spec
    ---------------------------------------------------------------------------
    Windows XP User32.dll   100   ikApplication  16x16 32x32 48x48 1,4,8,32 bpp
                            101   ikWarning
                            102   ikQuestion
                            103   ikError
                            104   ikInformation
                            105   ikApplication
    All (?)    comctl32.dll 20480 ikError        16x16 32x32 4 bpp
                            20481 ikInformation
                            20482 ikWarning
  }

  { ikApplication, ikError, ikInformation, ikQuestion, ikWarning }
  CIcons: array [TPictureType, ikApplication..ikWarning] of Integer = (
    (100, 103, 104, 102, 101),                             // XP
    (OIC_SAMPLE, 20480, 20481, OIC_QUES, 20482),           // Normal
    (OIC_SAMPLE, OIC_HAND, OIC_NOTE, OIC_QUES, OIC_BANG)   // Paranoid
    );
  CFlags: array [Boolean] of UINT = (0, LR_SHARED);
var
  IconKind: TJvIconKind;
  PictureType: TPictureType;
  IconHandle: THandle;
  Shared: Boolean;
  Modules: array [Boolean] of HMODULE;
begin
  PictureType := ptNormal;
  Modules[True] := 0;

  if IsWinXP_UP then
  begin
    Modules[False] := GetModuleHandle('user32.dll');
    if Modules[False] <> 0 then
      PictureType := ptXP
  end;

  if PictureType = ptNormal then
  begin
    Modules[False] := GetModuleHandle('comctl32.dll');
    if Modules[False] = 0 then
      PictureType := ptSimple;
  end;