graphics.pas

这是不可多得的源代码

function TFont.GetName: TFontName;
begin
  Result := FResource^.Font.Name;
end;

procedure TFont.SetName(const Value: TFontName);
var
  FontData: TFontData;
begin
  if Value <> '' then
  begin
    GetData(FontData);
    FillChar(FontData.Name, SizeOf(FontData.Name), 0);
    FontData.Name := Value;
    SetData(FontData);
  end;
end;

function TFont.GetSize: Integer;
begin
  Result := -MulDiv(Height, 72, FPixelsPerInch);
end;

procedure TFont.SetSize(Value: Integer);
begin
  Height := -MulDiv(Value, FPixelsPerInch, 72);
end;

function TFont.GetStyle: TFontStyles;
begin
  Result := FResource^.Font.Style;
end;

procedure TFont.SetStyle(Value: TFontStyles);
var
  FontData: TFontData;
begin
  GetData(FontData);
  FontData.Style := Value;
  SetData(FontData);
end;

function TFont.GetPitch: TFontPitch;
begin
  Result := FResource^.Font.Pitch;
end;

procedure TFont.SetPitch(Value: TFontPitch);
var
  FontData: TFontData;
begin
  GetData(FontData);
  FontData.Pitch := Value;
  SetData(FontData);
end;

function TFont.GetCharset: TFontCharset;
begin
  Result := FResource^.Font.Charset;
end;

procedure TFont.SetCharset(Value: TFontCharset);
var
  FontData: TFontData;
begin
  GetData(FontData);
  FontData.Charset := Value;
  SetData(FontData);
end;

{ TPen }

const
  DefPenData: TPenData = (
    Handle: 0;
    Color: clBlack;
    Width: 1;
    Style: psSolid);

constructor TPen.Create;
begin
  FResource := PenManager.AllocResource(DefPenData);
  FMode := pmCopy;
end;

destructor TPen.Destroy;
begin
  PenManager.FreeResource(FResource);
end;

procedure TPen.Assign(Source: TPersistent);
begin
  if Source is TPen then
  begin
    Lock;
    try
      TPen(Source).Lock;
      try
        PenManager.AssignResource(Self, TPen(Source).FResource);
        SetMode(TPen(Source).FMode);
      finally
        TPen(Source).Unlock;
      end;
    finally
      Unlock;
    end;
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TPen.GetData(var PenData: TPenData);
begin
  PenData := FResource^.Pen;
  PenData.Handle := 0;
end;

procedure TPen.SetData(const PenData: TPenData);
begin
  Lock;
  try
    PenManager.ChangeResource(Self, PenData);
  finally
    Unlock;
  end;
end;

function TPen.GetColor: TColor;
begin
  Result := FResource^.Pen.Color;
end;

procedure TPen.SetColor(Value: TColor);
var
  PenData: TPenData;
begin
  GetData(PenData);
  PenData.Color := Value;
  SetData(PenData);
end;

function TPen.GetHandle: HPen;
const
  PenStyles: array[TPenStyle] of Word =
    (PS_SOLID, PS_DASH, PS_DOT, PS_DASHDOT, PS_DASHDOTDOT, PS_NULL,
     PS_INSIDEFRAME);
var
  LogPen: TLogPen;
begin
  with FResource^ do
  begin
    if Handle = 0 then
    begin
      PenManager.Lock;
      with LogPen do
      try
        if Handle = 0 then
        begin
          lopnStyle := PenStyles[Pen.Style];
          lopnWidth.X := Pen.Width;
          lopnColor := ColorToRGB(Pen.Color);
          Handle := CreatePenIndirect(LogPen);
        end;
      finally
        PenManager.Unlock;
      end;
    end;
    Result := Handle;
  end;
end;

procedure TPen.SetHandle(Value: HPen);
var
  PenData: TPenData;
begin
  PenData := DefPenData;
  PenData.Handle := Value;
  SetData(PenData);
end;

procedure TPen.SetMode(Value: TPenMode);
begin
  if FMode <> Value then
  begin
    FMode := Value;
    Changed;
  end;
end;

function TPen.GetStyle: TPenStyle;
begin
  Result := FResource^.Pen.Style;
end;

procedure TPen.SetStyle(Value: TPenStyle);
var
  PenData: TPenData;
begin
  GetData(PenData);
  PenData.Style := Value;
  SetData(PenData);
end;

function TPen.GetWidth: Integer;
begin
  Result := FResource^.Pen.Width;
end;

procedure TPen.SetWidth(Value: Integer);
var
  PenData: TPenData;
begin
  if Value >= 0 then
  begin
    GetData(PenData);
    PenData.Width := Value;
    SetData(PenData);
  end;
end;

{ TBrush }

const
  DefBrushData: TBrushData = (
    Handle: 0;
    Color: clWhite;
    Bitmap: nil;
    Style: bsSolid);

constructor TBrush.Create;
begin
  FResource := BrushManager.AllocResource(DefBrushData);
end;

destructor TBrush.Destroy;
begin
  BrushManager.FreeResource(FResource);
end;

procedure TBrush.Assign(Source: TPersistent);
begin
  if Source is TBrush then
  begin
    Lock;
    try
      TBrush(Source).Lock;
      try
        BrushManager.AssignResource(Self, TBrush(Source).FResource);
      finally
        TBrush(Source).Unlock;
      end;
    finally
      Unlock;
    end;
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TBrush.GetData(var BrushData: TBrushData);
begin
  BrushData := FResource^.Brush;
  BrushData.Handle := 0;
  BrushData.Bitmap := nil;
end;

procedure TBrush.SetData(const BrushData: TBrushData);
begin
  Lock;
  try
    BrushManager.ChangeResource(Self, BrushData);
  finally
    Unlock;
  end;
end;

function TBrush.GetBitmap: TBitmap;
begin
  Result := FResource^.Brush.Bitmap;
end;

procedure TBrush.SetBitmap(Value: TBitmap);
var
  BrushData: TBrushData;
begin
  BrushData := DefBrushData;
  BrushData.Bitmap := Value;
  SetData(BrushData);
end;

function TBrush.GetColor: TColor;
begin
  Result := FResource^.Brush.Color;
end;

procedure TBrush.SetColor(Value: TColor);
var
  BrushData: TBrushData;
begin
  GetData(BrushData);
  BrushData.Color := Value;
  if BrushData.Style = bsClear then BrushData.Style := bsSolid;
  SetData(BrushData);
end;

function TBrush.GetHandle: HBrush;
var
  LogBrush: TLogBrush;
begin
  with FResource^ do
  begin
    if Handle = 0 then
    begin
      BrushManager.Lock;
      try
        if Handle = 0 then
        begin
          with LogBrush do
          begin
            if Brush.Bitmap <> nil then
            begin
              lbStyle := BS_PATTERN;
              Brush.Bitmap.HandleType := bmDDB;
              lbHatch := Brush.Bitmap.Handle;
            end else
            begin
              lbHatch := 0;
              case Brush.Style of
                bsSolid: lbStyle := BS_SOLID;
                bsClear: lbStyle := BS_HOLLOW;
              else
                lbStyle := BS_HATCHED;
                lbHatch := Ord(Brush.Style) - Ord(bsHorizontal);
              end;
            end;
            lbColor := ColorToRGB(Brush.Color);
          end;
          Handle := CreateBrushIndirect(LogBrush);
        end;
      finally
        BrushManager.Unlock;
      end;
    end;
    Result := Handle;
  end;
end;

procedure TBrush.SetHandle(Value: HBrush);
var
  BrushData: TBrushData;
begin
  BrushData := DefBrushData;
  BrushData.Handle := Value;
  SetData(BrushData);
end;

function TBrush.GetStyle: TBrushStyle;
begin
  Result := FResource^.Brush.Style;
end;

procedure TBrush.SetStyle(Value: TBrushStyle);
var
  BrushData: TBrushData;
begin
  GetData(BrushData);
  BrushData.Style := Value;
  if BrushData.Style = bsClear then BrushData.Color := clWhite;
  SetData(BrushData);
end;

{ TFontRecall }

constructor TFontRecall.Create(AFont: TFont);
begin
  inherited Create(TFont.Create, AFont);
end;

{ TPenRecall }

constructor TPenRecall.Create(APen: TPen);
begin
  inherited Create(TPen.Create, APen);
end;

{ TBrushRecall }

constructor TBrushRecall.Create(ABrush: TBrush);
begin
  inherited Create(TBrush.Create, ABrush);
end;

{ TCanvas }

constructor TCanvas.Create;
begin
  inherited Create;
  InitializeCriticalSection(FLock);
  FFont := TFont.Create;
  FFont.OnChange := FontChanged;
  FFont.OwnerCriticalSection := @FLock;