{*******************************************************}
{                                                       }
{       成功助手                                        }
{                                                       }
{       版權(quán)所有 (C) 2008 八九軟件                      }
{       Email: fansheng_hx@163.com                      }
{       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;

  //地圖參數(shù)
  PMapParam = ^TMapParam;
  TMapParam = record
    Zoom: Integer;
    x, y: Integer;
  end;

  //下載地圖線程
  TGetThread = class(TThread)
  private
    FEarthMap: TEarthMap;
    //任務(wù)列表
    FTaskList: TList;
    //讀寫任務(wù)列表鎖
    FLock: TCriticalSection;
    //地圖文件存放路徑
    FMapPath: string;
    //獲取地圖的URL
    FMapURL: string;
    //代理服務(wù)器
    FProxy: TProxy;
    //獲取一個(gè)任務(wù)
    function GetTask(var AMapParam: TMapParam): Boolean;
    //從Google服務(wù)器上獲取地圖
    function GetMap(const AZoom, Ax, Ay: Integer; var AFileName: string): Boolean;
    //設(shè)置網(wǎng)絡(luò)代理
    procedure SetProxy(AValue: TProxy);
  public
    constructor Create;
    destructor Destroy; override;
    //增加一個(gè)下載地圖任務(wù)
    procedure AddTask(AZoom, AX, AY: Integer);
    //清除所有下載地圖任務(wù)
    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;
    //在沒有下載地圖文件的情況下的默認(rèn)圖片
    FDefMap: TBitmap;
    //地圖的放大系數(shù)
    FMapZoom: TMapZoom;
    //地圖的范圍
    FMapRect: TRect;
    //地圖和控件窗口的偏移距離
    FMapVector: TPoint;
    //地圖文件存放路徑
    FMapPath: string;
    //獲取地圖的URL
    FMapURL: string;
    //代理服務(wù)器
    FProxy: TProxy;
    //窗口大小
    FWinWidth, FWinHeight: Integer;
    //上一次鼠標(biāo)移動(dòng)的位置
    FOrganMouse: TPoint;
    //顯示地圖經(jīng)緯度
    FOnMapGPS: TShowGPS;
    //地圖放大系數(shù)改變
    FOnMapZoomChange: TMapZoomChange;
    procedure SetMapZoom(AZoom: TMapZoom);
    procedure SetProxy(AProxy: TProxy);
  protected
    //畫單個(gè)的256*256地圖圖片
    procedure DrawOneMap(const AZoom, AX, AY: Integer; var ABmp: TBitmap);
    //改變大小
    procedure WMSize(var AMsg: TWMSize); message WM_SIZE;
    //重載此方法主要是為滾動(dòng)滾軸的時(shí)候只觸發(fā)一次放大、縮小事件
    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;
    //補(bǔ)全整個(gè)屏幕的地圖
    function StrechMap: Boolean;
    //把顯示地圖屏幕鼠標(biāo)轉(zhuǎn)換為地圖坐標(biāo),其實(shí)是鼠標(biāo)在FImage上的坐標(biāo)
    procedure CursorToMap(AMouse: TPoint; var x, y: Integer);
    //畫單張地圖
    procedure WMMap(var AMsg: TMessage); message WM_MAP;
    //鼠標(biāo)位置
    procedure OmImgMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    //鼠標(biāo)移動(dòng)
    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;

//由放大系數(shù)得到地圖塊數(shù)
function GetMaxMapCount(Zoom: Integer): Integer;
//地圖上的象素轉(zhuǎn)為經(jīng)緯度
procedure PelsToLongLat(Zoom: Integer; xPels, yPels: Integer; var dLongitude, dLatitude: Double);
//經(jīng)緯度轉(zhuǎn)為地圖上的象素，這個(gè)轉(zhuǎn)為的結(jié)果是地圖最下面的點(diǎn)為坐標(biāo)原點(diǎn)
procedure LongLatToPels(Zoom: Integer; dLongitude, dLatitude: Double; var xPels, yPels: Integer);

procedure Register;

implementation


const
  CMapFile = '%d-%d-%d.gif';           //地圖文件存放的文件名命名規(guī)則  Zomm-x-y
  CMapWidth = 256;                 //Google地圖單個(gè)地圖為 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);
  //得到地圖歸一后緯度所在的坐標(biāo)值
  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;
  //得到地圖歸一后的坐標(biāo)值
  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);   //先創(chuàng)建一個(gè)掛起的線程
  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;