earthmap.pas

想在DELPHI中应用GoogleMap吗

{*******************************************************}
{                                                       }
{       成功助手                                        }
{                                                       }
{       版权所有 (C) 2008 八九软件                      }
{       Email: [e-mail]                      }
{       Web: www.bajiusoft.com                          }   
{                                                       }
{*******************************************************}



unit EarthMap;

interface

uses
  Windows, SysUtils, Messages, Classes, Controls, GraphicEx, ExtCtrls, HTTPSend,
  SyncObjs, Graphics, Math;

const
  WM_MAP = WM_USER + 1001;
type
  TEarthMap = class;
  TMapZoom = 0..17;

  //代理
  TProxy = record
    Proxy: Boolean;
    Host: string;
    Port: string;
  end;

  //地图参数
  PMapParam = ^TMapParam;
  TMapParam = record
    Zoom: Integer;
    x, y: Integer;
  end;

  //下载地图线程
  TGetThread = class(TThread)
  private
    FEarthMap: TEarthMap;
    //任务列表
    FTaskList: TList;
    //读写任务列表锁
    FLock: TCriticalSection;
    //地图文件存放路径
    FMapPath: string;
    //获取地图的URL
    FMapURL: string;
    //代理服务器
    FProxy: TProxy;
    //获取一个任务
    function GetTask(var AMapParam: TMapParam): Boolean;
    //从Google服务器上获取地图
    function GetMap(const AZoom, Ax, Ay: Integer; var AFileName: string): Boolean;
    //设置网络代理
    procedure SetProxy(AValue: TProxy);
  public
    constructor Create;
    destructor Destroy; override;
    //增加一个下载地图任务
    procedure AddTask(AZoom, AX, AY: Integer);
    //清除所有下载地图任务
    procedure ClearAllTask;
    procedure Execute; override;

    //检查文件头是否正确
    function CheckFileHeader(AStream: TStream): Boolean; overload;
    function CheckFileHeader(AFileName: string): Boolean; overload;

    property EarthMap: TEarthMap read FEarthMap write FEarthMap;
    property MapPath: string read FMapPath write FMapPath;
    property MapURL: string read FMapURL write FMapURL;
    property Proxy: TProxy read FProxy write SetProxy;
  end;

  TShowGPS = procedure(Sender: TObject; Longitude, Latitude: Double) of object;
  TMapZoomChange = procedure(Sender: TObject; MapZoom: Integer) of object;
  TEarthMap = class(TWinControl)
  private
    //获取地图线程
    FGetThread: TGetThread;
    //画地图使用的图片
    FImage: TImage;
    //在没有下载地图文件的情况下的默认图片
    FDefMap: TBitmap;
    //地图的放大系数
    FMapZoom: TMapZoom;
    //地图的范围
    FMapRect: TRect;
    //地图和控件窗口的偏移距离
    FMapVector: TPoint;
    //地图文件存放路径
    FMapPath: string;
    //获取地图的URL
    FMapURL: string;
    //代理服务器
    FProxy: TProxy;
    //窗口大小
    FWinWidth, FWinHeight: Integer;
    //上一次鼠标移动的位置
    FOrganMouse: TPoint;
    //显示地图经纬度
    FOnMapGPS: TShowGPS;
    //地图放大系数改变
    FOnMapZoomChange: TMapZoomChange;
    procedure SetMapZoom(AZoom: TMapZoom);
    procedure SetProxy(AProxy: TProxy);
  protected
    //画单个的256*256地图图片
    procedure DrawOneMap(const AZoom, AX, AY: Integer; var ABmp: TBitmap);
    //改变大小
    procedure WMSize(var AMsg: TWMSize); message WM_SIZE;
    //重载此方法主要是为滚动滚轴的时候只触发一次放大、缩小事件
    function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer;
      MousePos: TPoint): Boolean; override;
    //缩小
    function DoMouseWheelDown(Shift: TShiftState; MousePos: TPoint): Boolean; override;
    //放大
    function DoMouseWheelUp(Shift: TShiftState; MousePos: TPoint): Boolean; override;
    //获取最大地图块的大小
    function GetMapCount(AZoom: Integer): Integer;
    //补全整个屏幕的地图
    function StrechMap: Boolean;
    //把显示地图屏幕鼠标转换为地图坐标,其实是鼠标在FImage上的坐标
    procedure CursorToMap(AMouse: TPoint; var x, y: Integer);
    //画单张地图
    procedure WMMap(var AMsg: TMessage); message WM_MAP;
    //鼠标位置
    procedure OmImgMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    //鼠标移动
    procedure OnImgMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);

    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
    procedure CMExit(var Msg: TCMExit); message CM_EXIT;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy;

    //画地图
    procedure DrawMap;
  published
    property MapZoom: TMapZoom read FMapZoom write SetMapZoom default 0;
    property Align;
    property BevelEdges;
    property BevelInner;
    property BevelKind;
    property BevelOuter;
    property BevelWidth;
    property Color;
    property OnMapGPS: TShowGPS read FOnMapGPS write FOnMapGPS;
    property OnMapZoomChange: TMapZoomChange read FOnMapZoomChange write FOnMapZoomChange;
    property Proxy: TProxy read FProxy write SetProxy;
  end;

//由放大系数得到地图块数
function GetMaxMapCount(Zoom: Integer): Integer;
//地图上的象素转为经纬度
procedure PelsToLongLat(Zoom: Integer; xPels, yPels: Integer; var dLongitude, dLatitude: Double);
//经纬度转为地图上的象素，这个转为的结果是地图最下面的点为坐标原点
procedure LongLatToPels(Zoom: Integer; dLongitude, dLatitude: Double; var xPels, yPels: Integer);

procedure Register;

implementation


const
  CMapFile = '%d-%d-%d.gif';           //地图文件存放的文件名命名规则  Zomm-x-y
  CMapWidth = 256;                 //Google地图单个地图为 256*256 的GIF文件
  CMapHeight = 256;
  CMapURL = 'http://servicetile.mapabc.com/googlechina/maptile?v=cn1&hl=zh-CN&x=%d&y=%d&zoom=%d&s=Galile';
  //CMapURL = ' http://mt3.google.cn/googlechina/maptile?v=cn1&hl=zh-CN&x=%d&y=%d&zoom=%d&s=Galileo';

function GetMaxMapCount(Zoom: Integer): Integer;
begin
  if Zoom <= 0 then
  begin
    Result := 1;
  end
  else
  begin
    Result := 2 shl (Zoom - 1);
  end;
end;

procedure LongLatToPels(Zoom: Integer; dLongitude,
  dLatitude: Double; var xPels, yPels: Integer);
var
  iMapCount: Integer;
  dOnePels: Double;
  function DecToMerc(Latitude: Double): Double;
  begin
    Result := Ln(Tan(Pi/4 + Latitude/2))
  end;
begin
  iMapCount := GetMaxMapCount(Zoom);
  xPels := Floor(256*iMapCount*(dLongitude+180) / 360);
  //得到地图归一后纬度所在的坐标值
  dOnePels := DecToMerc(dLatitude*Pi/180) / 2 / Pi * 256 + 128;
  yPels := Floor(dOnePels * iMapCount);
end;

procedure PelsToLongLat(Zoom, xPels, yPels: Integer;
  var dLongitude, dLatitude: Double);
var
  iMapCount: Integer;
  function MercToDec(Latitude: Double): Double;
  begin
    Result := (ArcTan(Exp(Latitude))*2) - (Pi/2);
  end;
begin
  iMapCount := GetMaxMapCount(Zoom);
  dLongitude := (360/iMapCount) * (xPels/256) - 180;
  //得到地图归一后的坐标值
  dLatitude := ((iMapCount - yPels div 256)*256-(yPels mod 256))/iMapCount - 128;
  dLatitude := ((MercToDec(((dLatitude/256)*Pi)*2))*180)/Pi;
end;

procedure Register;
begin
  RegisterComponents('Fan', [TEarthMap]);
end;

{ TGetThread }

procedure TGetThread.AddTask(AZoom, AX, AY: Integer);
var
  MapParam: PMapParam;
begin
  New(MapParam);
  MapParam.Zoom := AZoom;
  MapParam.x := AX;
  MapParam.y := AY;
  FLock.Enter;
  try
    FTaskList.Add(MapParam);
    if Suspended then
      Resume;    //唤醒线程
  finally
    FLock.Leave;
  end;
end;

function TGetThread.CheckFileHeader(AStream: TStream): Boolean;
var
  sHeader: string[4];
  sFileType: string;
  SrcPos: Int64;
begin
  Result := False;
  if (not Assigned(AStream)) or (AStream.Size < 4) then Exit; 
  SrcPos := AStream.Position;
  AStream.Position := 0;
  try
    AStream.Read(sHeader[1], 4);
    sFileType := sHeader[1] + sHeader[2] + sHeader[3];
    if not SameText('GIF', sFileType) then
    begin
      sFileType := sHeader[2] + sHeader[3] + sHeader[4];
      if SameText('PNG', sFileType) then
        Result := True
      else
        Result := False;
    end
    else
      Result := True;
  finally
    AStream.Position := SrcPos;
  end;
end;

function TGetThread.CheckFileHeader(AFileName: string): Boolean;
var
  AStream: TFileStream;
begin
  Result := False;
  AStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
  try
    Result := CheckFileHeader(AStream);
  finally
    AStream.Free;
  end;
end;

procedure TGetThread.ClearAllTask;
var
  i: Integer;
begin
  FLock.Enter;
  try
    for i := FTaskList.Count - 1 downto 0 do
    begin
      if FTaskList.Items[i] <> nil then
        Dispose(PMapParam(FTaskList.Items[i]));
    end;
    FTaskList.Clear;
  finally
    FLock.Leave;
  end;
end;

constructor TGetThread.Create;
begin
  inherited Create(True);   //先创建一个挂起的线程
  FTaskList := TList.Create;
  FLock := TCriticalSection.Create;
  FreeOnTerminate := False;
end;

destructor TGetThread.Destroy;
begin
  ClearAllTask;
  FTaskList.Free;
  FLock.Free;
  inherited;
end;

procedure TGetThread.Execute;
var
  MapParam: TMapParam;
  FileName: string;
begin
  inherited;
  repeat
    if GetTask(MapParam) then
    begin
      if GetMap(MapParam.Zoom, MapParam.x, MapParam.y, FileName) then
        PostMessage(FEarthMap.Handle, WM_MAP, Integer(FileName), 0);
    end
    else
      Suspend;
  until Terminated;
end;

function TGetThread.GetMap(const AZoom, Ax, Ay: Integer;
  var AFileName: string): Boolean;
var
  sUrl: string;
  mmStream: TMemoryStream;
  sFilePath: string;
begin
  //Sleep(1000);
  Result := False;
  sFilePath := FMapPath + '\';
  if not DirectoryExists(sFilePath) then
    CreateDir(sFilePath);
  mmStream := TMemoryStream.Create;
  try
    AFileName := Format(CMapFile, [AZoom, Ax, Ay]);
    AFileName := sFilePath + AFileName;
    if not FileExists(AFileName) then
    begin
      sUrl := Format(CMapURL, [Ax, Ay, 17-AZoom]);   //Google中0表示放大到最大，而这里0表示最小
      if FProxy.Proxy then
        HttpGetBinary(sUrl, mmStream, FProxy.Host, FProxy.Port)
      else
        HttpGetBinary(sUrl, mmStream);
      if (mmStream.Size > 0) and CheckFileHeader(mmStream) then
      begin
        mmStream.SaveToFile(AFileName);
      end;
    end;
    Result := True;
  finally
    mmStream.Free;
  end;
end;

function TGetThread.GetTask(var AMapParam: TMapParam): Boolean;
begin
  Result := False;
  FLock.Enter;
  try
    if FTaskList.Count > 0 then
    begin
      AMapParam.Zoom := PMapParam(FTaskList.Items[0]).Zoom;
      AMapParam.x := PMapParam(FTaskList.Items[0]).x;
      AMapParam.y := PMapParam(FTaskList.Items[0]).y;
      Dispose(FTaskList.Items[0]);
      FTaskList.Delete(0);
      Result := True;
    end;
  finally
    FLock.Leave;
  end;
end;

procedure TGetThread.SetProxy(AValue: TProxy);
begin
  FProxy.Proxy := AValue.Proxy;
  FProxy.Host := AValue.Host;
  FProxy.Port := AValue.Port;
end;

{ TEarthMap }

procedure TEarthMap.CMEnter(var Message: TCMEnter);
begin
  inherited;
  SetFocus;
end;