evbgraphics.pas

很好的源代码

  for I := 0 to Count - 1 do begin
    Info := Items[I] as TEvBBitmapFileFormatInfo;
    if SameText(Info.Header,Copy(Header,Info.HeaderOffset + 1,Length(Info.Header))) then begin
      Result := Info.FileFormatClass;
      Description := Info.Description;
      Exit;
    end;
  end;
  Result := nil;
  Description := '';
end;

function TEvBBitmapFileFormatList.GetItem(
  const Index: Integer): TEvBBitmapFileFormatInfo;
begin
  Result := (inherited Items[Index]) as TEvBBitmapFileFormatInfo;
end;

{ TEvBBitmapFileFormat }

constructor TEvBBitmapFileFormat.Create(const ADescription: String;
  const ABitmap: TBitmap);
begin
  inherited Create;
  FDescription := ADescription;
  FBitmap := ABitmap;
  FQuality := MaxCompressionQuality;
end;

function TEvBBitmapFileFormat.CreateGreyscaleBitmapCopy: TBitmap;
var
  Helper: TBitmap;
  FreeHelper: Boolean;
  X, Y: Integer;
  XYZ: PEvBXYZ;
  P: PByte;
begin
  if FBitmapCopy = nil then
    FBitmapCopy := TBitmap.Create;

  if Bitmap.PixelFormat = pf24Bit then begin
    Helper := Bitmap;
    FreeHelper := False;
  end else begin
    Helper := TBitmap.Create;
    Helper.Assign(Bitmap);
    Helper.PixelFormat := pf24Bit;
    FreeHelper := True;
  end;

  try
    FBitmapCopy.PixelFormat := pf8Bit;
    FBitmapCopy.Width := Helper.Width;
    FBitmapCopy.Height := Helper.Height;
    FBitmapCopy.Palette := CreateGreyscalePalette;
    for Y := 0 to Helper.Height - 1 do begin
      XYZ := Helper.ScanLine[Y];
      P := FBitmapCopy.ScanLine[Y];
      for X := 0 to Helper.Width - 1 do begin
        { Create human-vision-correct greyscale value with the formula
           Grey = (Red * 3 + Green * 6 + Blue) div 10 }
        P^ := (XYZ.Z * 3 + XYZ.Y * 6 + XYZ.X) div 10;
        Inc(P);
        Inc(XYZ);
      end;
    end;
  finally
    if FreeHelper then
      Helper.Free;
  end;

  Result := FBitmapCopy;
end;

function TEvBBitmapFileFormat.CreateGreyscalePalette: HPalette;
var
  Pal: TMaxLogPalette;
  I: Integer;
begin
  Pal.palVersion := $300;
  Pal.palNumEntries := 256;
  for I := 0 to 255 do
    with Pal.palPalEntry[I] do begin
      peRed   := I;
      peGreen := I;
      peBlue  := I;
      peFlags := 0;
    end;
  Result := CreatePalette(PLogPalette(@Pal)^);
end;

function TEvBBitmapFileFormat.CreateTrueColorBitmapCopy: TBitmap;
begin
  if FBitmapCopy = nil then
    FBitmapCopy := TBitmap.Create;

  FBitmapCopy.Assign(Bitmap);
  FBitmapCopy.PixelFormat := pf24Bit;

  Result := FBitmapCopy;
end;

destructor TEvBBitmapFileFormat.Destroy;
begin
  FBitmapCopy.Free;
  inherited;
end;

procedure TEvBBitmapFileFormat.InternalError(const Msg: String);
begin
  raise EInvalidGraphicOperation.CreateFmt('Internal error (%s): %s',[ClassName,Msg]);
end;

procedure TEvBBitmapFileFormat.InvalidStream;
begin
  raise EInvalidGraphic.Create(FDescription + ' image is not valid');
end;

function TEvBBitmapFileFormat.IsGreyscalePalette(
  const Palette: HPalette): Boolean;
var
  Entries: array [0..255] of TPaletteEntry;
  I: Integer;
begin
  Result := (GetPaletteEntries(Palette,0,256,Entries) > 0);
  if Result then
    for I := 0 to 255 do
      with Entries[I] do begin
        Result := (peRed = I) and (peGreen = I) and (peBlue = I);
        if not Result then
          Exit;
      end;
end;

procedure TEvBBitmapFileFormat.ReadStream(const Stream: TStream);
begin
  FStream := Stream;
end;

procedure TEvBBitmapFileFormat.WriteStream(const Stream: TStream);
begin
  FStream := Stream;
end;

{ TEvBBitmap }

constructor TEvBBitmap.Create;
begin
  inherited;
  FQuality := MaxCompressionQuality;
end;

class function TEvBBitmap.GetFilterString(
  const Options: TEvBFilterStringOptions): String;
var
  I: Integer;
  Info: TEvBBitmapFileFormatInfo;
  Extensions: String;
begin
  Result := ''; Extensions := '';
  for I := 0 to BitmapFileFormats.Count - 1 do begin
    Info := BitmapFileFormats[I];
    Result := Result + Format('%s (*%s)|*%1:s|',
      [Info.Description,Info.Extension]);
    Extensions := Extensions + '*' + Info.Extension + ';';
  end;
  if fsoAllSupportedFiles in Options then
    Result := Format('All supported files|%s|',
      [Copy(Extensions,1,Length(Extensions) - 1)]) + Result;
  if fsoAllFiles in Options then
    Result := Result + 'All files (*.*)|*.*'
  else
    Result := Copy(Result,1,Length(Result) - 1);
end;

class function TEvBBitmap.GetRegisteredFileFormat(const Index: Integer): TEvBBitmapFileFormatInfo;
begin
  Result := BitmapFileFormats[BitmapFileFormats.Count - Index - 1];
end;

procedure TEvBBitmap.LoadFromFile(const Filename: String);
var
  Extension, Description: String;
  FileFormatClass: TEvBBitmapFileFormatClass;
  FileFormat: TEvBBitmapFileFormat;
  Stream: TStream;
begin
  Extension := ExtractFileExt(Filename);
  FileFormatClass := BitmapFileFormats.FindByExtension(Extension,Description);
  if FileFormatClass = nil then
    inherited
  else begin
    Stream := nil;
    FileFormat := FileFormatClass.Create(Description,Self);
    try
      Stream := TFileStream.Create(Filename,fmOpenRead or fmShareDenyWrite);
      FileFormat.ReadStream(Stream);
    finally
      FileFormat.Free;
      Stream.Free;
    end;
  end;
end;

procedure TEvBBitmap.LoadFromStream(Stream: TStream);
var
  StreamPos: Int64;
  StreamHeader, Description: String;
  FileFormatClass: TEvBBitmapFileFormatClass;
  FileFormat: TEvBBitmapFileFormat;
begin
  StreamPos := Stream.Position;
  SetLength(StreamHeader,8);
  Stream.Read(StreamHeader[1],8);
  Stream.Position := StreamPos;
  FileFormatClass := BitmapFileFormats.FindByHeader(StreamHeader,Description);
  if FileFormatClass = nil then
    inherited
  else begin
    FileFormat := FileFormatClass.Create(Description,Self);
    try
      FileFormat.ReadStream(Stream);
    finally
      FileFormat.Free;
    end;
  end;
end;

class function TEvBBitmap.RegisteredFileFormatCount: Integer;
begin
  Result := BitmapFileFormats.Count;
end;

class procedure TEvBBitmap.RegisterFileFormat(const Description, Extension,
  Header: String; const FileFormatClass: TEvBBitmapFileFormatClass;
  const SupportsQualityLevels: Boolean; const HeaderOffset: Integer);
begin
  BitmapFileFormats.Add(Description,Extension,Header,HeaderOffset,
    SupportsQualityLevels,FileFormatClass);
end;

procedure TEvBBitmap.SaveToFile(const Filename: String);
var
  Extension, Description: String;
  FileFormatClass: TEvBBitmapFileFormatClass;
  FileFormat: TEvBBitmapFileFormat;
  Stream: TStream;
begin
  Extension := ExtractFileExt(Filename);
  FileFormatClass := BitmapFileFormats.FindByExtension(Extension,Description);
  if FileFormatClass = nil then
    inherited
  else begin
    Stream := nil;
    FileFormat := FileFormatClass.Create(Description,Self);
    try
      FileFormat.Quality := FQuality;
      Stream := TFileStream.Create(Filename,fmCreate);
      FileFormat.WriteStream(Stream);
    finally
      FileFormat.Free;
      Stream.Free;
    end;
  end;
end;

procedure TEvBBitmap.SaveToStream(const Stream: TStream;
  const FileFormatExtension: String);
var
  Description: String;
  FileFormatClass: TEvBBitmapFileFormatClass;
  FileFormat: TEvBBitmapFileFormat;
begin
  FileFormatClass := BitmapFileFormats.FindByExtension(FileFormatExtension,Description);
  if FileFormatClass = nil then
    inherited SaveToStream(Stream)
  else begin
    FileFormat := FileFormatClass.Create(Description,Self);
    try
      FileFormat.Quality := FQuality;
      FileFormat.WriteStream(Stream);
    finally
      FileFormat.Free;
    end;
  end;
end;

initialization

finalization
  GlobalBitmapFileFormats.Free;

end.