百度地图切片源码

开发工具：lazarus

算法仍有问题。

unit unit_main;{$mode objfpc}{$H+}interfaceuses  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;implementationuses 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, '#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    memo1.Lines.Add('---------------------------------------');    memo1.Lines.Add('处理级别：' + intToStr(iGradeCur));    memo1.Lines.Add('中心像素坐标：' + intToStr(xiangsuX) + '-' + intToStr(xiangsuY));    // 生成当前级别目录    destPath := trim(EditDstPath.Text) + '\tiles\' + intToStr(iGradeCur);    if not DirectoryExists(destPath) then      CreateDir(destPath);    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));        // 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.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;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.