mapx.~pas

Delphi + MapX程序框架(地图)源码程序

unit MapX;

interface

uses MapXLib_TLB, Classes, Controls, Dialogs, SysUtils, Forms, Variants, Printers,
  RulerFrm, AreaFrm, InforFrm, Graphics, Messages, CommCtrl, Windows;

type
  TMapX = class;

  TMapXToolType = (
    mttPointSelectTool=100, mttRadiusSelectTool=101, mttRectSelectTool=102,
    mttPolygonSelectTool=103, mttMultiRadiusSelectTool=104, mttMultiRectSelectTool=105,
    mttMultiPolygonSelectTool=106, mttInforTool=107, mttRulerTool=108, mttAreaTool=109,
    mttLabelTool=110,
    mttArrowTool=1000, mttPanTool=1001, mttZoomInTool=1003, mttZoomOutTool=1004
    );

  //所有工具的基类
  TMapXToolObject = class
  private
    FMapX: TMapX;
    FToolType: TMapXToolType;
  public
    constructor Create(const Sender: TMapX); virtual;
    //执行工具
    procedure Execute; virtual; abstract;
  end;

  //所有选择工具的基类，在Execute方法中判断图层是否可选择
  TMapXSelectToolObject = class(TMapXToolObject)
  private
    //能否被使用
    FEnable: Boolean;
    //选择对象结果,由具体的工具实现
    FSelection: CMapxFeatures;
  public
    procedure Execute; override;
  end;

  //所有跟点选有关工具的基类，在Execute方法中获得选择对象
  TMapXPointSelectToolObject = class(TMapXSelectToolObject)
  public
    procedure Execute(X1, Y1: Double); overload; virtual;
  end;

  //点选择工具
  TPointSelectTool = class(TMapXPointSelectToolObject)
  public
    constructor Create(const Sender: TMapX); override;
    procedure Execute(X1, Y1: Double; Shift, Ctrl: WordBool); overload;
  end;

  //圆选择工具
  TRadiusSelectTool = class(TMapXSelectToolObject)
  public
    constructor Create(const Sender: TMapX); override;
    procedure Execute(X1, Y1, Distance: Double; Shift, Ctrl: WordBool); overload;
  end;

  //矩形选择工具
  TRectSelectTool = class(TMapXSelectToolObject)
  public
    constructor Create(const Sender: TMapX); override;
    procedure Execute(X1, Y1, X2, Y2: Double; Shift, Ctrl: WordBool); overload;
  end;

  //多边形选择工具
  TPolygonSelectTool = class(TMapXSelectToolObject)
  public
    constructor Create(const Sender: TMapX); override;
    procedure Execute(const Points: IDispatch; Shift, Ctrl: WordBool); overload;
  end;

  TRulerMode = (rmFinished,rmProcessing);
  TMouseMode = (mmDown,mmMove);
  //距离丈量工具
  TRulerTool = class(TMapXToolObject)
  private
    FfrmRuler: TfrmRuler;
    FXDown, FYDown: Double;    //记录鼠标按下的地图坐标
    FXMove, FYMove: Double;    //记录鼠标移到的地图坐标
    FRulerMode : TRulerMode;     //记录标尺的模式是处于进行状态还是完成状态
    FRuleCurrDistance: Double;   //记录当前两点之间的距离
    FRulePastDistance: Double;  //记录已经经过的距离距离
  public
    constructor Create(const Sender: TMapX); override;
    destructor Destroy; override;
    procedure Execute(X, Y: Integer; Button: TMouseButton; Mode: TMouseMode); overload;
  end;

  //面积丈量工具
  TAreaTool = class(TMapXToolObject)
  private
    FGirth: Double;   //多边行：周长-首尾点长度
    FArea: Double;
    FfrmArea: TfrmArea;
  public
    constructor Create(const Sender: TMapX); override;
    destructor Destroy; override;
    procedure Execute(const Points: IDispatch); overload;
  end;

  //对象信息显示工具
  TInforTool = class(TMapXPointSelectToolObject)
  private
    FfrmInfor: TfrmInfor;
  public
    constructor Create(const Sender: TMapX); override;
    destructor Destroy; override;
    procedure Execute(X1, Y1: Double); override;
  end;
  
  //对象标注工具
  TLabelTool = class(TMapXPointSelectToolObject)
  public
    constructor Create(const Sender: TMapX); override;
    procedure Execute(X1, Y1: Double); override;
  end;

  { 所有地图编辑工具的基类 
  TEditToolObject = class(TToolObject)
  private
    FEditable: Boolean;
    FTimer: TTimer;
  public
    constructor Create(const Sender: TMapX); override;
    procedure Activate; override;
    procedure OnTimer(Sender: TObject); virtual; abstract;
    destructor Destroy; override;
    //当前图层是否可编辑，在改变当前图层时获得
    //  详见MapXCurrentLyrChanged函数
    property Editable: Boolean read FEditable write FEditable;
    property Timer: TTimer read FTimer write FTimer;
  end;
  }
  { 增加点对象工具 
  TAddPointTool = class(TEditToolObject)
  public
    constructor Create(const Sender: TMapX); override;
    procedure Execute(X1, Y1: Double); overload;
  end;
  }
  { 增加多边线工具 
  TAddPolyLineTool = class(TEditToolObject)
  private
    procedure OnTimer(Sender: TObject); override;
  public
    constructor Create(const Sender: TMapX); override;
    procedure Execute(const Points: IDispatch); overload;
  end;
  }
  { 增加多边形工具 
  TAddPolygonTool = class(TEditToolObject)
  public
    constructor Create(const Sender: TMapX); override;
    procedure Execute(const Points: IDispatch); overload;
  end;
  }
  TMapXThemeType = (mttRanged, mttBar, mttPie, mttGradSymbol, mttDotDensity,
    mttIndividualValue);
  //专题图
  TMapXTheme = class(TObject)
  private
    FMapX: TMapX;
    FName: string;
    //地图上的对象ID集合
    FFeatureIDList: TStringList;
    //数据库表名
    FDBTableName: string;
    //表中索引字段名
    FIDFieldName: string;
    //表中数据字段名
    FDataFieldName: string;
    //专题图类型
    FThemeType: TMapXThemeType;
  public
    constructor Create(const Sender: TMapX); virtual;
    destructor Destroy; override;
    procedure LoadFromStream(AStream: TStream);
    procedure SaveToStream(var Stream);
    procedure CreateLayerTheme(ALayer: string; FeatureIDs: TStringList = nil);
    property MapX: TMapX read FMapX;
  end;

  { 按Tab表字段搜索对象的种类:
    stExact:        精确匹配
    stLeftDim:      从左边起匹配
    stRightDim:     从右边起匹配
    stArbitraryDim: 任意匹配
    获取搜索结果函数: GetSearchResult}
  TSearchType = (stExact, stLeftDim, stRightDim, stArbitraryDim);

  { 对象空间位置分析的种类:
     atSelected:    显示当前土层的选择对象结果
     atAlongLine:   显示沿线周边缓冲区内的对象结果
     atInRegion:    显示某区域内的对象结果
     atAroundPoint: 显示某点周围缓冲区内的对象结果
     获取结果函数: GetAnalyseResult}
  TAnalyseType = (atSelected, atAlongLine, atInRegion, atAroundPoint);
  TAnalyseTypes = set of TAnalyseType;

  TWorkLayerChanged = procedure(Sender: TObject; NewWorkLayer: string) of object;
  TCurrentToolChanged = procedure(Sender: TObject; NewTool: TMapXToolType) of object;

  TMapX = class(TObject)
  private
    FMap: TMap;
    //地图文件
    FFileName: string;
    //工作图层
    FWorkLayer: string;
    //当前鼠标所处的地理坐标
    FMouseX,FMouseY: Double;
    //当前鼠标所处的屏幕坐标 }
    FMouseScreenX, FMouseScreenY: Integer;
    //当前鼠标位置下,"当前图层"上的对象.根据鼠标的移动即时更新
    FFeatureUnderMouse: CMapXFeature;
    //当前工具
    FCurrentTool: TMapXToolType;
    //各种工具
    FPointSelectTool: TPointSelectTool;
    FRadiusSelectTool: TRadiusSelectTool;
    FRectSelectTool: TRectSelectTool;
    FPolygonSelectTool: TPolygonSelectTool;

    FInforTool: TInforTool;
    FRulerTool: TRulerTool;
    FAreaTool: TAreaTool;
    FLabelTool: TLabelTool;

    FOnWorkLayerChanged: TWorkLayerChanged;
    FOnCurrentToolChanged: TCurrentToolChanged;

    FMapXTheme: TMapXTheme;

    procedure SetFileName(const Value: string); virtual;
    procedure SetWorkLayer(const Value: string);
    procedure SetCurrentTool(const Value: TMapXToolType);
    function LayerExist(ALayer: string): Boolean;
    function LayerVisible(ALayer: string): Boolean;
    function LayerSelectable(ALayer: string): Boolean;
    function DataExist(AData: string): Boolean;
    function GetMapHandle: HWND;
  protected
    procedure MapXOnMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer); virtual;
    procedure MapXOnMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer); virtual;
    procedure MapXOnMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer); virtual;
    procedure MapXOnToolUsed(ASender: TObject; ToolNum: Smallint; X1, Y1, X2,
      Y2, Distance: Double; Shift, Ctrl: WordBool;
      var EnableDefault: WordBool); virtual;
    procedure MapXOnPolyToolUsed(ASender: TObject; ToolNum: Smallint;
      Flags: Integer; const Points: IDispatch; bShift, bCtrl: WordBool;
      var EnableDefault: WordBool);  virtual;
  public
    constructor Create(AOwner: TComponent); overload; virtual;
    destructor Destroy; override;
    //打开地图
    procedure OpenFile(AFileName: string); virtual;
    //获取地图的所有图层名称
    procedure Get_Layers(AList: TStringList);
    //获取地图的所有可视图层名称
    procedure Get_VisibleLayers(AList: TStringList);
    //获取地图的某一图层的字段集合
    procedure Get_LayerFields(ALayer: string; AList: TStringList);
    //设置图层的可视否
    procedure SetLayerVisible(ALayer: string; IsVisible: Boolean);
    //设置图层的关键字段
    procedure SetLayerKeyField(ALayer, AField: string);
    //设置某个图层的选择结果
    //若Shift为true: 从图层Lyr的已有选择对象中去除Fs
    //若Ctrl为true: 从图层Lyr的已有选择对象中增加Fs
    //若Shift、Ctrl均为False：用Fs代替图层Lyr的已有选择对象
    procedure SetLayerSelection(Shift, Ctrl: boolean;
      Fs: CMapxFeatures; ALayer: String);
    //地图标题属性设置
    procedure TitleSetting;
    //图层属性设置
    procedure LayerSetting;
    //专题图属性设置
    procedure ThemeSetting;
    //查询对象设置
    procedure SearchSetting;
    //缓冲区分析设置
    procedure AnalyseSetting(AnalyseType: TAnalyseType);
    //保存地图
    procedure SaveAsGstFile;
    //保存地图为图片
    procedure SaveAsGraph;
    //打印地图
    procedure PrintMap;
    //绑定图层数据
    procedure BindLayerData(ALayer: string);
    //返回图层的个数
    function GetLayerCount: Integer;
    //获得数据集的个数
    function GetDataSetCount: Integer;
    //获得数据集
    function GetDataSetByName(AName: string): CMapXDataSet;
    //获得图层
    function GetLayerByName(AName: string): CMapXLayer;
    //获得搜索结果
    function GetSearchResult(ALayer, AField, AText: string;
      SearchType: TSearchType): CMapxfeatures;
    //返回几个对象合并后的对象
    function GetCombinedFeature(Fs: CMapXFeatures): CMapXFeature;
    //获取对象空间分析的种类
    function GetAnalyseTypes(SourceFs: CMapXFeatures): TAnalyseTypes;
    //获得空间分析结果
    function GetAnalyseResult(AnalyseType: TAnalyseType; SourceF: CMapXFeature;
      DesLyr: string; Dis: Double): CMapXFeatures;
    //获得图层的选择集
    function GetLayerSelection(ALayer: string): CMapXFeatures;

    property FileName: string read FFileName write SetFileName;
    property WorkLayer: string read FWorkLayer write SetWorkLayer;
    property MouseX: Double read FMouseX;
    property MouseY: Double read FMouseY;
    property FeatureUnderMouse: CMapXFeature read FFeatureUnderMouse;
    property CurrentTool: TMapXToolType read FCurrentTool write SetCurrentTool;
    property MapHandle: HWND read GetMapHandle;
  end;

  THawkMap = class(TMapX)
  private
    FBuddyMapX: TMapX;
    procedure SetFileName(const Value: string); override;
  protected
    procedure MapXOnToolUsed(ASender: TObject; ToolNum: Smallint; X1, Y1, X2,
      Y2, Distance: Double; Shift, Ctrl: WordBool;
      var EnableDefault: WordBool); override;
    procedure MapXOnMapViewChanged(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
    procedure SetBuddyMap(AMapX: TMapX);
  end;

function CreateToolTipWindow(hWndParent :HWND) :HWND;
procedure AddToolTip(hwnd: DWORD; lpToolInfo: PToolInfo; IconType: Integer;
  Text, Title: PChar; BackColor, TextColor:TColor);

const
 TTS_BALLOON    = $40;
 TTM_SETTITLE = (WM_USER + 32);

var
  hToolTip: HWND;      //气泡提示窗口句柄
  AToolInfo: TToolInfo;


implementation

uses TitleFrm, SaveFrm, PrintFrm, ThemeFrm, SearchFrm, AnalyseFrm;

//创建气泡提示窗口
function CreateToolTipWindow(hWndParent :HWND) :HWND;
begin
  //DoInitCommonControls(ICC_WIN95_CLASSES);
  //创建窗口TTS_BALLOON就是泡状窗口
  Result := CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASS, nil,
    WS_POPUP or TTS_NOPREFIX or TTS_ALWAYSTIP or TTS_BALLOON,
    CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT,
    hWndParent, 0, hInstance, nil );
  SetWindowPos(Result, HWND_TOPMOST, 0, 0, 0, 0,
      SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
  //延迟时间可以当参数
  SendMessage(Result,TTM_SETDELAYTIME,TTDT_INITIAL,100);
  SendMessage(Result,TTM_SETDELAYTIME,TTDT_RESHOW, 100 div 5);
  //停留显示时间
  SendMessage (Result,TTM_SETDELAYTIME,TTDT_AUTOPOP,3000);
end;

procedure AddToolTip(hwnd: DWORD; lpToolInfo: PToolInfo; IconType: Integer;
  Text, Title: PChar; BackColor, TextColor:TColor);
 //BackColor, TextColor分别是背景颜色和文本颜色,如果是0则取默认值.
var
  Rect: TRect;
  Buffer : array[0..255] of Char;
begin
  if (hwnd <> 0) and (GetClientRect(hwnd, Rect)) then
  begin
  
   lpToolInfo.cbSize:= SizeOf(TToolInfo);
   lpToolInfo.uFlags:= TTF_SUBCLASS or TTF_TRANSPARENT;
   lpToolInfo.hInst:= hInstance;
   lpToolInfo.hwnd := hwnd;
   lpToolInfo.uId:= hwnd;
   lpToolInfo.Rect := Rect;
   lpToolInfo.lpszText := Text;

   SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpToolInfo));
   FillChar(Buffer, SizeOf(Buffer), #0);
   lstrcpy(Buffer, Title);
   if (IconType > 3) or (IconType < 0) then IconType := 0;
   if BackColor <> 0 then
     SendMessage(hToolTip, TTM_SETTIPBKCOLOR, BackColor, 0);
   if TextColor <> 0 then
     SendMessage(hToolTip, TTM_SETTIPTEXTCOLOR, TextColor, 0);
   SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@Buffer));
  end;
end;

{ TMapX }

constructor TMapX.Create(AOwner: TComponent);
begin
  FMap:= TMap.Create(AOwner);
  FMap.Parent:= TWinControl(AOwner);
  FMap.Align:= alClient;
  FMap.OnMouseDown:= MapXOnMouseDown;
  FMap.OnMouseMove:= MapXOnMouseMove;
  FMap.OnMouseUp:= MapXOnMouseUp;
  FMap.OnToolUsed:= MapXOnToolUsed;
  FMap.OnPolyToolUsed:= MapXOnPolyToolUsed;

  FPointSelectTool:= TPointSelectTool.Create(Self);
  FRadiusSelectTool:= TRadiusSelectTool.Create(Self);
  FRectSelectTool:= TRectSelectTool.Create(Self);
  FPolygonSelectTool:= TPolygonSelectTool.Create(Self);

  FInforTool:= TInforTool.Create(Self);
  FRulerTool:= TRulerTool.Create(Self);
  FAreaTool:= TAreaTool.Create(Self);
  FLabelTool:= TLabelTool.Create(Self);

  FMapXTheme:= TMapXTheme.Create(Self);
end;

destructor TMapX.Destroy;
begin
  FMap.Free;
  FPointSelectTool.Free;
  FRadiusSelectTool.Free;
  FRectSelectTool.Free;
  FPolygonSelectTool.Free;

  FInforTool.Free;
  FRulerTool.Free;
  FAreaTool.Free;
  FLabelTool.Free;

  FMapXTheme.Free;
  inherited;
end;

procedure TMapX.Get_Layers(AList: TStringList);
var