makemap1.pas

自己开发的delphi 100lei 内容丰富 绝对不要错过了啊。

unit makemap1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, Buttons, StdCtrls, ComCtrls, Menus, ToolWin;

type
  TForm1 = class(TForm)
    ScrollBox1: TScrollBox;
    bild: TPaintBox;
    opend: TOpenDialog;
    Bar1: TStatusBar;
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    SpeedButton4: TSpeedButton;
    SpeedButton5: TSpeedButton;
    SpeedButton6: TSpeedButton;
    Memo1: TMemo;
    ToolBar1: TToolBar;
    MainMenu1: TMainMenu;
    fire1: TMenuItem;
    open1: TMenuItem;
    N1: TMenuItem;
    Quit1: TMenuItem;
    GroupBox1: TGroupBox;
    ComboBox1: TComboBox;
    N2: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure bildPaint(Sender: TObject);
    procedure ComboBox1Change(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure SpeedButton3Click(Sender: TObject);
    procedure bildMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure bildMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure bildMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure bildDblClick(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure showmap2Click(Sender: TObject);
    procedure showmap1Click(Sender: TObject);
    procedure open1Click(Sender: TObject);
  private
    { Private-Deklarationen }
    function getzoom : integer;
    procedure updatebild;
    procedure getimgs;
    procedure gettbmp;
    procedure settbmp;
    procedure addmap(x,y:integer);
    function gv (a,x:integer):string;
    procedure drawmap(s:string);
    function gc (var s : string):integer;
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;
  myimg : array [-1..4] of tbitmap;
  map : tstrings;
  points : tstrings;
  mode : integer = 1;
  ismode : boolean = false;
  oldx,oldy : integer;
  pts : array [0..500] of tpoint;
  ptix : integer = 0;
  allownext : boolean = true;
  allowchange : boolean = true;
  canchange : boolean = true;
const zoom : array [-1..3] of byte = (1,1,2,4,8);
implementation

{$R *.DFM}

function tform1.gc (var s : string):integer;
var t : integer;
begin
     result := maxint;
     if length(s) < 2 then exit;
     if s[1] = ',' then begin
        delete(s,1,1);
        t := pos(',',s);
        if t = 0 then t := maxint-1;
        result := strtointdef(copy(s,1,t-1),maxint)*getzoom;
        s := copy(s,t,maxint);
     end;
end;

procedure tform1.drawmap(s:string);
var ch : char;
    a,b,c,d : integer;
    tmt : array [0..500] of tpoint;
begin
     ch := s[1];
     delete(s,1,1);
     with bild.canvas do begin
          //pen.mode := pmblack;
          if ch <> 'p' then begin
             a := gc(s);
             b := gc(s);
             c := gc(s);
             d := gc(s);
          end;
          case ch of
               'c' : ellipse(a,b,c,(c-a)+b);
               'p' : begin
                          a := 0;
                          b := gc(s);
                          while b < maxint-1 do begin
                                tmt[a].x := b;
                                tmt[a].y := gc(s);
                                inc(a);
                                b:=gc(s);
                          end;
                          polygon(slice(tmt,a-1));
                      end;
               'r' : rectangle(a,b,c,d);
          end;
     end;
end;

function tform1.gv (a,x:integer):string;
begin
     a := a div getzoom;
     //if a < 0 then a := 0;
     //if a > x then a := x;
     result:=','+inttostr(a);
end;

procedure tform1.addmap(x,y:integer);
const md : array [1..3] of char = ('r','c','p');
var sr : string;
    t : integer;
    x1,y1 : integer;
begin
     x1 := myimg[0].width;
     y1 := myimg[0].height;
     sr := md[mode];
     if mode < 1 then exit;
     if mode <> 3 then begin
         sr := sr+gv(oldx,x1)+gv(oldy,y1);
         sr := sr+gv(x,x1);
         if mode = 1 then sr := sr+gv(y,y1);
         map.add(sr);
         memo1.lines.add(sr);
         updatebild;
         exit;
     end;
     if ptix < 2 then exit;
     for t := 0 to ptix -1 do begin
         sr := sr+gv(pts[t].x,x1);
         sr := sr+gv(pts[t].y,y1);
     end;
     map.add(sr);
         memo1.lines.add(sr);
     updatebild;
end;

procedure tform1.gettbmp;
begin
     screen.cursor := crhourglass;
     with myimg[4] do begin
          width := bild.width;
          height := bild.height;
          canvas.copyrect(rect(0,0,width,height),bild.canvas,rect(0,0,width,height));
     end;
     screen.cursor := crdefault;
end;

procedure tform1.settbmp;
begin
     bild.canvas.draw(0,0,myimg[4]);
end;

procedure tform1.getimgs;
var t : integer;
begin
     screen.cursor := crhourglass;
     for t := 0 to 3 do
         with myimg[t] do begin
              width := myimg[-1].width * zoom[t];
              height := myimg[-1].height * zoom[t];
              canvas.stretchdraw(rect(0,0,width,height),myimg[-1]);
         end;
     screen.cursor := crdefault;
end;

procedure tform1.updatebild;
begin
          ismode := false;
          bild.width := myimg[-1].width * getzoom;
          bild.height := myimg[-1].height * getzoom;
          bild.repaint;
end;

function tform1.getzoom : integer;
begin
     result := zoom[combobox1.itemindex];
end;

procedure TForm1.FormCreate(Sender: TObject);
var t : integer;
begin
     for t := -1 to 4 do myimg[t] := tbitmap.create;
     map := tstringlist.create;
     combobox1.itemindex := 0;
end;

procedure TForm1.FormDestroy(Sender: TObject);
var t : integer;
begin
     for t := -1 to 4 do myimg[t].free;
     map.free;

end;

procedure TForm1.SpeedButton1Click(Sender: TObject);
var sr : tfilename;
begin
     with opend do begin
          title := 'open map';
          if execute then begin
             sr := filename;
             if not fileexists(sr) then exit;
             myimg[-1].loadfromfile(sr);
             getimgs;
             sr:=changefileext(sr,'.map');
             map.clear;
             if  fileexists(sr) then
                 map.loadfromfile(sr);
             memo1.lines.assign(map);
             updatebild;
             speedbutton4.down := true;
             mode := 1;
          end;
     end;
end;

procedure TForm1.bildPaint(Sender: TObject);
var t : integer;
begin
     bild.canvas.pen.mode := pmblack;
     bild.canvas.draw(0,0,myimg[combobox1.itemindex]);
     bild.canvas.pen.mode := pmnot;
     if map.count > 0 then for t := 0 to map.count -1 do
        drawmap(map[t]);
     gettbmp;
end;

procedure TForm1.ComboBox1Change(Sender: TObject);
begin
     updatebild;
end;

procedure TForm1.SpeedButton2Click(Sender: TObject);
var sr : tfilename;
begin
     sr := opend.filename;
     if not fileexists(sr) then
     with opend do begin
          title := 'save map';
          if not execute then exit;
          sr := changefileext(opend.filename,'.map');
     end;
     sr := changefileext(sr,'.map');
     map.savetofile(sr);
end;

procedure TForm1.SpeedButton3Click(Sender: TObject);
begin
     ismode := false;
     mode := (sender as tspeedbutton).tag;
     updatebild;
end;

procedure TForm1.bildMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var t : integer;
begin
     bar1.Panels[0].Text := 'X: '+inttostr(x div getzoom)+'  Y: '+inttostr(y div getzoom);
     if not ismode then exit;
     with bild.canvas do begin
          pen.mode := pmnot;
          pen.width := 0;
          settbmp;
          case mode of
               1 : rectangle(oldx div getzoom*getzoom,oldy div getzoom*getzoom,x div getzoom*getzoom,y div getzoom*getzoom);
               2 : ellipse(oldx div getzoom*getzoom,oldy div getzoom*getzoom,x div getzoom*getzoom,(oldy+(x-oldx)) div getzoom*getzoom);
               3 : begin
                        if ptix = 0 then exit;
                        pen.width := getzoom;
                        t := 0;
                        moveto(pts[0].x,pts[0].y);
                        if ptix > 1 then begin
                           for t := 1 to ptix -1 do
                               lineto(pts[t].x,pts[t].y);
                        end;
                        lineto(x div getzoom*getzoom,y div getzoom*getzoom);
                   end;
          end;
     end;
end;

procedure TForm1.bildMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
     if not allownext then begin
        allownext := true;
        exit;
     end;
     if not ismode then gettbmp;
     oldx := x;
     oldy := y;
     if not ismode then ptix := 0;
     ismode := true;
     if mode = 3 then begin
        if ptix > 500 then exit;
        pts [ptix].x := x div getzoom*getzoom;
        pts [ptix].y := y div getzoom*getzoom;
        inc (ptix);
     end;
end;

procedure TForm1.bildMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
     if ismode then if mode <> 3 then addmap(x,y);
     if mode <> 3 then ismode := false;
end;

procedure TForm1.bildDblClick(Sender: TObject);
begin
     if ismode then if mode = 3 then addmap(0,0);
     ismode := false;
     ptix :=0;
     allownext := false;
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
     if key = vk_escape then
        updatebild;
end;

procedure TForm1.showmap2Click(Sender: TObject);
var t : integer;
    sr : string;
begin
     bild.canvas.pen.mode := pmblack;
     sr :=memo1.lines[SendMessage(memo1.Handle, EM_LINEFROMCHAR, memo1.SelStart, 0)];
     if sr = '' then exit;
     drawmap(sr);
     bild.canvas.pen.mode := pmnot;
     for t := 0 to 10 do begin
         drawmap(sr);
         sleep(30);
     end;
     updatebild;

end;

procedure TForm1.showmap1Click(Sender: TObject);
begin
     map.assign(memo1.lines);
     updatebild;
end;

procedure TForm1.open1Click(Sender: TObject);
var sr : tfilename;
begin
     with opend do begin
          title := 'open map';
          if execute then begin
             sr := filename;
             if not fileexists(sr) then exit;
             myimg[-1].loadfromfile(sr);
             getimgs;
             sr:=changefileext(sr,'.map');
             map.clear;
             if  fileexists(sr) then
                 map.loadfromfile(sr);
             memo1.lines.assign(map);
             updatebild;
             speedbutton4.down := true;
             mode := 1;
          end;
     end;
end;

end.