import
This commit is contained in:
@@ -0,0 +1,22 @@
|
||||
TargaImage.pas is a TGraphic descendant for Delphi. Installing it
|
||||
will allow Delphi TImage and TDBImage components to read Targa files
|
||||
just like BMP & WMF files with no coding on your part.
|
||||
|
||||
It also adds the TGA file type to the Delphi Open/Save Picture dialog
|
||||
boxes.
|
||||
|
||||
To install this unit, place it in your one of your library folders
|
||||
and make it available to all your Delphi projects by using
|
||||
Component>Install Component from the Delphi menus.
|
||||
|
||||
NOTE: any Delphi applications using this *must* have FreeImage.dll
|
||||
installed in your application's folder, or somewhere in the path.
|
||||
|
||||
-----------------------
|
||||
|
||||
Tommy
|
||||
Edinburgh, Scotland
|
||||
LeTene@battlefieldeurope.org
|
||||
|
||||
|
||||
|
||||
@@ -0,0 +1,212 @@
|
||||
unit TargaImage;
|
||||
|
||||
// ==========================================================
|
||||
//
|
||||
// This file is part of FreeImage 3
|
||||
//
|
||||
// COVERED CODE IS PROVIDED UNDER THIS LICENSE ON AN "AS IS" BASIS, WITHOUT WARRANTY
|
||||
// OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, WITHOUT LIMITATION, WARRANTIES
|
||||
// THAT THE COVERED CODE IS FREE OF DEFECTS, MERCHANTABLE, FIT FOR A PARTICULAR PURPOSE
|
||||
// OR NON-INFRINGING. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE COVERED
|
||||
// CODE IS WITH YOU. SHOULD ANY COVERED CODE PROVE DEFECTIVE IN ANY RESPECT, YOU (NOT
|
||||
// THE INITIAL DEVELOPER OR ANY OTHER CONTRIBUTOR) ASSUME THE COST OF ANY NECESSARY
|
||||
// SERVICING, REPAIR OR CORRECTION. THIS DISCLAIMER OF WARRANTY CONSTITUTES AN ESSENTIAL
|
||||
// PART OF THIS LICENSE. NO USE OF ANY COVERED CODE IS AUTHORIZED HEREUNDER EXCEPT UNDER
|
||||
// THIS DISCLAIMER.
|
||||
//
|
||||
// Use at your own risk!
|
||||
//
|
||||
// ==========================================================
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Windows,
|
||||
Classes,
|
||||
FreeImage,
|
||||
Graphics,
|
||||
Types;
|
||||
|
||||
type
|
||||
TTargaImage = class(TGraphic)
|
||||
private
|
||||
fImage: PFIBITMAP;
|
||||
fWidth: Integer;
|
||||
fHeight: Integer;
|
||||
protected
|
||||
procedure Draw(ACanvas: TCanvas; const ARect: TRect); override;
|
||||
function GetEmpty: Boolean; override;
|
||||
function GetHeight: Integer; override;
|
||||
function GetWidth: Integer; override;
|
||||
procedure SetHeight(Value: Integer); override;
|
||||
procedure SetWidth(Value: Integer); override;
|
||||
public
|
||||
constructor Create; override;
|
||||
destructor Destroy; override;
|
||||
procedure Assign(Source: TPersistent); override;
|
||||
procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE); override;
|
||||
procedure LoadFromStream(Stream: TStream); override;
|
||||
procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle; var APalette: HPALETTE); override;
|
||||
procedure SaveToStream(Stream: TStream); override;
|
||||
end;
|
||||
|
||||
procedure Register;
|
||||
|
||||
implementation
|
||||
|
||||
{ Design-time registration }
|
||||
|
||||
procedure Register;
|
||||
begin
|
||||
TPicture.RegisterFileFormat('tga', 'TARGA Files', TTargaImage);
|
||||
end;
|
||||
|
||||
{ IO functions }
|
||||
|
||||
function FI_ReadProc(buffer : pointer; size : Cardinal; count : Cardinal; handle : fi_handle) : UInt; stdcall;
|
||||
var
|
||||
stream: TStream;
|
||||
bytesToRead: Cardinal;
|
||||
begin
|
||||
stream := TStream(handle);
|
||||
bytesToRead := size*count;
|
||||
Result := stream.Read(buffer^, bytesToRead);
|
||||
end;
|
||||
|
||||
function FI_WriteProc(buffer : pointer; size, count : Cardinal; handle : fi_handle) : UInt; stdcall;
|
||||
var
|
||||
stream: TStream;
|
||||
bytesToWrite: Cardinal;
|
||||
begin
|
||||
stream := TStream(handle);
|
||||
bytesToWrite := size*count;
|
||||
Result := stream.Write(buffer^, bytesToWrite);
|
||||
end;
|
||||
|
||||
function FI_SeekProc(handle : fi_handle; offset : longint; origin : integer) : Integer; stdcall;
|
||||
begin
|
||||
TStream(handle).Seek(offset, origin);
|
||||
Result := 0;
|
||||
end;
|
||||
|
||||
function FI_TellProc(handle : fi_handle) : LongInt; stdcall;
|
||||
begin
|
||||
Result := TStream(handle).Position;
|
||||
end;
|
||||
|
||||
{ TTargaImage }
|
||||
|
||||
constructor TTargaImage.Create;
|
||||
begin
|
||||
fImage := nil;
|
||||
fWidth := 0;
|
||||
fHeight := 0;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
destructor TTargaImage.Destroy;
|
||||
begin
|
||||
if Assigned(fImage) then
|
||||
FreeImage_Unload(fImage);
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TTargaImage.Assign(Source: TPersistent);
|
||||
begin
|
||||
if Source is TTargaImage then begin
|
||||
fImage := FreeImage_Clone(TTargaImage(Source).fImage);
|
||||
fWidth := FreeImage_GetWidth(fImage);
|
||||
fHeight := FreeImage_GetHeight(fImage);
|
||||
Changed(Self);
|
||||
end else
|
||||
inherited;
|
||||
end;
|
||||
|
||||
procedure TTargaImage.Draw(ACanvas: TCanvas; const ARect: TRect);
|
||||
var
|
||||
pbi: PBitmapInfo;
|
||||
begin
|
||||
if Assigned(fImage) then begin
|
||||
pbi := FreeImage_GetInfo(fImage);
|
||||
SetStretchBltMode(ACanvas.Handle, COLORONCOLOR);
|
||||
StretchDIBits(ACanvas.Handle, ARect.left, ARect.top,
|
||||
ARect.right-ARect.left, ARect.bottom-ARect.top,
|
||||
0, 0, fWidth, fHeight,
|
||||
FreeImage_GetBits(fImage), pbi^, DIB_RGB_COLORS, SRCCOPY);
|
||||
end;
|
||||
end;
|
||||
|
||||
function TTargaImage.GetEmpty: Boolean;
|
||||
begin
|
||||
Result := Assigned(fImage);
|
||||
end;
|
||||
|
||||
function TTargaImage.GetHeight: Integer;
|
||||
begin
|
||||
Result := fHeight;
|
||||
end;
|
||||
|
||||
function TTargaImage.GetWidth: Integer;
|
||||
begin
|
||||
Result := fWidth;
|
||||
end;
|
||||
|
||||
procedure TTargaImage.LoadFromClipboardFormat(AFormat: Word; AData: THandle; APalette: HPALETTE);
|
||||
begin
|
||||
if Assigned(fImage) then begin
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTargaImage.LoadFromStream(Stream: TStream);
|
||||
var
|
||||
io: FreeImageIO;
|
||||
begin
|
||||
with io do begin
|
||||
read_proc := FI_ReadProc;
|
||||
write_proc := FI_WriteProc;
|
||||
seek_proc := FI_SeekProc;
|
||||
tell_proc := FI_TellProc;
|
||||
end;
|
||||
fImage := FreeImage_LoadFromHandle(FIF_TARGA, @io, Stream);
|
||||
if Assigned(fImage) then begin
|
||||
fWidth := FreeImage_GetWidth(fImage);
|
||||
fHeight := FreeImage_GetHeight(fImage);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTargaImage.SaveToClipboardFormat(var AFormat: Word; var AData: THandle; var APalette: HPALETTE);
|
||||
begin
|
||||
end;
|
||||
|
||||
procedure TTargaImage.SaveToStream(Stream: TStream);
|
||||
var
|
||||
io: FreeImageIO;
|
||||
begin
|
||||
with io do begin
|
||||
read_proc := FI_ReadProc;
|
||||
write_proc := FI_WriteProc;
|
||||
seek_proc := FI_SeekProc;
|
||||
tell_proc := FI_TellProc;
|
||||
end;
|
||||
FreeImage_SaveToHandle(FIF_TARGA, fImage, @io, Stream);
|
||||
end;
|
||||
|
||||
procedure TTargaImage.SetHeight(Value: Integer);
|
||||
begin
|
||||
if Assigned(fImage) then begin
|
||||
fHeight := Value;
|
||||
FreeImage_Rescale(fImage, fWidth, fHeight, FILTER_BICUBIC);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TTargaImage.SetWidth(Value: Integer);
|
||||
begin
|
||||
if Assigned(fImage) then begin
|
||||
fWidth := Value;
|
||||
FreeImage_Rescale(fImage, fWidth, fHeight, FILTER_BICUBIC);
|
||||
end;
|
||||
end;
|
||||
|
||||
initialization
|
||||
TPicture.RegisterFileFormat('tga', 'TARGA Files', TTargaImage);
|
||||
end.
|
||||
Reference in New Issue
Block a user