百度地图切片源码

开发工具：lazarus

算法仍有问题。

unit unit_main;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  LCLType, LCLIntf, ExtCtrls, IntfGraphics, GraphType, ComCtrls, regexpr,
  Math,BGRABitmap, BGRABitmapTypes, BCImageButton;

type

  { TFormMain }

  TFormMain = class(TForm)
    Button2: TButton;
    ButtonBrowsePic: TButton;
    Button4: TButton;
    BtnCut: TButton;
    Button6: TButton;
    BtnPreview: TButton;
    CombxSrcPic: TComboBox;
    CombxMin: TComboBox;
    CombxMax: TComboBox;
    EditPmzbY: TEdit;
    EditPmzbX: TEdit;
    EditClipBoard: TEdit;
    EditJD: TEdit;
    EditWD: TEdit;
    EditSrcPic: TEdit;
    EditDstPath: TEdit;
    GroupBox1: TGroupBox;
    Image1: TImage;
    Image2: TImage;
    Image3: TImage;
    Image0: TImage;
    ImageAll: TImage;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    LabelLink: TLabel;
    Memo1: TMemo;
    MemoMap: TMemo;
    OpenDialog1: TOpenDialog;
    Panel1: TPanel;
    pbar: TProgressBar;
    rbPng: TRadioButton;
    rbJpg: TRadioButton;
    SDirDiog: TSelectDirectoryDialog;
    procedure ButtonBrowsePicClick(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure BtnCutClick(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure BtnPreviewClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure LabelLinkClick(Sender: TObject);
  private
    { private declarations }

    //AImage: TLazIntfImage;
    //lRawImage: TRawImage;
    BGRABmpAll, BGRAImgText: TBGRABitmap;
    procedure SaveToPng(bmp: TBitmap; PngFileName: String);
    // 加载图片文件
    procedure loadPic;
  public
    tukuaiCenterX, tukuaiCenterY: integer; // 中心图块坐标
    procedure ShowForm(FormClass: TFormClass);
    { public declarations }
  end;


var
  FormMain: TFormMain;

implementation

uses unit_map, Unit_PicShow;

{$R *.lfm}

{ TFormMain }

procedure TFormMain.ShowForm(FormClass: TFormClass);
begin
  with FormClass.Create(self) do
    try
      ShowModal;
    finally
      Free;
    end;
end;

procedure TFormMain.SaveToPng(bmp: TBitmap; PngFileName: String);
var
  png : TPortableNetworkGraphic;
begin
  png := TPortableNetworkGraphic.Create;
  try
    png.Assign(bmp);
    png.SaveToFile(PngFileName);
  finally
    png.Free;
  end;
end;

// 加载图片文件
procedure TFormMain.loadPic;
var
  BGRABmpPart, BGRAStretch: TBGRABitmap;
  i,j: Integer;
  fn,fnJpg,fnPng: string;
  Rect:TRect;
begin
  // 加载完整图片
  BGRABmpAll := TBGRABitmap.Create(utf8ToSys(EditSrcPic.Text));
  ImageAll.Picture.LoadFromFile((EditSrcPic.Text));

  // 显示打开图片的宽度及高度
  memo1.Lines.Add('图片宽度：' + intToStr(BGRABmpAll.Width) + '; 图片高度：' + intToStr(BGRABmpAll.Height));

  // 完整预览选择的图片
  BGRAStretch := BGRABmpAll.Resample(Panel1.Width, Panel1.Height) as TBGRABitmap;


  // 显示左上角图片 ---------
  //Rect.TopLeft:=Point(0,0);
  //Rect.BottomRight:=Point(256, 256);
  //BGRABmpAll.DrawPart(Rect, Image0.Canvas, 0, 0, true);
  // 显示左上角图片 =========

  //
  BGRABmpPart := TBGRABitmap.Create(256, 256);
  for i := 0 to 1 do
    for j := 0 to 1 do
      begin
        Rect.TopLeft:=Point(256 * i, 256 * j);
        Rect.BottomRight:=Point(256 * (i + 1), 256 * (j + 1));
        //BGRABmpPart.FillRect(0, 0, 256, 256, BGRA(0,0,0,0), dmset);
        BGRABmpAll.DrawPart(Rect, BGRABmpPart.Canvas, 0, 0, true);
        if (i = 0) and (j = 0) then
        begin
          BGRABmpAll.DrawPart(Rect, Image0.Canvas, 0, 0, true);
          memo1.Lines.Add('第1样张图片显示完毕，图片加黑边为正常。');
        end;

        fnPng := extractFilePath(paramStr(0)) + intToStr(i) + '_' + intToStr(j) + '.png';
        BGRABmpPart.SaveToFile(fnPng);
        memo1.Lines.Add('测试图片存储为：' + sysToUtf8(fnPng));

        fnJpg := extractFilePath(paramStr(0)) + intToStr(i) + '_' + intToStr(j) + '.jpg';
        BGRABmpPart.SaveToFile(fnJpg);
        memo1.Lines.Add('测试图片存储为：' + sysToUtf8(fnJpg));

      end;

  memo1.Lines.Add('测试图片处理完毕。');

  BGRABmpPart.Free;
  BGRAStretch.Free;


end;

// 源图片定位按钮
procedure TFormMain.ButtonBrowsePicClick(Sender: TObject);
var
  fn: string;
begin
  memo1.Clear;

  OpenDialog1.Filter:='jpeg文件|*.jpg|png文件|*.png';
  if OpenDialog1.Execute then
    EditSrcPic.Text := OpenDialog1.FileName;

  fn := trim(EditSrcPic.Text);
  if fn = '' then
    exit;

  loadPic;

  BtnCut.Enabled := true;
  BtnPreview.Enabled := true;
end;

// 目标路径
procedure TFormMain.Button4Click(Sender: TObject);
begin
  if SDirDiog.Execute then
  begin
    EditDstPath.Text := SDirDiog.FileName;
  end;
end;

// 开始切图按钮
procedure TFormMain.BtnCutClick(Sender: TObject);
var
  iGradeMin, iGradeMax, iGradeDef, xiangsuX, xiangsuY: integer;
  picSrc, destPath, destFn, f: string;
  srcPicStrechW, srcPicStrechH, rectBotmRighX, rectBotmRighY, srcTileWidth,
  tilCoordX, tilCoordY, iGradeCur, i, j, Vtimes, Htimes: integer;
  strList: TStringList;
  Rect:TRect;
  BGRAStretch, BGRABmpPart: TBGRABitmap;
  clrText: TBGRAPixel;
begin
  memo1.Clear;


  picSrc := trim(EditSrcPic.Text);
  if picSrc = '' then
  begin
    showmessage('请定位待处理图片。');
    exit;
  end;

  destPath := EditDstPath.Text;
  if destPath = '' then
  begin
    showmessage('请定义输出路径');
    exit;
  end;

  // 创建 tiles 目录 ----
  destPath := trim(EditDstPath.Text) + '\tiles';
  if not DirectoryExists(destPath) then
     CreateDir(destPath);
  // 创建 tiles 目录 ====

  iGradeMin := strToInt(CombxMin.Text); // 最小级别
  iGradeMax := strToInt(CombxMax.Text);  // 最大级别
  iGradeDef := strToInt(CombxSrcPic.Text);  // 原图所在的级别

  pbar.Min := 0;

  //生成 map.html ------------------------------------
  strList:= TStringList.Create;
  strList.LoadFromFile(ExtractFilePath(ParamStr(0)) + '\t.html');

  strList.Text := stringReplace(strList.Text, '#minZoom#', intToStr(iGradeMin), [rfReplaceAll]);
  strList.Text := stringReplace(strList.Text, '#maxZoom#', intToStr(iGradeMax), [rfReplaceAll]);

  strList.Text := stringReplace(strList.Text, '#center_x#', EditJD.Text, [rfReplaceAll]);
  strList.Text := stringReplace(strList.Text, '#center_y#', EditWD.Text, [rfReplaceAll]);

  strList.Text := stringReplace(strList.Text, '#defaultZoom#', intToStr(iGradeDef), [rfReplaceAll]);

  f := trim(EditDstPath.Text) + '\map.html';
  DeleteFile(f);
  strList.SaveToFile(f);
  strList.Free;
  //生成 map.html ====================================

  for iGradeCur := iGradeMin to iGradeMax do
  //for l := 6 to 8 do
  begin
    // 计算中心像素坐标
    // 像素坐标 = |平面坐标 × 2 iGradeCur - 18| (iGradeCur - 18是2的指数)
    xiangsuX := trunc(abs(strToFloat(EditPmzbX.Text) * power(2, iGradeCur - 18)));
    xiangsuY := trunc(abs(strToFloat(EditPmzbY.Text) * power(2, iGradeCur - 18)));

    memo1.Lines.Add('---------------------------------------');
    memo1.Lines.Add('处理级别：' + intToStr(iGradeCur));
    memo1.Lines.Add('中心像素坐标：' + intToStr(xiangsuX) + '-' + intToStr(xiangsuY));

    // 计算中心图块坐标
    // 图块坐标 = |像素坐标 ÷ 256|
    tukuaiCenterX := trunc(xiangsuX / 256);
    tukuaiCenterY := trunc(xiangsuY / 256);
    memo1.Lines.Add('中心图块坐标：' + intToStr(tukuaiCenterX) + '-' + intToStr(tukuaiCenterY));

    // 生成当前级别目录
    destPath := trim(EditDstPath.Text) + '\tiles\' + intToStr(iGradeCur);
    if not DirectoryExists(destPath) then
      CreateDir(destPath);

    // widthSingle := 256 div iGradeCur * gradeDef;   // 源图切割后，单个图片的边长

    // srcPicStrechW := trunc(abs(BGRABmpAll.Width * power(2, iGradeDef - iGradeCur))); // 计算某级别下，变形后源图宽度
    // srcPicStrechH := trunc(abs(BGRABmpAll.Height * power(2, iGradeDef - iGradeCur))); // 计算某级别下，变形后源图高度
    //memo1.Lines.Add('变形w:' + intToStr(srcPicStrechW));
    //memo1.Lines.Add('变形H:' + intToStr(srcPicStrechH));

    srcTileWidth := trunc(abs(256 * power(2, iGradeDef - iGradeCur))); // 计算源瓦片宽度

    memo1.Lines.Add('单个源瓦片宽度:' + intToStr(srcTileWidth));
    if srcTileWidth <=0 then
    begin
      memo1.Lines.Add('瓦片宽度不可小于1。');
      exit;
    end;

    // 创建宽度为  srcTileWidth 的 BGRABitmap，临时存储未变形的切片
    // BGRABmpPart := TBGRABitmap.Create(srcTileWidth, srcTileWidth);
    pbar.Max := iGradeCur - 1;

    // 横向分割块数
    if BGRABmpAll.Width mod srcTileWidth = 0 then
      Htimes := BGRABmpAll.Width div srcTileWidth
    else
      Htimes := BGRABmpAll.Width div srcTileWidth + 1;

    // 纵向分割块数
    if BGRABmpAll.Height mod srcTileWidth = 0 then
      Vtimes := BGRABmpAll.Height div srcTileWidth
    else
      Vtimes := BGRABmpAll.Height div srcTileWidth + 1;

    memo1.Lines.Add('Htimes:' + intToStr(Htimes));
    memo1.Lines.Add('Vtimes:' + intToStr(Vtimes));

    for i := 1 to Htimes do // 横向循环
    begin
      pbar.Position:=i;
      for j := 1 to Vtimes do  // 纵向循环
      begin
        // 创建宽度为  srcTileWidth 的 BGRABitmap，复制BGRABmpPart后用于变形
        BGRAStretch := TBGRABitmap.Create(srcTileWidth, srcTileWidth);
        // 创建宽度为  srcTileWidth 的 BGRABitmap，临时存储未变形的切片
        BGRABmpPart := TBGRABitmap.Create(srcTileWidth, srcTileWidth);

        // 定义待复制的源瓦片 Rect 参数 ----------------
        Rect.TopLeft:=Point(srcTileWidth * (i -  1), srcTileWidth * (j - 1));

        // 右下角坐标，如果超出变形后原图大小，会出错
        // Rect.BottomRight:=Point(srcTileWidth * i, srcTileWidth * j);
        // srcPicStrechW  rectBotmRighX, rectBotmRighY

        //取得 rect 右下角横坐标位置
        if srcTileWidth * i <= BGRABmpAll.Width then
          rectBotmRighX := srcTileWidth * i
        else
          rectBotmRighX := BGRABmpAll.Width; // srcPicStrechW 变形后原图宽度

        //取得 rect 右下角纵坐标位置
        if srcTileWidth * j <= BGRABmpAll.Height then
          rectBotmRighY := srcTileWidth * j
        else
          rectBotmRighY := BGRABmpAll.Height; // srcPicStrechW 变形后原图宽度

        Rect.BottomRight:=Point(rectBotmRighX, rectBotmRighY);
        // 定义待复制的源瓦片 Rect 参数 ================

        // 切出指定位置、宽度为 srcTileWidth 的图形
        BGRABmpAll.DrawPart(Rect, BGRABmpPart.Canvas, 0, 0, true);
        // 变形为边长256的图形
        BGRAStretch := BGRABmpPart.Resample(256, 256) as TBGRABitmap;

        // BGRAStretch.TextOutAngle(100, 100, -450, 'Hello world',c,);
        BGRAStretch.FontHeight := 50;
        BGRAStretch.FontAntialias := true;
        clrText := ColorToBGRA(ColorToRGB(clYellow));  // 字体颜色
        BGRAStretch.TextOutAngle(0, 0, 0, intToStr(iGradeCur) + ':' + intToStr(i) + ',' + intToStr(j), clrText, taLeftJustify);
        clrText := ColorToBGRA(ColorToRGB(clBtnText)); // 为产生阴影，换一种字体颜色
        BGRAStretch.TextOutAngle(1, 1, 0, intToStr(iGradeCur) + ':' + intToStr(i) + ',' + intToStr(j), clrText, taLeftJustify);

        //BGRAStretch.SetPixel(30,5, cText);

        //destFn := destPath + '\tile' + intToStr(tukuaiCenterX + i - iGradeCur div 2) + '_' + intToStr(tukuaiCenterY - (j - iGradeCur div 2)) + '.jpg';
        //destFn := destPath + '\tile' + intToStr(tukuaiCenterX - Htimes div 2 + i - 1) + '_' + intToStr(tukuaiCenterY + Vtimes div 2 - j) + '.jpg';

        tilCoordX := tukuaiCenterX - Htimes div 2 + i - 1;
        tilCoordY := tukuaiCenterY + (Vtimes + 1) div 2 - j;

        BGRAStretch.FontHeight := 30;
        clrText := ColorToBGRA(ColorToRGB(clYellow));  // 字体颜色
        BGRAStretch.TextOutAngle(10, 160, 0, intToStr(tilCoordX) + ',' + intToStr(tilCoordY), clrText, taLeftJustify);
        clrText := ColorToBGRA(ColorToRGB(clBtnText)); // 为产生阴影，换一种字体颜色
        BGRAStretch.TextOutAngle(11, 161, 0, intToStr(tilCoordX) + ',' + intToStr(tilCoordY), clrText, taLeftJustify);

        if (tilCoordX = tukuaiCenterX) and (tilCoordY = tukuaiCenterY) then // 中心图块
        begin
          BGRAStretch.FontHeight := 60;
          clrText := ColorToBGRA(ColorToRGB(clWhite));  // 字体颜色
          BGRAStretch.TextOutAngle(0, 10, 0, '中心图块', clrText, taLeftJustify);
          clrText := ColorToBGRA(ColorToRGB(clBtnText)); // 为产生阴影，换一种字体颜色
          BGRAStretch.TextOutAngle(1, 11, 0, '中心图块', clrText, taLeftJustify);
        end;

        destFn := destPath + '\tile' + intToStr(tilCoordX) + '_' + intToStr(tilCoordY) + '.jpg';


        memo1.Lines.Add(destFn);
        BGRAStretch.SaveToFile(destFn);

        BGRAStretch.Free;
        BGRABmpPart.Free;

      end;
    end;
    // BGRABmpPart.Free;
    pbar.Position:=0;
  end;

  memo1.Lines.Add('');
  memo1.Lines.Add('切片完成。');
  //bitA.Free;
  //bitTile.Free;
end;

// 获取经纬度
procedure TFormMain.Button6Click(Sender: TObject);
var
  s,jwd_x,jwd_y: string;
  RegexObj: TRegExpr;
  i, xiangsuX, xiangsuY,
  iYutuJibie // 当前级别
  : integer;
  //xiangsuX, xiangsuY: float;
begin
  memo1.Clear;

  if trim(CombxSrcPic.Text) = '' then
  begin
    showmessage('请确定当前级别。');
    exit;
  end;

  iYutuJibie := strToInt(CombxSrcPic.Text);

  if (iYutuJibie > 18) or (iYutuJibie < 1) then
  begin
    showmessage('级别范围1——18.');
    exit;
  end;

  memoMap.Lines.SaveToFile(ExtractFilePath(ParamStr(0)) + 'locamap');

  FormMap.ShowModal;

  // 从剪贴板获得经纬度  格式: jwd:116.716754,40.049897;pmzb:12992991,4845443.71
  EditClipBoard.PasteFromClipboard;
  s := EditClipBoard.Text;
  memo1.Lines.Add('点击的经纬度、平面坐标');
  memo1.Lines.Add(s);
  memo1.Lines.Add('');

  RegexObj := TRegExpr.Create;
  RegexObj.Expression := '\d+\.*\d+';
  RegexObj.ModifierI := true;

  // 取得经度 纬度 平面横坐标 平面纵坐标
  i := 0;
  if RegexObj.Exec(s) then
  repeat
    if i = 0 then
      EditJD.Text := RegexObj.Match[0]   // 经度
    else if i = 1 then
      EditWD.Text := RegexObj.Match[0]   // 纬度
    else if i = 2 then
      EditPmzbX.Text := RegexObj.Match[0]  // 平面坐标 x
    else if i = 3 then
      EditPmzbY.Text := RegexObj.Match[0]; // 平面坐标 y

    i := i + 1;
  until not RegexObj.ExecNext;

  RegexObj.Free;

  // 计算中心像素坐标
  // 像素坐标 = |平面坐标 × 2 iGradeCur - 18| (iGradeCur - 18是2的指数)
  xiangsuX := trunc(abs(strToFloat(EditPmzbX.Text) * power(2, iYutuJibie - 18)));
  xiangsuY := trunc(abs(strToFloat(EditPmzbY.Text) * power(2, iYutuJibie - 18)));
  memo1.Lines.Add('中心像素坐标：' + intToStr(xiangsuX) + '-' + intToStr(xiangsuY));

  // 计算图块坐标
  // 图块坐标 = |像素坐标 ÷ 256|
  tukuaiCenterX := trunc(xiangsuX / 256);
  tukuaiCenterY := trunc(xiangsuY / 256);
  memo1.Lines.Add('中心图块坐标：'  + intToStr(tukuaiCenterX) + '-' + intToStr(tukuaiCenterY));

end;

procedure TFormMain.BtnPreviewClick(Sender: TObject);
begin
  FormPicShow.ShowModal;
end;

procedure TFormMain.FormCreate(Sender: TObject);
begin
  LabelLink.Font.Style:= [fsUnderline];
  LabelLink.Cursor:= crHandPoint;

  EditSrcPic.Text := sysToUtf8(ExtractFilePath(paramStr(0)) + 'map.jpg');

  //loadPic;
end;

procedure TFormMain.FormDestroy(Sender: TObject);
begin
  BGRABmpAll.Free;
end;

procedure TFormMain.LabelLinkClick(Sender: TObject);
begin
  OpenURL('http://api.map.baidu.com/lbsapi/getpoint/index.html');
end;

end.