agraphic.pas

来自「delphi编程控件」· PAS 代码 · 共 189 行

unit agraphic;
(*
 COPYRIGHT (c) RSD Software 1997 - 98
 All Rights Reserved.
*)

interface

uses Windows, Graphics, Classes;


function ShadeRect(Ahdc : HDC; ARect : TRect) : Boolean;
function  GetDrawText(ACanvas : TCanvas; ARect : TRect;
      AAlignment : TAlignment; Var AText : String) : Integer;
function GetTextWidth(AFont : TFont; AText : String) : Integer;

function GetFontMetric(AFont : TFont) : TTextMetric;
function GetFontHeight(AFont : TFont) : Integer;
function GetFontWidth(AFont : TFont) : Integer;

implementation
function ShadeRect(Ahdc : HDC; ARect : TRect) : Boolean;
Const
 Bits : Array [0..7] of Word = ($0055, $00AA, $0055, $00AA,
                         $0055, $00AA, $0055, $00AA);
Var
  crHighlightColor, crOldBkColor, crOldTextColor : COLORREF;
  hBrush, hOldBrush : Integer;
  hBitmap, hBrushBitmap, hOldMemBitmap : Integer;
  OldBkMode, nWidth, nHeight : Integer;
  hMemDC : HDC;
  rcRect : TRect;
begin
   SetRect(rcRect, 0, 0, 0, 0);
   // The Width and Height of the target area
   nWidth := ARect.Right - ARect.Left + 1;
   nHeight := ARect.Bottom - ARect.Top + 1;

   // Need a pattern bitmap
   hBrushBitmap := CreateBitmap( 8, 8, 1, 1, @Bits);
   // Need to store the original image
   hBitmap := CreateCompatibleBitmap(Ahdc, nWidth, nHeight);
   // Need a memory DC to work in
   hMemDC := CreateCompatibleDC(Ahdc);
   // Create the pattern brush
   hBrush := CreatePatternBrush( hBrushBitmap );

   // Has anything failed so far? If so, abort!
   if(hBrushBitmap <= 0) Or (hBitmap <= 0)
   Or (hMemDC <= 0) Or (hBrush <= 0) then begin
     if(hBrushBitmap > 0) then DeleteObject(hBrushBitmap);
     if(hBitmap > 0) then DeleteObject(hBitmap);
     if(hMemDC > 0) then DeleteDC(hMemDC);
     if(hBrush > 0) then DeleteObject(hBrush);
     Result := False;
     exit;
   end;

   // Select the bitmap into the memory DC
   hOldMemBitmap := SelectObject(hMemDC, hBitmap);

   // How wide/tall is the original?
   rcRect.Right := nWidth;
   rcRect.Bottom := nHeight;

   // Lay down the pattern in the memory DC
   FillRect(hMemDC, rcRect, hBrush);

   // Fill in the non-color pixels with the original image
   BitBlt(hMemDC, 0, 0, nWidth, nHeight, Ahdc, ARect.Left, ARect.Top, SRCAND);

   // For the "Shutdown" look, use black or gray here instead
   crHighlightColor := GetSysColor(COLOR_HIGHLIGHT);

   // Set the color scheme
   crOldTextColor := SetTextColor(Ahdc, crHighlightColor);
   crOldBkColor := SetBkColor(Ahdc, RGB(0,0,0));
   OldBkMode := GetBkMode(Ahdc);
   SetBkMode(Ahdc, OPAQUE);

   // Select the pattern brush
   hOldBrush := SelectObject(Ahdc, hBrush);
   // Fill in the color pixels, and set the others to black
   FillRect(Ahdc, ARect, hBrush );
   // Fill in the black ones with the original image
   BitBlt(Ahdc, ARect.Left, ARect.Top, nWidth, nHeight,
           hMemDC, 0, 0, SRCPAINT);

   // Restore target DC settings
   SetBkMode(Ahdc, OldBkMode);
   SetBkColor(Ahdc, crOldBkColor);
   SetTextColor(Ahdc, crOldTextColor);

   // Clean up
   SelectObject(hMemDC, hOldMemBitmap);
   DeleteObject(hBitmap);
   DeleteDC(hMemDC);
   DeleteObject(hBrushBitmap);
   SelectObject(Ahdc, hOldBrush);
   DeleteObject(hBrush);

   Result := True;
end;


function  GetDrawText(ACanvas : TCanvas; ARect : TRect;
      AAlignment : TAlignment; Var AText : String) : Integer;
const
  AlignFlags : array [TAlignment] of Integer =
    ( DT_LEFT or DT_WORDBREAK or DT_VCENTER or DT_SINGLELINE or DT_EXPANDTABS or DT_NOPREFIX  Or DT_CALCRECT,
      DT_RIGHT or DT_WORDBREAK or DT_VCENTER or DT_SINGLELINE or DT_EXPANDTABS or DT_NOPREFIX  Or DT_CALCRECT,
      DT_CENTER or DT_WORDBREAK or DT_VCENTER or DT_SINGLELINE or DT_EXPANDTABS or DT_NOPREFIX  Or DT_CALCRECT);
  App = '...';
Var
  St : String;
  AWidth : Integer;
  Ch : Char;

  function GetTextWidth(ASt : String) : Integer;
  Var
    r : TRect;
  begin
    r := ARect;
    DrawText(ACanvas.Handle, PChar(ASt), Length(ASt), r, AlignFlags[AAlignment]);
    Result := r.Right - r.Left;
  end;

begin
  if(AText = '') then begin
    Result := 0;
    exit;
  end;
  Result := GetTextWidth(AText);
  if(Result > (ARect.Right - ARect.Left)) then begin
    St := AText[1];
    AWidth := GetTextWidth(St + App);
    if(AWidth < (ARect.Right - ARect.Left)) then begin
      while(AWidth < (ARect.Right - ARect.Left)) do begin
        Ch := AText[Length(St) + 1];
        AWidth := GetTextWidth(St + Ch + App);
        if(AWidth < (ARect.Right - ARect.Left)) then
          St := St + Ch;
      end;
      St := St + App;
    end;
    AText := St;
  end;
end;

function GetTextWidth(AFont : TFont; AText : String) : Integer;
Var
  r : TRect;
  SaveFont : HFont;
  ADC : HDC;
begin
  SetRect(r, 0, 0, 1000, 100);
  ADC := GetDC(0);
  SaveFont := SelectObject(ADC, AFont.Handle);
  DrawText(ADC, PChar(AText), Length(AText), r,
    DT_LEFT or DT_WORDBREAK or DT_VCENTER or DT_SINGLELINE or DT_EXPANDTABS or DT_NOPREFIX  Or DT_CALCRECT);
  SelectObject(ADC, SaveFont);
  ReleaseDC(0, ADC);
  Result := r.Right - r.Left;
end;

function GetFontMetric(AFont : TFont) : TTextMetric;
var
  DC: HDC;
  SaveFont: HFont;
begin
  DC := GetDC(0);
  SaveFont := SelectObject(DC, AFont.Handle);
  GetTextMetrics(DC, Result);
  SelectObject(DC, SaveFont);
  ReleaseDC(0, DC);
end;

function GetFontHeight(AFont : TFont) : Integer;
begin
  Result := GetFontMetric(AFont).tmHeight;
end;

function GetFontWidth(AFont : TFont) : Integer;
begin
  Result := GetFontMetric(AFont).tmAveCharWidth;
end;

end.