dfsstatusbar.pas

动态提示控件

var
  KeyboardHookHandle: HHOOK;
  KeyHookClients: TList;
  RegisteredTimers: integer;
  MayNeedRefresh: boolean;

// Keyboard hook callback
function KeyboardHookCallBack(Code: integer; KeyCode: WPARAM;
   KeyInfo: LPARAM): LRESULT; stdcall;
var
  x: integer;
begin
  if Code >= 0 then
  begin
    if MayNeedRefresh then
    begin
      for x := 0 to KeyHookClients.Count-1 do
        TdfsStatusPanel(KeyHookClients[x]).Invalidate;
      MayNeedRefresh := FALSE;
    end else
    // Is it one of the indicator keys, and is it not a repeat
    if ((KeyCode = VK_CAPITAL) or (KeyCode = VK_NUMLOCK) or
       (KeyCode = VK_SCROLL)) and
       // This checks to see if the key is being pressed (bit 31) and if it was
       // up before (bit 30).  We don't care about key releases or keys that
       // were already down.  That just makes us flicker...
       (((KeyInfo SHR 31) and 1) = 0) and (((KeyInfo SHR 30) and 1) = 0) then
    begin
      for x := 0 to KeyHookClients.Count-1 do
      begin
        case TdfsStatusPanel(KeyHookClients[x]).PanelType of
          sptCapsLock:
            begin
              if KeyCode = VK_CAPITAL then
                TdfsStatusPanel(KeyHookClients[x]).Invalidate;
            end;
          sptNumLock:
            begin
              if KeyCode = VK_NUMLOCK then
                TdfsStatusPanel(KeyHookClients[x]).Invalidate;
            end;
          sptScrollLock:
            begin
              if KeyCode = VK_SCROLL then
                TdfsStatusPanel(KeyHookClients[x]).Invalidate;
            end;
        end;
      end;
    end;
  end;
  Result := CallNextHookEx(KeyboardHookHandle, Code, KeyCode, KeyInfo);
end;

// Utility routins for installing the windows hook for keypresses
procedure RegisterTaskKeyboardHook(Client: TdfsStatusPanel);
begin
  if KeyboardHookHandle = 0 then
    KeyboardHookHandle := SetWindowsHookEx(WH_KEYBOARD, KeyboardHookCallBack,
       0, GetCurrentThreadID);

  KeyHookClients.Add(Client);
end;

procedure DeregisterTaskKeyboardHook(Client: TdfsStatusPanel);
begin
  KeyHookClients.Remove(Client);
  if KeyHookClients.Count < 1 then
  begin
    UnhookWindowsHookEx(KeyboardHookHandle);
    KeyboardHookHandle := 0;
  end;
end;

// Utility function for making a copy of a font handle
function CopyHFont(Font: HFONT): HFONT;
var
  LF: TLogFont;
begin
  if Font <> 0 then
  begin
    GetObject(Font, SizeOf(LF), @LF);
    Result := CreateFontIndirect(LF);
  end else
    Result := 0;
end;


{ TdfsGaugeAttrs }

procedure TdfsGaugeAttrs.Assign(Source: TPersistent);
var
  SrcAttrs: TdfsGaugeAttrs absolute Source;
begin
  if Source is TdfsGaugeAttrs then
  begin
    FOwner := SrcAttrs.Owner;
    Position := SrcAttrs.Position;
    Style := SrcAttrs.Style;
  end else
    inherited Assign(Source);
end;

constructor TdfsGaugeAttrs.Create(AOwner: TdfsStatusPanel);
begin
  inherited Create;
  FOwner := AOwner;
  FStyle := gsPercent;
  FPosition := 0;
  FSpeed := 4;
  FColor := clHighlight;
  FTextColor := clHighlightText;
end;

procedure TdfsGaugeAttrs.SetColor(const Value: TColor);
begin
  if FColor <> Value then
  begin
    FColor := Value;
    FOwner.FGaugeBitmap.Free;
    FOwner.FGaugeBitmap := NIL;
    FOwner.Invalidate;
  end;
end;

procedure TdfsGaugeAttrs.SetPosition(const Value: TPercent);
begin
  if FPosition <> Value then
  begin
    FPosition := Value;
    FOwner.Invalidate;
  end;
end;

procedure TdfsGaugeAttrs.SetSpeed(const Value: integer);
begin
  if (FSpeed <> Value) and (FSpeed > 0) then
    FSpeed := Value;

  if Owner.FGaugeDirection < 0 then
    Owner.FGaugeDirection := -FSpeed
  else
    Owner.FGaugeDirection := FSpeed;
end;

procedure TdfsGaugeAttrs.SetStyle(const Value: TdfsGaugeStyle);
begin
  if FStyle <> Value then
  begin
    if (Owner.PanelType = sptGauge) and (FStyle in IndeterminateGuages) and
       Owner.Enabled then
      TdfsStatusPanels(Owner.Collection).DeregisterTimer(Owner);
    FStyle := Value;
    FOwner.Invalidate;
    if (Owner.PanelType = sptGauge) and (FStyle in IndeterminateGuages) and
       Owner.Enabled then
      TdfsStatusPanels(Owner.Collection).RegisterTimer(Owner);
  end;
end;


procedure TdfsGaugeAttrs.SetTextColor(const Value: TColor);
begin
  if Value <> FTextColor then
  begin
    FTextColor := Value;
    Owner.Invalidate;
  end;
end;

{ TdfsStatusPanel }

procedure TdfsStatusPanel.Assign(Source: TPersistent);
var
  SrcPanel: TdfsStatusPanel absolute Source;
begin
  if Source is TdfsStatusPanel then
  begin
{    if LinkedPanel <> NIL then
      LinkedPanel.Free;
    LinkedPanel := SrcPanel.FLinkedPanel;}

    GaugeAttrs.Assign(SrcPanel.GaugeAttrs);
    Alignment := SrcPanel.Alignment;
    Bevel := SrcPanel.Bevel;
{$IFDEF DFS_COMPILER_4_UP}
    BiDiMode := SrcPanel.BiDiMode;
    ParentBiDiMode := SrcPanel.ParentBiDiMode;
{$ENDIF}
    Glyph.Assign(SrcPanel.Glyph);
    Text := SrcPanel.Text;
    DateFormat := SrcPanel.DateFormat;
    TimeFormat := SrcPanel.TimeFormat;
    Enabled := SrcPanel.Enabled;
    Width := SrcPanel.Width;
    AutoFit := SrcPanel.AutoFit;
    Hint := SrcPanel.Hint;

    OnDrawPanel := SrcPanel.OnDrawPanel;
    OnHintText := SrcPanel.OnHintText;

    // Do last!
    PanelType := SrcPanel.PanelType;
  end else
    inherited Assign(Source);
end;

constructor TdfsStatusPanel.Create(AOwner: TCollection);
begin
  inherited Create(AOwner);

  if AOwner is TdfsStatusPanels then
  begin
    TdfsStatusPanels(AOwner).FLinkedPanels.Add;
    LinkedPanel.Style := psOwnerDraw;
  end else
    raise Exception.Create('TdfsStatusPanel owner must be TdfsStatusPanesls');
  FKeyOn := FALSE;
  FGaugeLastPos := 0;
  FGaugeDirection := 1;
  FPanelType := sptNormal;
  FAutoFit := FALSE;
  FEnabled := TRUE;
  FTimeFormat := '';
  FDateFormat := '';
  FGaugeAttrs := TdfsGaugeAttrs.Create(Self);
  FGlyph := TPicture.Create;
  FGlyph.OnChange := GlyphChanged;
end;


destructor TdfsStatusPanel.Destroy;
begin
  if Enabled then
    case FPanelType of
      sptCapsLock, sptNumLock, sptScrollLock:
        begin
          if StatusBar.UseMonitorDLL then
            StatusBar.DeregisterSystemHook
          else begin
            DeregisterTaskKeyboardHook(Self);
            StatusBar.DeregisterMainWinHook(Self);
          end;
        end;
      sptDate, sptTime, sptDateTime, sptTimeDate:
        TdfsStatusPanels(Collection).DeregisterTimer(Self);
      sptGauge:
        if GaugeAttrs.Style in IndeterminateGuages then
          TdfsStatusPanels(Collection).DeregisterTimer(Self);
    end;

  FGlyph.Free;
  FGaugeAttrs.Free;
  FGaugeBitmap.Free;
  TdfsStatusPanels(Collection).FLinkedPanels[Index].Free;

  inherited Destroy;
end;


function TdfsStatusPanel.GetAlignment: TAlignment;
begin
  Result := LinkedPanel.Alignment
end;

function TdfsStatusPanel.GetBevel: TStatusPanelBevel;
begin
  Result := LinkedPanel.Bevel
end;

{$IFDEF DFS_COMPILER_4_UP}
function TdfsStatusPanel.GetBiDiMode: TBiDiMode;
begin
  Result := LinkedPanel.BiDiMode
end;

function TdfsStatusPanel.GetParentBiDiMode: Boolean;
begin
  Result := LinkedPanel.ParentBiDiMode
end;
{$ENDIF}

function TdfsStatusPanel.GetStatusBar: TdfsStatusBar;
begin
  Result := TdfsStatusPanels(Collection).FStatusBar;
end;

function TdfsStatusPanel.GetWidth: Integer;
begin
  Result := LinkedPanel.Width
end;

procedure TdfsStatusPanel.Invalidate;
begin
  if StatusBar <> NIL then
    StatusBar.InvalidatePanel(Index);
end;

{$IFDEF DFS_COMPILER_4_UP}
function TdfsStatusPanel.IsBiDiModeStored: Boolean;
begin
  Result := not ParentBiDiMode;
end;
{$ENDIF}

procedure TdfsStatusPanel.Redraw(Canvas: TCanvas; Dest: TRect);
var
  Buffer: TBitmap;
  R: TRect;
begin
  if (not StatusBar.HandleAllocated) or (IsRectEmpty(Dest))then
    exit;

  InflateRect(Dest, -1, -1); // Don't paint over the shadows.

  R := Dest;
  OffsetRect(R, -Dest.Left, -Dest.Top);
  Buffer := TBitmap.Create;
  try
    Buffer.Width := R.Right;
    Buffer.Height := R.Bottom;

    Buffer.Canvas.Font.Handle := CopyHFont(Canvas.Font.Handle);
    Buffer.Canvas.Brush.Color := StatusBar.Color;
    Buffer.Canvas.FillRect(R);

    if BorderWidth > 0 then
      InflateRect(R, -BorderWidth, -BorderWidth);

    if Enabled then
    begin
      case PanelType of
        sptCapsLock, sptNumLock, sptScrollLock:
          DrawKeyLock(Buffer.Canvas, R);

        sptNormal, sptDate, sptTime, sptDateTime, sptTimeDate, sptEllipsisText,
        sptEllipsisPath, sptOwnerDraw:
          begin
            if (PanelType = sptOwnerDraw) and
               not (csDesigning in StatusBar.ComponentState) then
              exit;
            DrawTextBased(Buffer.Canvas, R);
          end;

          sptGlyph:
            DrawGlyph(Buffer.Canvas, R);

          sptGauge:
            if GaugeAttrs.Style in IndeterminateGuages then
              DrawIndeterminateGauge(Buffer.Canvas, R)
            else
              DrawGauge(Buffer.Canvas, R);
      end;
    end;

    Canvas.Draw(Dest.Left, Dest.Top, Buffer);
  finally
    Buffer.Free;
  end;
end;

procedure TdfsStatusPanel.DrawGauge(Canvas: TCanvas; R: TRect);
var
  R1, R2: TRect;
  R1Rgn, R2Rgn, OldRgn: HRGN;
  Pct: string;
  OldColor: TColorRef;
  DTFlags: UINT;
begin
  R1 := R;
  R2 := R;
  R1.Right := R1.Left + MulDiv(R.Right-R.Left, FGaugeAttrs.Position, 100);
  with Canvas do
  begin
    Brush.Color := GaugeAttrs.Color;
    FillRect(R1);
    R2.Left := R1.Right;
    Brush.Color := StatusBar.Color;
    FillRect(R2);

    { This could probably be simplified with ExtTextOut and SetTextAlign now
      things are being properly buffered off-screen.  But, this is working and
      doesn't seem slow, so....  "If it ain't broke, don't fix it."  :)        }
    if Text = '' then
      Pct := IntToStr(FGaugeAttrs.Position) + '%'
    else
      Pct := Text; // Use what's in the panel's text property.
    // don't change background color behind text!
    Brush.Style := bsClear;
    OldColor := GetTextColor(Handle);

    R1Rgn := CreateRectRgnIndirect(R1);
    R2Rgn := CreateRectRgnIndirect(R2);
    OldRgn := CreateRectRgn(0, 0, 1, 1);
    try
      GetClipRgn(Handle, OldRgn);

      DTFlags := DT_VCENTER or DT_NOPREFIX or DT_SINGLELINE;
      case Alignment of
        taCenter:       DTFlags := DTFlags or DT_CENTER;
        taRightJustify: DTFlags := DTFlags or DT_RIGHT;
      end;
      // Draw the text in the "filled" area with text color
      if (R1Rgn<>0) and (SelectClipRgn(Handle, R1Rgn) <> ERROR) then
        try
          SetTextColor(Handle, ColorToRGB(GaugeAttrs.TextColor));
          DrawText(Handle, PChar(Pct), -1, R, DTFlags);
        finally
          SelectClipRgn(Handle, OldRgn);
        end;

      // Draw the text in the "empty" area with normal color
      if (R2Rgn<>0) and (SelectClipRgn(Handle, R2Rgn) <> ERROR) then
        try
//          SetTextColor(Handle, OldColor);
          SetTextColor(Handle, ColorToRGB(StatusBar.Font.Color));
          DrawText(Handle, PChar(Pct), -1, R, DTFlags);
        finally
          SelectClipRgn(Handle, OldRgn);
        end;
    finally
      SetTextColor(Handle, OldColor);
      DeleteObject(R1Rgn);
      DeleteObject(R2Rgn);
      DeleteObject(OldRgn);
    end;
  end;
end;

procedure TdfsStatusPanel.DrawGlyph(Canvas: TCanvas; R: TRect);
const
  TEXT_SPACE = 2;
var
  TW: integer;
  GR: TRect;
begin
  GR := R;
  if Text <> '' then
    TW := Canvas.TextWidth(Text) + TEXT_SPACE
  else
    TW := 0;
  if (Alignment = taCenter) or AutoFit then
     with GR do
       Left := Left + ((Right - Left - Glyph.Width - TW) div 2)
  else if Alignment = taRightJustify then
    GR.Left := GR.Right - Glyph.Width;