elpspanl.pas

动态提示控件

      Params := DT_PATH_ELLIPSIS
    else
      Params := DT_END_ELLIPSIS;
    // Tell it to Modify the PChar, and do not draw to the canvas
    Params := Params + DT_MODIFYSTRING + DT_CALCRECT;
    // Ellipsify the string based on availble space to draw in
    DrawTextEx(Canvas.Handle, TempPChar, -1, TempRect, Params, nil);
    // Copy the modified PChar into the result
    Result := StrPas(TempPChar);
  finally
    // Free Memory from PChar
    FreeMem(TempPChar, Length(Text)+1);
  end;
{$ELSE}
  procedure CutFirstDirectory(var S: string);
  var
    Root: Boolean;
    P: Integer;
  begin
    if S = '' then exit;
    if S = '\' then
      S := ''
    else begin
      if S[1] = '\' then begin
        Root := True;
        Delete(S, 1, 1);
      end else
        Root := False;
      if S[1] = '.' then
        Delete(S, 1, 4);
      P := Pos('\',S);
      if P <> 0 then begin
        Delete(S, 1, P);
        S := '...\' + S;
      end else
        S := '';
      if Root then
        S := '\' + S;
    end;
  end;

  function MinimizeName(const Filename: string; const Canvas: TCanvas;
                        MaxLen: Integer): string;
  var
    Drive: string;
    Dir: string;
    Name: string;
  begin
    Result := FileName;
    Dir := ExtractFilePath(Result);
    Name := ExtractFileName(Result);

    if (Length(Dir) >= 2) and (Dir[2] = ':') then begin
      Drive := Copy(Dir, 1, 2);
      Delete(Dir, 1, 2);
    end else
      Drive := '';
    while ((Dir <> '') or (Drive <> '')) and (Canvas.TextWidth(Result) > MaxLen) do begin
      if Dir = '\...\' then begin
        Drive := '';
        Dir := '...\';
      end else if Dir = '' then
        Drive := ''
      else
        CutFirstDirectory(Dir);
      Result := Drive + Dir + Name;
    end;
  end;
var
  Temp: string;
  AvgChar: integer;
  TLen,
  Index: integer;
  Metrics: TTextMetric;
begin
  try
    if AsPath then begin
      Result := MinimizeName(Text, Canvas, MaxWidth);
    end else begin
      Temp := Text;
      if (Temp <> '') and (Canvas.TextWidth(Temp) > MaxWidth) then begin
        GetTextMetrics(Canvas.Handle, Metrics);
        AvgChar := Metrics.tmAveCharWidth;
        if (AvgChar * 3) < MaxWidth then begin
          Index := (MaxWidth div AvgChar) - 1;
          Temp := Copy(Text, 1, Index);
          if Canvas.TextWidth(Temp + '...') > MaxWidth then begin
            repeat
              dec(Index);
              SetLength(Temp, Index);
            until (Canvas.TextWidth(Temp + '...') < MaxWidth) or (Index < 1);
            { delete chars }
          end else begin
            TLen := Length(Text);
            repeat
              inc(Index);
              Temp := Copy(Text, 1, Index);
            until (Canvas.TextWidth(Temp + '...') > MaxWidth) or (Index >= TLen);
            SetLength(Temp, Index-1);
          end;
          Temp := Temp + '...';
        end else
          Temp := '.';
      end;
      Result := Temp;
    end;
  except
    Result := '';
  end;
{$ENDIF}
end;


constructor TdfsEllipsisPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAutoHintOptions := DEF_AUTOHINTOPTIONS;
  ShowHint := TRUE;
  FIsPath := FALSE;
  FCaption := '';
  FSaveHint := '';
end;

procedure TdfsEllipsisPanel.Loaded;
begin
  inherited Loaded;
  FSaveHint := Hint;
end;

procedure TdfsEllipsisPanel.UpdatePanelText;
begin
  if HandleAllocated then begin
    { Make sure the right font has been selected. }
    Canvas.Font.Assign(Font);
    inherited Caption := EllipsifyText(FIsPath, FCaption, Canvas,
       ClientWidth-(BevelWidth*2)-BorderWidth*2);
    UpdateHintText;
  end;
end;

procedure TdfsEllipsisPanel.UpdateHintText;
  function LastChar(const Str: string): char;
  begin
    if Length(Str) > 0 then
      Result := Str[Length(Str)]
    else
      Result := #0;
  end;
begin
  if ahEnabled in FAutoHintOptions then begin
    if ahOnEllipsis in FAutoHintOptions then begin
      if (Length(inherited Caption) > 2) and
         (Copy(inherited Caption, Length(inherited Caption)-2, 3) = '...') then
        Hint := FCaption
      else
        Hint := FSaveHint;
    end else
      Hint := FCaption;

{.$DEFINE WANT-TO-SEE-A-DELPHI-2-BUG}
{$IFDEF WANT-TO-SEE-A-DELPHI-2-BUG}
    if ahWindowOnly in FAutoHintOptions then begin
(* This code causes internal error c3254!  It is the second part of the "if" statement,
   but only if there is some code inside the begin...end.
                                vvvvvvvvvvvvvvvvvvvvvvvvvvv               *)
      if (Length(Hint) > 0) and (Hint[Length(Hint)] <> '|') then
        Hint := Hint + '|';
    end else begin
      if (Length(Hint) > 0) and (Hint[Length(Hint)] = '|') then
        Hint := Copy(Hint, 1, Length(Hint)-1);
    end;
{$ELSE}
    if ahWindowOnly in FAutoHintOptions then begin
      if LastChar(Hint) <> '|' then
        Hint := Hint + '|';
    end else begin
      if LastChar(Hint) = '|' then
        Hint := Copy(Hint, 1, Length(Hint)-1);
    end;
{$ENDIF}

  end else begin
    Hint := FSaveHint;
  end;
end; { This is where you will see the C3254 error message.  Caused on line 290 }

procedure TdfsEllipsisPanel.SetAutoHintOptions(Val: TAutoHintOptions);
begin
  if FAutoHintOptions <> Val then begin
    FAutoHintOptions := Val;
    UpdateHintText;
  end;
end;

procedure TdfsEllipsisPanel.SetIsPath(Val: boolean);
begin
  if Val = FIsPath then exit;
  FIsPath := Val;
  UpdatePanelText;
end;

procedure TdfsEllipsisPanel.SetCaption(const Val: string);
begin
  if Val = FCaption then exit;
  FCaption := Val;
  UpdatePanelText;
end;

function TdfsEllipsisPanel.GetCaption: string;
begin
  Result := FCaption;
end;

procedure TdfsEllipsisPanel.WMSize(var Msg: TWMSize);
begin
  inherited;
  UpdatePanelText;
end;

procedure TdfsEllipsisPanel.CMFontChanged(var Msg: TMessage);
begin
  inherited;
  Refresh;
  UpdatePanelText;
end;

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

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

end.