importbitmaps.pas

N年前有个法国小组用Delphi写了一个2D网游（AD&D类型）

unit ImportBitmaps;

{
 projet ADK-ISO (c)2002-2003 Paul TOTH <[e-mail]>

 http://www.web-synergy.net/naug-land/

}

interface

uses
  ADKImages, ImageTrees,
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, Spin;

type
  TBitmapImporter = class(TForm)
    OK: TButton;
    Button2: TButton;
    Image4: TImage;
    Label1: TLabel;
    seOrgX: TSpinEdit;
    seOrgY: TSpinEdit;
    Image5: TImage;
    Label2: TLabel;
    shColor: TShape;
    ColorDialog1: TColorDialog;
    Panel2: TPanel;
    PaintBox1: TPaintBox;
    cbCheckboard: TCheckBox;
    cbGrid: TCheckBox;
    cbOrg: TCheckBox;
    procedure Image4MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image4MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Image4MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Image5Click(Sender: TObject);
    procedure seOrgXChange(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure PaintBox1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure PaintBox1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure cbCheckboardClick(Sender: TObject);
    procedure OKClick(Sender: TObject);
  private
    { Private declarations }
    fFileName:string;
    fImageTree:TImageTree;
    fDialog:TOpenDialog;
    fImage:TBitmap;
    MouseX,MouseY,MouseB:integer;
    Org:TPoint;
    ox,oy:integer;
    procedure SetFileName(AFileName:string);
  public
    { Public declarations }
    property FileName:string read fFileName write SetFileName;
  end;

var
  BitmapImporter: TBitmapImporter;

function bgr(rgb:cardinal):cardinal;
procedure ImportBitmap(AImageTree:TImageTree; ADialog:TOpenDialog);

implementation

uses IsoMap1, ADKUtils, CommonData;

{$R *.dfm}

function bgr(rgb:cardinal):cardinal;
begin
 result:=(rgb and $FF00FF00) or ((rgb and $FF) shl 16) or ((rgb shr 16) and $ff); 
end;

procedure ImportBitmap(AImageTree:TImageTree; ADialog:TOpenDialog);
begin
 if BitmapImporter=nil then BitmapImporter:=TBitmapImporter.Create(Application);
 BitmapImporter.fDialog:=ADialog;
 BitmapImporter.fImageTree:=AImageTree;
 BitmapImporter.FileName:=OpenFileName(ADialog);
 BitmapImporter.ShowModal;
end;

function LessThan256Colors(Bitmap:TBitmap):boolean;
var
 p:array[0..255] of TColor;
 colorcount:integer;
 x,y:integer;

 function AddColor(color:TColor):boolean;
 var
  i:integer;
 begin
  for i:=0 to ColorCount-1 do
   if p[i]=color then begin
    result:=true;
    exit;
   end;
  if ColorCount=256 then
   result:=false
  else begin
   p[colorCount]:=color;
   inc(colorcount);
   result:=true;
  end;
 end;

begin
 case Bitmap.PixelFormat of
  pf1bit,pf4bit,pf8Bit: begin
   Bitmap.PixelFormat:=pf8bit;
   result:=true;
  end;
  pf15bit,pf16bit,pf32bit: begin
   colorcount:=0;
   for x:=0 to Bitmap.width-1 do
    for y:=0 to Bitmap.Height-1 do
     if not AddColor(Bitmap.Canvas.Pixels[x,y]) then begin
      result:=false;
      exit;
     end;
   Bitmap.PixelFormat:=pf8bit;
   result:=true;
  end;
  else result:=false;
 end;
end;

procedure TBitmapImporter.FormCreate(Sender: TObject);
begin
 fImage:=TBitmap.Create;
 fImage.Transparent:=True;
 LoadCheckBox(cbCheckBoard);
 LoadCheckBox(cbGrid);
 LoadCheckBox(cbOrg);
end;

procedure TBitmapImporter.FormDestroy(Sender: TObject);
begin
 SaveCheckBox(cbCheckBoard);
 SaveCheckBox(cbGrid);
 SaveCheckBox(cbOrg);
 fImage.Free;
end;

procedure TBitmapImporter.SetFileName(AFileName:string);
begin
 fFileName:=AFileName;
 fImage.LoadFromFile(fFileName);
 shColor.Brush.Color:=fImage.TransparentColor;
 if LessThan256Colors(fImage) then
  OK.Enabled:=True
 else begin
  OK.Enabled:=False;
  ShowMessage('Cette image comprend plus de 256 couleurs !');
 end;
end;

procedure TBitmapImporter.Image4MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
 MouseB:=ord(Button)+1;
 MouseX:=x;
 MouseY:=y;
 SetCaptureControl(TControl(Sender));
end;

procedure TBitmapImporter.Image4MouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
begin
 if MouseB>0 then begin
  seOrgX.Value:=org.x+x-MouseX;
  seOrgY.Value:=org.y+y-MouseY;
 end;
 MouseX:=x;
 MouseY:=y;
end;

procedure TBitmapImporter.Image4MouseUp(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
 SetCaptureControl(nil);
 MouseB:=0;
end;

procedure TBitmapImporter.Image5Click(Sender: TObject);
var
 cl:TColor;
begin
 ColorDialog1.Color:=shColor.Brush.Color;
 if ColorDialog1.Execute then begin
  cl:=ColorDialog1.Color;
  fImage.TransparentMode:=tmFixed;
  fImage.TransparentColor:=cl;
  shColor.Brush.color:=cl;
  PaintBox1Paint(nil);
 end;
end;

procedure TBitmapImporter.seOrgXChange(Sender: TObject);
begin
 with TSpinEdit(Sender) do begin
  if Tag=0 then org.x:=Value else org.y:=Value;
 end;
 PaintBox1Paint(nil);
end;

procedure TBitmapImporter.PaintBox1Paint(Sender: TObject);
var
 x,y,w,h:integer;
 bmp:TBitmap;

 procedure Grid(x,y,dir:integer);
 begin
  if (x<-48)or(y<-24) then exit;
  with bmp,Canvas do begin
   if (x>Width+48)or(y>Height+24) then exit;
   MoveTo(x-48,y   );
   LineTo(x   ,y-24);
   LineTo(x+48,y   );
   LineTo(x   ,y+24);
   LineTo(x-48,y   );
   if (dir and 1)=1 then Grid(x+48,y-24,dir and 3);
   if (dir and 2)=2 then Grid(x+48,y+24,dir and 6);
   if (dir and 4)=4 then Grid(x-48,y+24,dir and 12);
   if (dir and 8)=8 then Grid(x-48,y-24,dir and 9);
  end;
 end;

begin
 bmp:=TBitmap.Create;
 bmp.Width:=PaintBox1.Width;
 bmp.Height:=PaintBox1.Height;
 ox:=(PaintBox1.Width-fImage.Width) div 2;
 oy:=(PaintBox1.Height-fImage.Height) div 2;
 with bmp,Canvas do begin
  if cbCheckboard.Checked then begin
   Brush.Color:=clSilver;
   FillRect(Rect(ox,oy,ox+fImage.Width,oy+fImage.Height));
   Brush.Color:=clWhite;
   w:=fImage.Width div 6;
   h:=fImage.Height div 6;
   for y:=0 to h do begin
    for x:=0 to w do begin
     if odd(x+y) then FillRect(Rect(ox+6*x,oy+6*y,ox+6*(x+1),oy+6*(y+1)));
    end;
   end;
   Brush.Color:=clGray;
   FillRect(Rect(0,0,ox,Height));
   FillRect(Rect(ox+fImage.Width,0,Width,Height));
   FillRect(Rect(ox,0,ox+fImage.Width,oy));
   FillRect(Rect(ox,oy+fImage.Height,ox+fImage.Width,Height));
  end else begin
   Brush.Color:=clGray;
   FillRect(ClientRect);
  end;

  Draw(ox,oy,fImage);

  if cbGrid.Checked then begin
   Pen.Color:=clLime;
   Grid(ox+org.x,oy+org.y,1+2+4+8);
  end;

  if cbOrg.Checked then begin
   Pen.Color:=clRed;
   MoveTo(ox+org.x,0);
   LineTo(ox+org.x,Height);
   MoveTo(0,oy+org.y);
   LineTo(Width,oy+org.y);
  end;

 end;
 PaintBox1.Canvas.Draw(0,0,bmp);
 bmp.Free;
end;

procedure TBitmapImporter.PaintBox1MouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
 cl:integer;
begin
 if (x<ox)or(y<oy)or(x>ox+fImage.Width)or(y>oy+fImage.Height) then exit;
 cl:=fImage.Canvas.Pixels[x-ox,y-oy];
 fImage.TransparentMode:=tmFixed;
 fImage.TransparentColor:=cl;
 shColor.Brush.color:=cl;
 PaintBox1Paint(nil);
end;

procedure TBitmapImporter.PaintBox1MouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
var
 s:string;
begin
 s:=IntToHex(fImage.Canvas.Pixels[x,y],6);
 if PaintBox1.Hint<>s then begin
  Application.HideHint;
  PaintBox1.Hint:=s;
  Application.ActivateHint(PaintBox1.ClientToScreen(Point(x,y)));
 end;
end;

procedure TBitmapImporter.cbCheckboardClick(Sender: TObject);
begin
 PaintBox1Paint(nil);
end;

procedure TBitmapImporter.OKClick(Sender: TObject);
begin
 fImageTree.AddBitmap(fImageTree.TreeView.Selected,ExtractFileName(fFileName),fImage,org);
end;

end.