utmain.pas

用Delphi语句实现对地图放大

  Setzoom(Trunc(z*fn+0.5));
  pt2:=PointToPos(ptFix);
  Pt3.x:=Pt1.x-pt2.x;
  pt3.Y:=pt1.Y-pt2.Y;
  pt3.x:=pt3.x+GetMapLeftTop.X;
  pt3.y:=pt3.y+getMapLeftTop.y;
  SetMapLeftTop(pt3);
end;

procedure TForm1.N3Click(Sender: TObject);
begin
  application.Terminate;
end;


//------------------------------------------------------------------------------
//画经纬度
//------------------------------------------------------------------------------
procedure TForm1.DrawJWDGrid(DrawText: boolean);
var Pt1,pt2,pt3,pt4:TPoint;
    I:integer;
begin
  image1.Repaint;
  image1.Canvas.Pen.Color := clGreen;
  for i:=-9 to 9 do
  begin
    pt3.X:=-180000;
    pt3.Y:=I*10000;
    pt1:=posToPoint(pt3);
    pt4.X:=180000;
    pt4.Y:=I*10000;
    pt2:=postopoint(pt4);
    image1.Canvas.MoveTo(pt1.X,pt1.Y);
    image1.Canvas.LineTo(pt2.X,pt2.y);
    if DrawText=true then
    begin
      image1.Canvas.TextOut(pt1.x-20,pt1.y-5,inttostr(i*10));
      image1.Canvas.TextOut(pt2.x+20,pt2.y-5,inttostr(i*10));
    end;

  end;
  for i:=-18 to 18 do
  begin
    pt3.y:=-90000;
    pt3.x:=I*10000;
    pt1:=posToPoint(pt3);
    pt4.y:=90000;
    pt4.x:=I*10000;
    pt2:=postopoint(pt4);
    image1.Canvas.MoveTo(pt1.X,pt1.Y);
    image1.Canvas.LineTo(pt2.X,pt2.y);
    if DrawText=true then
    begin
      image1.Canvas.TextOut(pt1.x-20,pt1.y-5,inttostr(i*10));
      image1.Canvas.TextOut(pt2.x+20,pt2.y-5,inttostr(i*10));
    end;

  end;
end;

procedure TForm1.N2Click(Sender: TObject);
var Testpt,showpt: TPoint;
begin
  iOriginPos.X:=102816;  //104016,31300
  iOriginPos.Y:=31700;
  iZoom:=400;
  redrawmap();
  teststation;
  label1.Visible:=true;


  end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  izoom:=400;
end;

//------------------------------------------------------------------------------
//画地图底图
//------------------------------------------------------------------------------
procedure TForm1.DrawMap;
var
  MapDatafileName:string;
  mapDatafile:TextFile;
  ifor:integer;
  Sreadln:string;
  n_data:integer;
  pt1,pt2:TPoint;
  r_jd, r_wd:real;
begin
  image1.Canvas.Pen.Color:=clsilver;
  MapDatafileName:=Extractfilepath(paramstr(0))+'sysData\cdmap.dat';
  If Not FileExists(MapDataFileName) Then
  Begin
    Application.MessageBox(Pchar('地图信息文件没有找到！(' + MapDataFileName+')'), '警告', MB_ICONERROR+MB_OK);
    Exit;
  End;

  AssignFile(MapDataFile, MapDataFileName);
  Reset(MapDataFile);
  Try
    if (not Eof(MapDataFile)) then
    Begin
      ReadLn(MapDataFile, sReadLn);
      if Midstr(sReadLn,1,9) <> 'diamond 9' then
      begin
        Application.MessageBox(Pchar('测站信息文件只能是Micaps第17类文件！'), '警告', MB_ICONERROR+MB_OK);
        Exit;
      end;
    End;
    ReadLn(MapDataFile, sReadLn);

    while (not Eof(MapDataFile)) Do
    Begin
      Read(MapDataFile, n_data);
      ReadLn(MapDataFile, sReadLn);
      for ifor := 1 to n_data do
      begin
        Read(MapDataFile, r_jd, r_wd);
        pt1.X:=Trunc(r_jd*1000);
        pt1.Y:=Trunc(r_wd*1000);
        pt2:=postopoint(pt1);
        If ifor = 1 Then
          image1.Canvas.MoveTo(pt2.x, pt2.y)
        Else
          image1.Canvas.lineto(pt2.x, pt2.y);
      End;
      ReadLn(MapDataFile, sReadLn);
    End;
  Finally
     CloseFile(MapDataFile);
  End;
end;

//------------------------------------------------------------------------------
//填充底图
//------------------------------------------------------------------------------
procedure TForm1.FillPoly(DC: HDC;FillColor: TColor);
var
  Rgn :HRGN;
  MapDatafileName:string;
  mapDatafile:TextFile;
  ifor:integer;
  Sreadln:string;
  n_data:integer;
  pt1,pt2:TPoint;
  r_jd, r_wd:real;
  PointList,PointList2: TPointList;
begin
//---------------------------------------------------------------
  MapDatafileName:=Extractfilepath(paramstr(0))+'sysData\cdmap.dat';
  If Not FileExists(MapDataFileName) Then
  Begin
    Application.MessageBox(Pchar('地图信息文件没有找到！(' + MapDataFileName+')'), '警告', MB_ICONERROR+MB_OK);
    Exit;
  End;

  AssignFile(MapDataFile, MapDataFileName);
  Reset(MapDataFile);
  Try
    if (not Eof(MapDataFile)) then
    Begin
      ReadLn(MapDataFile, sReadLn);
      if Midstr(sReadLn,1,9) <> 'diamond 9' then
      begin
        Application.MessageBox(Pchar('测站信息文件只能是Micaps第17类文件！'), '警告', MB_ICONERROR+MB_OK);
        Exit;
      end;
    End;
    ReadLn(MapDataFile, sReadLn);

      Read(MapDataFile, n_data);
      ReadLn(MapDataFile, sReadLn);
      for ifor := 1 to n_data do
      begin
        Read(MapDataFile, r_jd, r_wd);
        pt1.X:=Trunc(r_jd*1000);
        pt1.Y:=Trunc(r_wd*1000);
        pointlist[ifor-1]:=pt1;
        pointList2[ifor-1]:=postopoint(pointlist[ifor-1]);
      End;
  Finally
  CloseFile(MapDataFile);
  end;
  Rgn := CreatePolygonRgn(PointList2[0],High(PointList2)-1,ALternate);
  FillRgn(DC,Rgn,CreateSolidBrush(FillColor));
  DeleteObject(Rgn);
end;

//------------------------------------------------------------------------------
//重画地图
//------------------------------------------------------------------------------
procedure TForm1.ReDrawmap;
var
  Bitmap: TBitmap;
begin
  Bitmap := nil;
  try
    Bitmap := TBitmap.Create;
    Bitmap.Width := Image1.ClientWidth;
    Bitmap.Height := Image1.ClientHeight;
    Image1.Picture.Graphic := Bitmap;
  finally
    Bitmap.Free;
  end;
  FillPoly(image1.Canvas.Handle,clLime);
  Drawjwdgrid(true);
  Drawmap();
end;

procedure TForm1.N4Click(Sender: TObject);
var point:Tpoint;
    Testpt,showpt,fixpt: TPoint;
begin

  //iOriginPos.X:=102816;  //104016,31300
  //iOriginPos.Y:=31700;
  //point.X:=image1.ClientWidth;
  //point.Y:=image1.ClientHeight;
  //izoom:=trunc(izoom*1.2);
  fixpt.X:=popupmenu1.PopupPoint.X;
  fixpt.Y:=popupmenu1.PopupPoint.y;
  zoom(1.2,fixpt);
  ReDrawmap;
  teststation;
  image1.Repaint;
end;


procedure TForm1.N5Click(Sender: TObject);
var point:Tpoint;
    Testpt,showpt,fixpt: TPoint;

begin
  fixpt.X:=popupmenu1.PopupPoint.X;
  fixpt.Y:=popupmenu1.PopupPoint.y;

  //iOriginPos.X:=102816;  //104016,31300
  //iOriginPos.Y:=31700;
  //point.X:=image1.ClientWidth;
  //point.Y:=image1.ClientHeight;
  //izoom:=trunc(izoom*0.8);
  zoom(0.8,fixpt);
  ReDrawmap;
  teststation;

  image1.Repaint;
end;


procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  mouseOrig.X:=x;
  mouseorig.Y:=y;
end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var pt,pt2:TPoint;
begin
  pt.X:=Mouseorig.X-x;
  pt.Y:=MouseOrig.Y-y;
  if (abs(pt.x)+abs(pt.Y))>10 then
  begin
    pt2.X:=postopoint(ioriginpos).x+pt.x;
    pt2.Y:=postopoint(ioriginpos).Y+pt.y;
    ioriginpos.X:=pointtopos(pt2).x;
    ioriginpos.Y:=pointtopos(pt2).Y;
    redrawmap();
    teststation;
  end;

end;

procedure TForm1.TestStation;
var Testpt,showPt:TPoint;
begin

  Testpt.X:=Trunc(104.732222*1000);
  Testpt.Y:=trunc(30.628056*1000);
  showpt:=postopoint(testpt);
  image1.Canvas.Brush.Style:=bsclear;
  image1.Canvas.TextOut(showpt.X,showpt.Y,'三圣乡');
  image1.Canvas.Pen.Color:=clblue;
  image1.Canvas.Ellipse(showpt.X-3, showpt.Y-3, showpt.X+3, showpt.Y+3);
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var   MousePt:Tpoint;
      labj,labw:string;
begin


  MousePt.X:=x;
  MousePt.y:=Y;
  if x>0 then   labj:='东经'
  else          labj:='西经';
  if y>0 then   labw:='北纬'
  else          labw:='南纬';

  label1.caption:=labj+formatfloat('000.000',Pointtopos(Mousept).x/1000)+','+labw+formatfloat('00.000',Pointtopos(Mousept).y/1000);

end;

procedure TForm1.N7Click(Sender: TObject);
begin
  frmTool.Show;
  frmTool.FormStyle:=fsstayontop;
end;

procedure TForm1.N8Click(Sender: TObject);
begin
  frmshowfactor.Show;
  frmshowfactor.FormStyle:=fsstayontop;
end;

end.