dfsstatusbar.pas

动态提示控件

      if Message.wParam = 0 then
        MayNeedRefresh := TRUE;
      // Won't work in some situations if we call it directly.
      PostMessage(Handle, WM_REFRESHLOCKINDICATORS, 0, 0);
    end;
  end;
  Result := FALSE;
end;

procedure TdfsStatusBar.WMRefreshLockIndicators(var Msg: TMessage);
var
  x: integer;
begin
  Panels.BeginUpdate;
  try
    for x := 0 to Panels.Count-1 do
      if Panels[x].PanelType in [sptCapsLock, sptNumLock, sptScrollLock] then
        InvalidatePanel(Panels[x].Index);
  finally
    Panels.EndUpdate;
  end;
end;

procedure TdfsStatusBar.CMFontChanged(var Msg: TMessage);
var
  x: integer;
begin
  inherited;

  UpdateExtentFont;

  if Panels = NIL then exit;

  Panels.BeginUpdate;
  try
    for x := 0 to Panels.Count-1 do
      if Panels[x].AutoFit then
        Panels[x].UpdateAutoFitWidth;
  finally
    Panels.EndUpdate;
  end;
end;


procedure TdfsStatusBar.SetOnDrawPanel(const Value: TdfsDrawPanelEvent);
begin
  inherited OnDrawPanel := TDrawPanelEvent(Value);
end;

function TdfsStatusBar.GetOnDrawPanel: TdfsDrawPanelEvent;
begin
  TDrawPanelEvent(Result) := inherited OnDrawPanel;
end;

function TdfsStatusBar.GetVersion: string;
begin
  Result := DFS_COMPONENT_VERSION;
end;

procedure TdfsStatusBar.SetVersion(const Val: string);
begin
  { empty write method, just needed to get it to show up in Object Inspector }
end;


procedure TdfsStatusBar.CMEnabledChanged(var Msg: TMessage);
var
  x: integer;
begin
  inherited;
  Invalidate;
  for x := 0 to Panels.Count-1 do
    Panels[x].EnabledChanged;
end;

procedure TdfsStatusBar.CMHintShow(var Msg: TMessage);
  function FindClosestBefore(x: integer): TdfsStatusPanel;
  var
    y: integer;
  begin
    Result := NIL;
    for y := 0 to Panels.Count-1 do
    begin
      if GetPanelRect(y).Left < x then
        Result := Panels[y]
      else
        break;
    end;
(*  If I do it this way, it screws up.  Optimizaer bug, maybe?
    for y := Panels.Count-1 downto 0 do
    begin
      if GetPanelRect(y).Left < x then
      begin
        Result := Panels[y];
        break;
      end;
    end;*)
  end;

  function FindClosestAfter(x: integer): TdfsStatusPanel;
  var
    y: integer;
  begin
    Result := NIL;
    for y := 0 to Panels.Count-1 do
    begin
      if GetPanelRect(y).Right > x then
      begin
        Result := Panels[y];
        break;
      end;
    end;
  end;
var
  x: integer;
  Panel: TdfsStatusPanel;
  R: TRect;
begin
  inherited;

  with TCMHintShow(Msg) do
  begin
    begin
      Panel := NIL;
      for x := 0 to Panels.Count-1 do
      begin
        if PtInRect(GetPanelRect(x), HintInfo.CursorPos) then
        begin
          Panel := Panels[x];
          break;
        end;
      end;

      if (Panel = NIL) or (Panel.Hint = '') then
      begin
        // Hit a border, or a panel without a hint.  What we have to do here is
        // tell the hint info how big of a rectangle the hint applies to.  So,
        // we must find the first panel before this point with a hint, and the
        // first panel after this point with a hint and set CursorRect equal to
        // the area between those two panels.  CursorRect already has the area
        // of the status bar, so if we don't find a panel, it's ok.

        // Find first valid panel before hint position and set CursorRect.Left
        Panel := FindClosestBefore(HintInfo.CursorPos.x);
        while (Panel <> NIL) do
        begin
          R := GetPanelRect(Panel.Index);
          if Panel.Hint <> '' then
          begin
            HintInfo.CursorRect.Left := R.Right;
            Panel := NIL;
          end else
            Panel := FindClosestBefore(R.Left);
        end;

        // Find first valid panel after hint position and set CursorRect.Right
        Panel := FindClosestAfter(HintInfo.CursorPos.x);
        while (Panel <> NIL) do
        begin
          R := GetPanelRect(Panel.Index);
          if Panel.Hint <> '' then
          begin
            HintInfo.CursorRect.Right := R.Left;
            Panel := NIL;
          end else
            Panel := FindClosestAfter(R.Right);
        end;
      end else begin
        // Give it the hint of the panel
        HintInfo.HintStr := Panel.Hint;
        // Tell the hint mechanism that it needs to check the hint when the
        // cursor leaves the panel rectangle.
        HintInfo.CursorRect := GetPanelRect(Panel.Index);
      end;
    end;
  end;
end;

procedure TdfsStatusBar.DeregisterMainWinHook(Client: TdfsStatusPanel);
begin
  FMainWinHookClients.Remove(Client);
  Assert(FMainWinHookClients.Count >= 0, 'Unbalanced MainWinHook registrations');
  if FMainWinHookClients.Count < 1 then
    Application.UnhookMainWindow(AppWinHook);
end;

procedure TdfsStatusBar.RegisterMainWinHook(Client: TdfsStatusPanel);
begin
  FMainWinHookClients.Add(Client);
  if FMainWinHookClients.Count = 1 then
    Application.HookMainWindow(AppWinHook);
end;



procedure TdfsStatusBar.Loaded;
var
  x: integer;
begin
  inherited Loaded;

  UpdateExtentFont;

  for x := 0 to Panels.Count-1 do
    if Panels[x].AutoFit then
      Panels[x].UpdateAutoFitWidth;
end;

procedure TdfsStatusBar.CreateWnd;
var
  x: integer;
begin
  inherited CreateWnd;

  if not (csLoading in ComponentState) then
  begin
    UpdateExtentFont;

    for x := 0 to Panels.Count-1 do
      if Panels[x].AutoFit then
        Panels[x].UpdateAutoFitWidth;
  end;

  if FDLLClientCount > 0 then
    FKeyHookMsg := DLLRegisterKeyboardHook(Handle);
end;

procedure TdfsStatusBar.WMDestroy(var Msg: TWMDestroy);
begin
  if FUseMonitorDLL and (FDLLClientCount > 0) then
    DLLDeregisterKeyboardHook(Handle);

  inherited;
end;


function TdfsStatusBar.TextExtent(const Text: string): TSize;
begin
  if not GetTextExtentPoint32(FExtentCanvas, PChar(Text), Length(Text),
     Result) then
  begin
    Result.cx := -1;
    Result.cy := -1;
  end;
end;

procedure TdfsStatusBar.UpdateExtentFont;
begin
  if FExtentFont <> 0 then
  begin
    SelectObject(FExtentCanvas, FExtentFontOld);
    DeleteObject(FExtentFont);
  end;

  // In D4, the font handle might be different than what TFont describes!
  FExtentFont := CopyHFont(Font.Handle);
  FExtentFontOld := SelectObject(FExtentCanvas, FExtentFont);
end;

procedure TdfsStatusBar.SetUseMonitorDLL(const Value: boolean);
begin
  if FUseMonitorDLL <> Value then
  begin
    FUseMonitorDLL := Value;
    UpdateKeyboardHooks;
    if FUseMonitorDLL and (not DFSKbDLL_Loaded) {and
       not (csDesigning in ComponentState)} then
    begin
      UseMonitorDLL := FALSE;
      if csDesigning in ComponentState then
        raise Exception.Create('Could not load ' + DFSKbDLLName);
    end;    
  end;
end;

procedure TdfsStatusBar.UpdateKeyboardHooks;
var
  x: integer;
begin
  for x := 0 to Panels.Count-1 do
    Panels[x].UpdateKeyboardHook;
end;


procedure TdfsStatusBar.DeregisterSystemHook;
begin
  dec(FDLLClientCount);
  if FDLLClientCount < 1 then
  begin
    if DFSKbDLL_Loaded and HandleAllocated then
      DLLDeregisterKeyboardHook(Handle);
    FDLLClientCount := 0;
    if DFSKbDLL_Loaded then
      UnloadDFSKbDLL;
  end;
end;

procedure TdfsStatusBar.RegisterSystemHook;
begin
  inc(FDLLClientCount);
  if (FDLLClientCount = 1) {and not (csDesigning in ComponentState)} then
  begin
    if not DFSKbDLL_Loaded then
      IniTdfsKbDLL;
    if HandleAllocated and DFSKbDLL_Loaded then
      FKeyHookMsg := DLLRegisterKeyboardHook(Handle);
  end;
end;

procedure TdfsStatusBar.WndProc(var Msg: TMessage);
  function VKToPanelType(VKCode: byte): TdfsStatusPanelType;
  begin
    case VKCode of
      VK_NUMLOCK: Result := sptNumLock;
      VK_SCROLL:  Result := sptScrollLock;
    else
      Result := sptCapsLock;
    end;
  end;
var
  x: integer;
begin
  if Msg.Msg = FKeyHookMsg then
  begin
    for x := 0 to Panels.Count-1 do
      if VKToPanelType(Msg.wParam) = Panels[x].PanelType then
      begin
        Panels[x].FKeyOn := Odd(Msg.lParam);
        Panels[x].Invalidate;
      end;
  end else
    inherited WndProc(Msg);
end;

procedure TdfsStatusBar.Click;
var
  x: integer;
  CursorPos: TPoint;
begin
  GetCursorPos(CursorPos);
  CursorPos := ScreenToClient(CursorPos);
  for x := 0 to Panels.Count-1 do
  begin
    if PtInRect(GetPanelRect(x), CursorPos) then
    begin
      Panels[x].Click;
      break;
    end;
  end;

  inherited Click;
end;

procedure TdfsStatusBar.WMPaint(var Msg: TWMPaint);
  procedure DrawSizeGrip(R: TRect);
  begin
    OffsetRect(R, -1, -1);
    with Canvas do
    begin
      Brush.Color := Color;
      Pen.Width := 1;
      FillRect(R);
      Pen.Color := clBtnHighlight;
      MoveTo(R.Right - 2, R.Bottom);
      LineTo(R.Right, R.Bottom - 2);
      MoveTo(R.Right - 13, R.Bottom);
      LineTo(R.Right, R.Bottom - 13);
      MoveTo(R.Right - 9, R.Bottom);
      LineTo(R.Right, R.Bottom - 9);
      MoveTo(R.Right - 5, R.Bottom);
      LineTo(R.Right, R.Bottom - 5);
      MoveTo(R.Right - 1, R.Bottom);
      LineTo(R.Right, R.Bottom);

      Pen.Color := clBtnShadow;
      MoveTo(R.Right - 11, R.Bottom);
      LineTo(R.Right, R.Bottom - 11);
      MoveTo(R.Right - 7, R.Bottom);
      LineTo(R.Right, R.Bottom - 7);
      MoveTo(R.Right - 3, R.Bottom);
      LineTo(R.Right, R.Bottom - 3);

      Brush.Color := clBtnFace;
      Pen.Color := clBtnShadow;
      MoveTo(R.Left, R.Top);
      LineTo(R.Right, R.Top);
    end;
  end;
var
  R: TRect;
begin
  inherited;
  if Color <> clBtnFace then
  begin
    R := ClientRect;
    R.Left := R.Right - 15;
    Inc(R.Top, 3);
    dec(R.Bottom);
    DrawSizeGrip(R);
  end;
end;

{$IFDEF DFS_COMPILER_4_UP}
function TdfsStatusBar.ExecuteAction(Action: TBasicAction): Boolean;
begin
//  outputdebugstring(Pchar(panels[0].ftext));
  Result := inherited ExecuteAction(Action);
//  outputdebugstring(Pchar(panels[0].ftext));
  Invalidate;
//  outputdebugstring(Pchar(panels[0].ftext));
end;
{$ENDIF}


initialization
  {$IFDEF DFS_DEBUG}
  DFSDebug.Log('dfsStatusBar: init begin', TRUE);
  {$ENDIF}
  MayNeedRefresh := FALSE;
  KeyboardHookHandle := 0;
  KeyHookClients := TList.Create;
  RegisteredTimers := 0;
  {$IFDEF DFS_DEBUG}
  DFSDebug.Log('dfsStatusBar: init end.', TRUE);
  {$ENDIF}

finalization

  {$IFDEF DFS_DEBUG}
  DFSDebug.Log('dfsStatusBar: finalization begin.', TRUE);
  {$ENDIF}
  // remove hook just in case it somehow got left installed
  if KeyboardHookHandle <> 0 then
  begin
    UnhookWindowsHookEx(KeyboardHookHandle);
    KeyboardHookHandle := 0;
    Assert(FALSE, 'TdfsStatusBar: Keyboard hook still installed');
  end;

  Assert(RegisteredTimers = 0, 'TdfsStatusBar: Unbalanced timer registrations');

  KeyHookClients.Free