graphics.pas

这是不可多得的源代码

  end;
end;

procedure TResourceManager.AssignResource(GraphicsObject: TGraphicsObject;
  AResource: PResource);
var
  P: PResource;
begin
  Lock;
  try
    P := GraphicsObject.FResource;
    if P <> AResource then
    begin
      Inc(AResource^.RefCount);
      GraphicsObject.FResource := AResource;
      GraphicsObject.Changed;
      FreeResource(P);
    end;
  finally
    Unlock;
  end;
end;

var
  CanvasList: TThreadList;

procedure PaletteChanged;

  procedure ClearColor(ResMan: TResourceManager);
  var
    Resource: PResource;
  begin
    ResMan.Lock;
    try
      Resource := ResMan.ResList;
      while Resource <> nil do
      begin
        with Resource^ do
        { Assumes Pen.Color and Brush.Color share the same location }
          if (Handle <> 0) and (Pen.Color < 0) then
          begin
            DeleteObject(Handle);
            Handle := 0;
          end;
        Resource := Resource^.Next;
      end;
    finally
      ResMan.Unlock;
    end;
  end;

var
  I,J: Integer;
begin
  { Called when the system palette has changed (WM_SYSCOLORCHANGE) }
  I := 0;
  with CanvasList.LockList do
  try
    while I < Count do
    begin
      with TCanvas(Items[I]) do
      begin
        Lock;
        Inc(I);
        DeselectHandles;
      end;
    end;
    ClearColor(PenManager);
    ClearColor(BrushManager);
  finally
    for J := 0 to I-1 do  // Only unlock the canvases we actually locked
      TCanvas(Items[J]).Unlock;
    CanvasList.UnlockList;
  end;
end;

{ Color mapping routines }

const
  Colors: array[0..51] of TIdentMapEntry = (
    (Value: clBlack; Name: 'clBlack'),
    (Value: clMaroon; Name: 'clMaroon'),
    (Value: clGreen; Name: 'clGreen'),
    (Value: clOlive; Name: 'clOlive'),
    (Value: clNavy; Name: 'clNavy'),
    (Value: clPurple; Name: 'clPurple'),
    (Value: clTeal; Name: 'clTeal'),
    (Value: clGray; Name: 'clGray'),
    (Value: clSilver; Name: 'clSilver'),
    (Value: clRed; Name: 'clRed'),
    (Value: clLime; Name: 'clLime'),
    (Value: clYellow; Name: 'clYellow'),
    (Value: clBlue; Name: 'clBlue'),
    (Value: clFuchsia; Name: 'clFuchsia'),
    (Value: clAqua; Name: 'clAqua'),
    (Value: clWhite; Name: 'clWhite'),

    (Value: clMoneyGreen; Name: 'clMoneyGreen'),
    (Value: clSkyBlue; Name: 'clSkyBlue'),
    (Value: clCream; Name: 'clCream'),
    (Value: clMedGray; Name: 'clMedGray'),

    (Value: clActiveBorder; Name: 'clActiveBorder'),
    (Value: clActiveCaption; Name: 'clActiveCaption'),
    (Value: clAppWorkSpace; Name: 'clAppWorkSpace'),
    (Value: clBackground; Name: 'clBackground'),
    (Value: clBtnFace; Name: 'clBtnFace'),
    (Value: clBtnHighlight; Name: 'clBtnHighlight'),
    (Value: clBtnShadow; Name: 'clBtnShadow'),
    (Value: clBtnText; Name: 'clBtnText'),
    (Value: clCaptionText; Name: 'clCaptionText'),
    (Value: clDefault; Name: 'clDefault'),
    (Value: clGradientActiveCaption; Name: 'clGradientActiveCaption'),
    (Value: clGradientInactiveCaption; Name: 'clGradientInactiveCaption'),
    (Value: clGrayText; Name: 'clGrayText'),
    (Value: clHighlight; Name: 'clHighlight'),
    (Value: clHighlightText; Name: 'clHighlightText'),
    (Value: clHotLight; Name: 'clHotLight'),
    (Value: clInactiveBorder; Name: 'clInactiveBorder'),
    (Value: clInactiveCaption; Name: 'clInactiveCaption'),
    (Value: clInactiveCaptionText; Name: 'clInactiveCaptionText'),
    (Value: clInfoBk; Name: 'clInfoBk'),
    (Value: clInfoText; Name: 'clInfoText'),
    (Value: clMenu; Name: 'clMenu'),
    (Value: clMenuBar; Name: 'clMenuBar'),
    (Value: clMenuHighlight; Name: 'clMenuHighlight'),
    (Value: clMenuText; Name: 'clMenuText'),
    (Value: clNone; Name: 'clNone'),
    (Value: clScrollBar; Name: 'clScrollBar'),
    (Value: cl3DDkShadow; Name: 'cl3DDkShadow'),
    (Value: cl3DLight; Name: 'cl3DLight'),
    (Value: clWindow; Name: 'clWindow'),
    (Value: clWindowFrame; Name: 'clWindowFrame'),
    (Value: clWindowText; Name: 'clWindowText'));


function ColorToRGB(Color: TColor): Longint;
begin
  if Color < 0 then
    Result := GetSysColor(Color and $000000FF) else
    Result := Color;
end;

function ColorToString(Color: TColor): string;
begin
  if not ColorToIdent(Color, Result) then
    FmtStr(Result, '%s%.8x', [HexDisplayPrefix, Color]);
end;

function StringToColor(const S: string): TColor;
begin
  if not IdentToColor(S, Longint(Result)) then
    Result := TColor(StrToInt(S));
end;

procedure GetColorValues(Proc: TGetStrProc);
var
  I: Integer;
begin
  for I := Low(Colors) to High(Colors) do Proc(Colors[I].Name);
end;

function ColorToIdent(Color: Longint; var Ident: string): Boolean;
begin
  Result := IntToIdent(Color, Ident, Colors);
end;

function IdentToColor(const Ident: string; var Color: Longint): Boolean;
begin
  Result := IdentToInt(Ident, Color, Colors);
end;

{ TGraphicsObject }

procedure TGraphicsObject.Changed;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TGraphicsObject.Lock;
begin
  if Assigned(FOwnerLock) then EnterCriticalSection(FOwnerLock^);
end;

procedure TGraphicsObject.Unlock;
begin
  if Assigned(FOwnerLock) then LeaveCriticalSection(FOwnerLock^);
end;

function TGraphicsObject.HandleAllocated: Boolean;
begin
  Result := (FResource <> nil) and (FResource^.Handle <> 0);
end;

{ TFont }

const
  FontCharsets: array[0..17] of TIdentMapEntry = (
    (Value: 0; Name: 'ANSI_CHARSET'),
    (Value: 1; Name: 'DEFAULT_CHARSET'),
    (Value: 2; Name: 'SYMBOL_CHARSET'),
    (Value: 77; Name: 'MAC_CHARSET'),
    (Value: 128; Name: 'SHIFTJIS_CHARSET'),
    (Value: 129; Name: 'HANGEUL_CHARSET'),
    (Value: 130; Name: 'JOHAB_CHARSET'),
    (Value: 134; Name: 'GB2312_CHARSET'),
    (Value: 136; Name: 'CHINESEBIG5_CHARSET'),
    (Value: 161; Name: 'GREEK_CHARSET'),
    (Value: 162; Name: 'TURKISH_CHARSET'),
    (Value: 177; Name: 'HEBREW_CHARSET'),
    (Value: 178; Name: 'ARABIC_CHARSET'),
    (Value: 186; Name: 'BALTIC_CHARSET'),
    (Value: 204; Name: 'RUSSIAN_CHARSET'),
    (Value: 222; Name: 'THAI_CHARSET'),
    (Value: 238; Name: 'EASTEUROPE_CHARSET'),
    (Value: 255; Name: 'OEM_CHARSET'));

procedure GetCharsetValues(Proc: TGetStrProc);
var
  I: Integer;
begin
  for I := Low(FontCharsets) to High(FontCharsets) do Proc(FontCharsets[I].Name);
end;

function CharsetToIdent(Charset: Longint; var Ident: string): Boolean;
begin
  Result := IntToIdent(Charset, Ident, FontCharsets);
end;

function IdentToCharset(const Ident: string; var Charset: Longint): Boolean;
begin
  Result := IdentToInt(Ident, CharSet, FontCharsets);
end;

function GetFontData(Font: HFont): TFontData;
var
  LogFont: TLogFont;
begin
  Result := DefFontData;
  if Font <> 0 then
  begin
    if GetObject(Font, SizeOf(LogFont), @LogFont) <> 0 then
    with Result, LogFont do
    begin
      Height := lfHeight;
      if lfWeight >= FW_BOLD then
        Include(Style, fsBold);
      if lfItalic = 1 then
        Include(Style, fsItalic);
      if lfUnderline = 1 then
        Include(Style, fsUnderline);
      if lfStrikeOut = 1 then
        Include(Style, fsStrikeOut);
      Charset := TFontCharset(lfCharSet);
      Name := lfFaceName;
      case lfPitchAndFamily and $F of
        VARIABLE_PITCH: Pitch := fpVariable;
        FIXED_PITCH: Pitch := fpFixed;
      else
        Pitch := fpDefault;
      end;
      Handle := Font;
    end;
  end;
end;

constructor TFont.Create;
begin
  DefFontData.Handle := 0;
  FResource := FontManager.AllocResource(DefFontData);
  FColor := clWindowText;
  FPixelsPerInch := ScreenLogPixels;
end;

destructor TFont.Destroy;
begin
  FontManager.FreeResource(FResource);
end;

procedure TFont.Changed;
begin
  inherited Changed;
  if FNotify <> nil then FNotify.Changed;
end;

procedure TFont.Assign(Source: TPersistent);
begin
  if Source is TFont then
  begin
    Lock;
    try
      TFont(Source).Lock;
      try
        FontManager.AssignResource(Self, TFont(Source).FResource);
        Color := TFont(Source).Color;
        if PixelsPerInch <> TFont(Source).PixelsPerInch then
          Size := TFont(Source).Size;
      finally
        TFont(Source).Unlock;
      end;
    finally
      Unlock;
    end;
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TFont.GetData(var FontData: TFontData);
begin
  FontData := FResource^.Font;
  FontData.Handle := 0;
end;

procedure TFont.SetData(const FontData: TFontData);
begin
  Lock;
  try
    FontManager.ChangeResource(Self, FontData);
  finally
    Unlock;
  end;
end;

procedure TFont.SetColor(Value: TColor);
begin
  if FColor <> Value then
  begin
    FColor := Value;
    Changed;
  end;
end;

function TFont.GetHandle: HFont;
var
  LogFont: TLogFont;
begin
  with FResource^ do
  begin
    if Handle = 0 then
    begin
      FontManager.Lock;
      with LogFont do
      try
        if Handle = 0 then
        begin
          lfHeight := Font.Height;
          lfWidth := 0; { have font mapper choose }
          lfEscapement := 0; { only straight fonts }
          lfOrientation := 0; { no rotation }
          if fsBold in Font.Style then
            lfWeight := FW_BOLD
          else
            lfWeight := FW_NORMAL;
          lfItalic := Byte(fsItalic in Font.Style);
          lfUnderline := Byte(fsUnderline in Font.Style);
          lfStrikeOut := Byte(fsStrikeOut in Font.Style);
          lfCharSet := Byte(Font.Charset);
          if AnsiCompareText(Font.Name, 'Default') = 0 then  // do not localize
            StrPCopy(lfFaceName, DefFontData.Name)
          else
            StrPCopy(lfFaceName, Font.Name);
          lfQuality := DEFAULT_QUALITY;
          { Everything else as default }
          lfOutPrecision := OUT_DEFAULT_PRECIS;
          lfClipPrecision := CLIP_DEFAULT_PRECIS;
          case Pitch of
            fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
            fpFixed: lfPitchAndFamily := FIXED_PITCH;
          else
            lfPitchAndFamily := DEFAULT_PITCH;
          end;
          Handle := CreateFontIndirect(LogFont);
        end;
      finally
        FontManager.Unlock;
      end;
    end;
    Result := Handle;
  end;
end;

procedure TFont.SetHandle(Value: HFont);
begin
  SetData(GetFontData(Value));
end;

function TFont.GetHeight: Integer;
begin
  Result := FResource^.Font.Height;
end;

procedure TFont.SetHeight(Value: Integer);
var
  FontData: TFontData;
begin
  GetData(FontData);
  FontData.Height := Value;
  SetData(FontData);
end;