MapX实现自动滚屏(移屏)功能

MapX实现自动滚屏(移屏)功能

visli (h_visli@hotmail.com)

近日要做个在MapX上画线时，实现地图自动移动的功能，到网上搜索了一圈（包括MapInfo网站），找到的可怜的一点VB代码，也是只实现了滚屏 ，而没有实现划线等功能。这个问题是大家都遇到的，我反复看了MapInfo的操作，昨天下班的路上终于想去了解决的办法。

基本思路是：在鼠标按下（MouseDown）时，绘制实际线，在鼠标移动时（MouseMove），进行自动滚屏（如果需要的话），并绘制橡皮筋（不断更新），橡皮筋为9号线型的。有了这个思路就是会者不难了：

 

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, OleCtrls, MapXLib_TLB;

type
  TForm1 = class(TForm)
    Map1: TMap;
    btnZoomIn: TButton;
    btnZoomOut: TButton;
    btnDrawLine: TButton;
    procedure FormCreate(Sender: TObject);
    procedure btnZoomInClick(Sender: TObject);
    procedure btnZoomOutClick(Sender: TObject);
    procedure btnDrawLineClick(Sender: TObject);
    procedure Map1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Map1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Map1DblClick(Sender: TObject);
    procedure Map1ToolUsed(ASender: TObject; ToolNum: Smallint; X1, Y1, X2,
      Y2, Distance: Double; Shift, Ctrl: WordBool;
      var EnableDefault: WordBool);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

const
  DrawLineTool = 88;

var
  Form1: TForm1;

  //用于存放线上的点集
  LinePoints: CMapXPoints;
  //画线层
  LineLayer: CMapXLayer;
  //绘制线
  LineFtr: CMapXFeature;
  //橡皮筋
  RubberbandFtr: CMapXFeature;
  //橡皮筋样式
  RBStyle: CMapXStyle;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  LinePoints := CoPoints.Create;
  RBStyle := CoStyle.Create;
  //设置橡皮筋的线样式
  RBStyle.LineStyle := 9;

  LineLayer := Map1.Layers.CreateLayer('LineLayer', EmptyParam, EmptyParam, EmptyParam, EmptyParam);
  LineLayer.Editable := True;
  Map1.Layers.AnimationLayer := LineLayer;

  Map1.CreateCustomTool(DrawLineTool, miToolTypePoint, 2);
end;

procedure TForm1.btnZoomInClick(Sender: TObject);
begin
  Map1.CurrentTool := miZoomInTool;
end;

procedure TForm1.btnZoomOutClick(Sender: TObject);
begin
  Map1.CurrentTool := miZoomOutTool;
end;

procedure TForm1.btnDrawLineClick(Sender: TObject);
begin
  Map1.CurrentTool := DrawLineTool;
end;

procedure TForm1.Map1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  sX, sY: Single;
  mX, mY: Double;
begin
  if map1.CurrentTool = DrawLineTool then
  begin
    //将屏幕坐标转变为经纬度坐标
    sX := X;
    sY := Y;
    map1.ConvertCoord(sX, sY, mX, mY, miScreenToMap);

    LinePoints.AddXY(mX, mY, EmptyParam);

    if LinePoints.Count > 1 then
    begin
      if LinePoints.Count = 2 then
      begin
        LineFtr := Map1.FeatureFactory.CreateLine(LinePoints, EmptyParam);
        LineFtr := LineLayer.AddFeature(LineFtr, EmptyParam);
      end
      else
        //LineFtr.Parts.Item[1].AddXY(mX, mY, EmptyParam);
        LineFtr.Parts.Item(1).AddXY(mX, mY, EmptyParam);
      LineFtr.Update(True, EmptyParam);
    end;
  end;
end;

procedure TForm1.Map1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  RBPoints: CMapXPoints;
  sX, sY: Single;
  mX, mY: Double;
begin
  if map1.CurrentTool = DrawLineTool then
  begin
    //自动左右移屏
    if X > map1.MapScreenWidth - 10 then //右移
      map1.CenterX := map1.CenterX + Map1.Zoom * 0.0005
    else if X < 10 then //左移
      map1.CenterX := map1.CenterX - Map1.Zoom * 0.0005;

    //自动上下移屏
    if Y > map1.MapScreenHeight - 10 then //下移
      map1.CenterY := map1.CenterY - Map1.Zoom * 0.0005
    else if Y < 10 then //上移
      map1.CenterY := map1.CenterY + Map1.Zoom * 0.0005;

    if LinePoints.Count > 0 then
    begin
      sX := X;
      sY := Y;
      Map1.ConvertCoord(sX, sY, mX, mY, miScreenToMap);

      //获取橡皮筋起始与结束点
      RBPoints := CoPoints.Create;
      RBPoints.AddXY(LinePoints.Item(LinePoints.Count).X,
        LinePoints.Item(LinePoints.Count).Y,
        EmptyParam);
      RBPoints.AddXY(mX, mY, EmptyParam);

      if not Assigned(RubberbandFtr) then
      begin
        RubberbandFtr := Map1.FeatureFactory.CreateLine(RBPoints, RBStyle);
        RubberbandFtr := LineLayer.AddFeature(RubberbandFtr, EmptyParam);
      end
      else
      begin
        RubberbandFtr.Parts.RemoveAll;
        RubberbandFtr.Parts.Add(RBPoints);
      end;
      RubberbandFtr.Update(True, EmptyParam); //更新橡皮筋
    end;
  end;
end;

procedure TForm1.Map1DblClick(Sender: TObject);
var
  ft: CMapXFeature;
begin
  //结束绘制
  if (Map1.CurrentTool = DrawLineTool) and (LinePoints.Count > 2) then
  begin
    LinePoints.RemoveAll;
    LineLayer.DeleteFeature(RubberbandFtr);
    RubberbandFtr := nil;
  end
end;

procedure TForm1.Map1ToolUsed(ASender: TObject; ToolNum: Smallint; X1, Y1,
  X2, Y2, Distance: Double; Shift, Ctrl: WordBool;
  var EnableDefault: WordBool);
begin
  //当使用其它工具时，应清除橡皮筋
  if (ToolNum <> DrawLineTool) and (LinePoints.Count > 0) then
  begin
    LinePoints.RemoveAll;
    LineLayer.DeleteFeature(RubberbandFtr);
    RubberbandFtr := nil;
  end;
end;

end.

 创建自定义工具时只能用miToolTypePoint类型，而不能用其它类型。

有了上面的示例，要创建任何自动滚屏操作或业务，就都没有问题了，如可以做自动滚屏的选择工具、各种图元绘制工具等等。