mudmapunit.~pas

一个简单的小工具

unit MudMapUnit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, ComCtrls, Grids, ActnList, Buttons, ImgList, StdCtrls;

const
  cRowCount = 100;
  cColCount = 100;
  
type
  TFormMudMap = class(TForm)
    DrawGrid1: TDrawGrid;
    StatusBar1: TStatusBar;
    Panel1: TPanel;
    SpeedButton1: TSpeedButton;
    ActionList1: TActionList;
    ActionFullBox: TAction;
    ButtonOutputClipbar: TButton;
    ImageList1: TImageList;
    ButtonClear: TButton;
    procedure ActionFullBoxExecute(Sender: TObject);
    procedure DrawGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure FormCreate(Sender: TObject);
    procedure DrawGrid1KeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure ButtonOutputClipbarClick(Sender: TObject);
    procedure ButtonClearClick(Sender: TObject);
    procedure DrawGrid1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
  private
    { Private declarations }
    FPointList: array[0..cColCount - 1, 0..cRowCount - 1] of Integer;
    FGraphicIndex: Integer;
    procedure Clear;
  public
    { Public declarations }
  end;

var
  FormMudMap: TFormMudMap;

implementation

{$R *.dfm}

uses Clipbrd;

procedure TFormMudMap.Clear;
begin
  FillChar(FPointList, SizeOf(FPointList), 0);
  Repaint;
end;

procedure TFormMudMap.ActionFullBoxExecute(Sender: TObject);
begin
  FGraphicIndex := TAction(Sender).ImageIndex;
end;

procedure TFormMudMap.DrawGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
var
  vBitmap: TBitmap;
begin
  if FPointList[ACol, ARow] = 0 then Exit;
  vBitmap := TBitmap.Create;
  try
    ImageList1.GetBitmap(FPointList[ACol, ARow] - 1, vBitmap);
    TDrawGrid(Sender).Canvas.StretchDraw(Rect, vBitmap);
  finally
    vBitmap.Free;
  end;
end;

procedure TFormMudMap.FormCreate(Sender: TObject);
begin
  Clear;
end;

procedure TFormMudMap.DrawGrid1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
  I, J: Integer;
begin
  case Key of
    VK_SPACE, VK_RETURN:
    begin
      with TDrawGrid(Sender).Selection do
        for I := Left to Right do
          for J := Top to Bottom do
            FPointList[I, J] := FGraphicIndex + 1;
      TDrawGrid(Sender).Repaint;
    end;
    VK_DELETE:
    begin
      with TDrawGrid(Sender).Selection do
        for I := Left to Right do
          for J := Top to Bottom do
            FPointList[I, J] := 0;
      TDrawGrid(Sender).Repaint;
    end;
  end;
end;

procedure TFormMudMap.ButtonOutputClipbarClick(Sender: TObject);
var
  vBitmap: TBitmap;
  vRect: TRect;
  I, J: Integer;
  vFormat: Word;
  vData: THandle;
  vPalette: HPALETTE;
begin
  FillChar(vRect, SizeOf(vRect), 0);
  vRect.Left := cRowCount - 1;
  vRect.Top := cColCount - 1;
  for I := 0 to cColCount - 1 do
    for J := 0 to cRowCount - 1 do
      if FPointList[I, J] <> 0 then
      begin
        if vRect.Left > I then vRect.Left := I;
        if vRect.Top > J then vRect.Top := J;
        if vRect.Right < I then vRect.Right := I;
        if vRect.Bottom < J then vRect.Bottom := J;
      end;
  vBitmap := TBitmap.Create;
  try
    vBitmap.Width := (vRect.Right - vRect.Left + 1) * ImageList1.Width;
    vBitmap.Height := (vRect.Bottom - vRect.Top + 1) * ImageList1.Height;
    for I := vRect.Left to vRect.Right do
      for J := vRect.Top to vRect.Bottom do
        if FPointList[I, J] <> 0 then
          ImageList1.Draw(vBitmap.Canvas,
            (I - vRect.Left) * ImageList1.Width,
            (J - vRect.Top) * ImageList1.Height,
            FPointList[I, J] - 1);
    vBitmap.SaveToClipBoardFormat(vFormat, vData, vPalette);
    ClipBoard.SetAsHandle(vFormat, vData);
  finally
    vBitmap.Free;
  end;
end;

procedure TFormMudMap.ButtonClearClick(Sender: TObject);
begin
  Clear;
end;

procedure TFormMudMap.DrawGrid1MouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
begin
  TDrawGrid(Sender).MouseToCell(X, Y, X, Y);
  StatusBar1.Panels[0].Text := Format('', [X, Y])
end;

end.