jvballoonhint.pas

East make Tray Icon in delphi

  { Now   PictureType = ptXP     -> Modules = (user32.dll handle, 0)
          PictureType = ptNormal -> Modules = (comctl32.dll handle, 0)
          PictureType = ptSimple -> Modules = (0, 0)
  }

  for IconKind := Low(CIcons[PictureType]) to High(CIcons[PictureType]) do
  begin
    Shared := (PictureType = ptSimple) or
      (PictureType = ptNormal) and (IconKind in [ikApplication, ikQuestion]);
    IconHandle :=
      LoadImage(Modules[Shared], MakeIntResource(CIcons[PictureType, IconKind]),
      IMAGE_ICON, 16, 16, CFlags[Shared]);
    ImageList_AddIcon(FDefaultImages.Handle, IconHandle);
    { MSDN: Do not use DestroyIcon to destroy a shared icon. A shared icon is
      valid as long as the module from which it was loaded remains in memory }
    if not Shared then
      DestroyIcon(IconHandle);
  end;
end;

procedure TGlobalCtrl.GetDefaultSounds;
{ Taken from ActnMenus.pas }
var
  Registry: TRegistry;

  function ReadSoundSetting(KeyStr: string): string;
  var
    S: string;
  begin
    Registry.RootKey := HKEY_CURRENT_USER;
    Result := '';
    if Registry.OpenKeyReadOnly('\AppEvents\Schemes\Apps\.Default\' + KeyStr) then
    try
      S := Registry.ReadString('');
      SetLength(Result, 4096);
      SetLength(Result, ExpandEnvironmentStrings(PChar(S), PChar(Result), 4096) - 1);
    finally
      Registry.CloseKey;
    end;
  end;

begin
  Registry := TRegistry.Create;
  try
    FSounds[ikCustom] := ReadSoundSetting('SystemNotification\.Current');
    FSounds[ikNone] := FSounds[ikCustom];
    FSounds[ikApplication] := FSounds[ikCustom];
    FSounds[ikError] := ReadSoundSetting('SystemHand\.Current');
    FSounds[ikInformation] := ReadSoundSetting('SystemAsterisk\.Current');
    FSounds[ikQuestion] := ReadSoundSetting('SystemQuestion\.Current');
    FSounds[ikWarning] := ReadSoundSetting('SystemExclamation\.Current');
  finally
    Registry.Free;
  end;
end;

function TGlobalCtrl.GetMainCtrl: TJvBalloonHint;
begin
  if FCtrls.Count = 0 then
  begin
    if GMainCtrl = nil then
      GMainCtrl := TJvBalloonHint.Create(Self);
    Result := GMainCtrl;
  end
  else
    Result := TJvBalloonHint(FCtrls[0]);
end;

function TGlobalCtrl.HintImageSize: TSize;
begin
  Result := HintImageSize(MainCtrl.DefaultIcon, MainCtrl.DefaultImageIndex);
end;

function TGlobalCtrl.HintImageSize(const AIconKind: TJvIconKind;
  const AImageIndex: TImageIndex): TSize;
begin
  case AIconKind of
    ikCustom:
      with MainCtrl do
        if not Assigned(Images) or (AImageIndex < 0) or (AImageIndex >= Images.Count) then
        begin
          Result.cx := 16;
          Result.cy := 16;
        end
        else
        begin
          Result.cx := Images.Width;
          Result.cy := Images.Height;
        end;
    ikNone:
      begin
        Result.cx := 0;
        Result.cy := 0;
      end;
  else
    begin
      Result.cx := 16;
      Result.cy := 16;
    end;
  end;
end;

class function TGlobalCtrl.Instance: TGlobalCtrl;
begin
  if not Assigned(GGlobalCtrl) then
    GGlobalCtrl := TGlobalCtrl.Create(nil);
  Result := GGlobalCtrl;
end;

procedure TGlobalCtrl.PlaySound(const AIconKind: TJvIconKind);
begin
  if Length(FSounds[AIconKind]) > 0 then
    sndPlaySound(PChar(FSounds[AIconKind]), SND_NOSTOP or SND_ASYNC);
end;

procedure TGlobalCtrl.Remove(ABalloonHint: TJvBalloonHint);
var
  I: Integer;
begin
  I := FCtrls.IndexOf(ABalloonHint);
  if I >= 0 then
  begin
    FCtrls.Delete(I);

    if FCtrls.Count = 0 then
      UseBalloonAsApplicationHint := False;
  end;
end;

procedure TGlobalCtrl.SetBkColor(const Value: TColor);
begin
  if FNeedUpdateBkColor and (FBkColor <> Value) then
  begin
    { Icons in windows XP use an alpha channel to 'blend' with the background.
      If the background color changes, then the images must be redrawn,
      when using pre v6.0 ComCtl32.dll image lists
    }
    FBkColor := Value;
    FDefaultImages.Clear;
    FDefaultImages.BkColor := FBkColor;
    GetDefaultImages;
  end;
end;

procedure TGlobalCtrl.SetUseBalloonAsApplicationHint(const Value: Boolean);
begin
  if FDesigning then
    FUseBalloonAsApplicationHint := Value
  else
  if Value <> FUseBalloonAsApplicationHint then
  begin
    FUseBalloonAsApplicationHint := Value;

    Application.CancelHint;

    if FUseBalloonAsApplicationHint then
    begin
      FOldHintWindowClass := HintWindowClass;
      HintWindowClass := TJvBalloonWindow;
    end
    else
      HintWindowClass := FOldHintWindowClass;
  end;
end;

//=== { TJvBalloonWindowEx } =================================================

function TJvBalloonWindowEx.CalcHeaderRect(MaxWidth: Integer): TRect;
begin
  Result := inherited CalcHeaderRect(MaxWidth);
  if FShowCloseBtn then
  begin
    Inc(Result.Right, 20);
    if Result.Bottom < 20 then
      Result.Bottom := 20;
  end;
end;

procedure TJvBalloonWindowEx.ChangeCloseState(const AState: Cardinal);
{$IFDEF JVCLThemesEnabled}
var
  Details: TThemedElementDetails;
  Button: TThemedToolTip;
{$ENDIF JVCLThemesEnabled}
begin
  if AState <> FCloseState then
  begin
    FCloseState := AState;
    {$IFDEF JVCLThemesEnabled}
    if ThemeServices.ThemesEnabled then
    begin
      if (AState and DFCS_PUSHED > 0) and (AState and DFCS_HOT = 0) then
        Button := tttCloseNormal
      else
      if AState and DFCS_PUSHED > 0 then
        Button := tttClosePressed
      else
      if AState and DFCS_HOT > 0 then
        Button := tttCloseHot
      else
        Button := tttCloseNormal;

      Details := ThemeServices.GetElementDetails(Button);
      ThemeServices.DrawElement(Canvas.Handle, Details, FCloseBtnRect);
    end
    else
    {$ENDIF JVCLThemesEnabled}
      DrawFrameControl(Canvas.Handle, FCloseBtnRect, DFC_CAPTION, DFCS_TRANSPARENT or
        DFCS_CAPTIONCLOSE or FCloseState);
  end;
end;

function FormHasFocus(FormHandle: HWND): Boolean;
var
  H: HWND;
begin
  H := GetFocus;
  while IsWindow(H) and (H <> FormHandle) do
    H := GetParent(H);
  Result := H = FormHandle;
end;

procedure TJvBalloonWindowEx.EnsureTopMost;
begin
  if not Assigned(FCtrl.FData.RAnchorWindow) then
    Exit;

  if not FormHasFocus(FCtrl.FData.RAnchorWindow.Handle) then
    { Current window is not focused, thus place the balloon behind the
      window that has focus }
    NormalizeTopMost
  else
    RestoreTopMost;
end;

procedure TJvBalloonWindowEx.Init(AData: Pointer);
begin
  Canvas.Font := Screen.HintFont;
  Color := Application.HintColor;

  with PHintData(AData)^ do
  begin
    FImageIndex := RImageIndex;
    FIconKind := RIconKind;
    FHeader := RHeader;

    FShowHeader := FHeader > '';
    FShowIcon := (FIconKind <> ikNone) and
      ((FIconKind <> ikCustom) or (FImageIndex <> -1));
    FShowCloseBtn := RShowCloseBtn;

    FAnimationTime := RAnimationTime;
    FAnimationStyle := RAnimationStyle;

    FSwitchHeight := RSwitchHeight;
    FIsAnchored := Assigned(RAnchorWindow);
  end;

  FImageSize := TGlobalCtrl.Instance.HintImageSize(FIconKind, FImageIndex);
  FCurrentPosition := FCtrl.DefaultBalloonPosition;
end;

procedure TJvBalloonWindowEx.InternalActivateHint(var Rect: TRect;
  const AHint: string);
const
  {TJvAnimationStyle = (atNone, atSlide, atRoll, atRollHorNeg, atRollHorPos, atRollVerNeg,
    atRollVerPos, atSlideHorNeg, atSlideHorPos, atSlideVerNeg, atSlideVerPos, atCenter, atBlend);}
  CAnimationStyle: array [TJvAnimationStyle] of Integer = (0, AW_SLIDE, 0, AW_HOR_NEGATIVE,
    AW_HOR_POSITIVE, AW_VER_NEGATIVE, AW_VER_POSITIVE, AW_HOR_NEGATIVE or AW_SLIDE,
    AW_HOR_POSITIVE or AW_SLIDE, AW_VER_NEGATIVE or AW_SLIDE, AW_VER_POSITIVE or AW_SLIDE,
    AW_CENTER, AW_BLEND);
var
  AutoValue: Integer;
begin
  CheckPosition(Rect);

  if HandleAllocated and IsWindowVisible(Handle) then
  begin
    Hide;
    if ParentWindow = 0 then
      ShowWindow(Handle, SW_HIDE);
  end;

  { This will prevent focusing/unfocusing of the application button on the
    taskbar when clicking on the balloon window }
  if FIsAnchored then
    { Application Handle, so we automatically get minimized/restored when the
      application minimizes/restores }
    ParentWindow := Application.Handle
  else
    ParentWindow := 0;

  UpdateBoundsRect(Rect);
  UpdateRegion;
  UpdateBoundsRect(Rect);

  if Rect.Top + Height > Screen.DesktopHeight then
    Rect.Top := Screen.DesktopHeight - Height;
  if Rect.Left + Width > Screen.DesktopWidth then
    Rect.Left := Screen.DesktopWidth - Width;
  if Rect.Left < Screen.DesktopLeft then
    Rect.Left := Screen.DesktopLeft;
  if Rect.Bottom < Screen.DesktopTop then
    Rect.Bottom := Screen.DesktopTop;

  { Set the Z order of the balloon }
  if Assigned(FCtrl.FData.RAnchorWindow) then
  begin
    if not IsWindowVisible(FCtrl.FData.RAnchorWindow.Handle) or
      IsIconic(FCtrl.FData.RAnchorWindow.Handle) then
      { Current window is minimized, thus do not show the balloon }
      Exit
    else
      EnsureTopMost;
  end
  else
    RestoreTopMost;

  if (FAnimationStyle <> atNone) and IsWinXP_UP and Assigned(AnimateWindowProc) then
  begin
    if FAnimationStyle in [atSlide, atRoll] then
      case FCurrentPosition of
        bpLeftDown, bpRightDown:
          AutoValue := AW_VER_POSITIVE;
      else {bpLeftUp, bpRightUp:}
        AutoValue := AW_VER_NEGATIVE;
      end
    else
      AutoValue := 0;
    { This function will fail on systems other than Windows XP,
      because of use of the window region: }
    AnimateWindowProc(Handle, FAnimationTime, CAnimationStyle[FAnimationStyle] or AutoValue);
  end;

  { Ensure property Visible is set to True: }
  Show;
  { If ParentWindow = 0, calling Show won't trigger the CM_SHOWINGCHANGED message
    thus ShowWindow/SetWindowPos isn't called. We do it ourselfs: }
  if ParentWindow = 0 then
    ShowWindow(Handle, SW_SHOWNOACTIVATE);
  {$IFNDEF COMPILER6_UP}
  Invalidate;
  {$ENDIF !COMPILER6_UP}
end;

procedure TJvBalloonWindowEx.MoveWindow(NewPos: TPoint);
begin
  BoundsRect := Rect(NewPos.X, NewPos.Y, NewPos.X + Width, NewPos.Y + Height);
end;

procedure TJvBalloonWindowEx.NormalizeTopMost;
var
  TopWindow: HWND;
begin
  if not Assigned(FCtrl.FData.RAnchorWindow) then
    Exit;

  { Retrieve the window below the anchor window in the Z order. }
  TopWindow := GetWindow(FCtrl.FData.RAnchorWindow.Handle, GW_HWNDPREV);
  if GetWindowLong(TopWindow, GWL_EXSTYLE) and WS_EX_TOPMOST <> 0 then
    TopWindow := HWND_NOTOPMOST;

  SetWindowPos(Handle, TopWindow, 0, 0, 0, 0,
    SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER);
end;

procedure TJvBalloonWindowEx.Paint;
var
  HintRect: TRect;
  HeaderRect: TRect;
begin
  HintRect := ClientRect;

  if FShowIcon then
    TGlobalCtrl.Instance.DrawHintImage(Canvas, 12, FDeltaY + 7, FIconKind, FImageIndex, Color);

  FCloseState := 0;
  if FShowCloseBtn then
  begin
    FCloseBtnRect := Rect(HintRect.Right - 22, FDeltaY + 5, HintRect.Right - 6, FDeltaY + 21);
    {$IFDEF JVCLThemesEnabled}
    if ThemeServices.ThemesEnabled then
    begin
      Dec(FCloseBtnRect.Left);
      Dec(FCloseBtnRect.Top);
    end;
    {$ENDIF JVCLThemesEnabled}
    ChangeCloseState(DFCS_FLAT);
  end;

  if FMsg > '' then
  begin
    Inc(HintRect.Left, 12);
    Inc(HintRect.Top, FDeltaY + FMessageTop);
    Canvas.Font := Screen.HintFont;
    Canvas.Font.Style := Canvas.Font.Style - [fsBold];
    DrawText(Canvas.Handle, PChar(FMsg), -1, HintRect, 
      DefaultTextFlags or DrawTextBiDiModeFlagsReadingOnly);
  end;

  if FShowHeader then
  begin
    HeaderRect := ClientRect;
    Inc(HeaderRect.Left, 12);
    if FShowIcon then
      Inc(HeaderRect.Left, FImageSize.cx + 8);
    Inc(HeaderRect.Top, FDeltaY + 8);
    Canvas.Font.Style := Canvas.Font.Style + [fsBold];
    DrawText(Canvas.Handle, PChar(FHeader), -1, HeaderRect,
      DefaultTextFlags or DrawTextBiDiModeFlagsReadingOnly);
  end;
end;

procedure TJvBalloonWindowEx.RestoreTopMost;
begin
  SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0,
    SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER);
end;

procedure TJvBalloonWindowEx.WMActivateApp(var Msg: TWMActivateApp);
begin
  inherited;
  if Msg.Active then
    EnsureTopMost;
end;

procedure TJvBalloonWindowEx.WMLButtonDown(var Msg: TWMLButtonDown);
begin
  inherited;
  if FShowCloseBtn then
  begin
    if PtInRect(FCloseBtnRect, SmallPointToPoint(Msg.Pos)) then
    begin
      {SetCapture(Handle);}// handled in inherited
      ChangeCloseState(FCloseState or DFCS_PUSHED);
    end;
  end;
end;

procedure TJvBalloonWindowEx.WMLButtonUp(var Msg: TWMLButtonUp);
begin
  if FShowCloseBtn then
  begin
    if FCloseState and DFCS_PUSHED > 0 then
    begin
      {ReleaseCapture;}// handled in inherited
      ChangeCloseState(FCloseState and not DFCS_PUSHED);
      if PtInRect(FCloseBtnRect, SmallPointToPoint(Msg.Pos)) then
      begin
        { Prevent firing of OnClick event in inherited call }
        ControlState := ControlState - [csClicked];
        if FCtrl.HandleCloseBtnClick then
          FCtrl.CancelHint;
      end;
    end;
  end;
  inherited;
end;

procedure TJvBalloonWindowEx.WMMouseMove(var Msg: TWMMouseMove);
var
  State: Cardinal;
begin
  inherited;
  if FShowCloseBtn then
  begin
    State := DFCS_FLAT;

    if PtInRect(FCloseBtnRect, SmallPointToPoint(Msg.Pos)) then
    begin
      { Note: DFCS_HOT is not supported in windows 95 systems }
      State := State or DFCS_HOT;
      if FCloseState and DFCS_PUSHED > 0 then
        State := State or DFCS_PUSHED;
    end;
    ChangeCloseState(State);
  end;
end;

procedure TJvBalloonWindowEx.WMNCHitTest(var Msg: TWMNCHitTest);
begin
  Msg.Result := HTCLIENT;
end;

initialization
  {$IFDEF UNITVERSIONING}
  RegisterUnitVersion(HInstance, UnitVersioning);
  {$ENDIF UNITVERSIONING}

finalization
  FreeAndNil(GGlobalCtrl);
  {$IFDEF UNITVERSIONING}
  UnregisterUnitVersion(HInstance);
  {$ENDIF UNITVERSIONING}

end.