mapxbase.~pas

此代码是关于mapgis的在

unit MapXBase;

interface

uses
  Classes, Types, SysUtils, MapXLib_TLB, Variants, Graphics, Dialogs, DB, ADODB,
  StoreManager;
  
type
  TShapeType=(stUnknown, stSymbol, stLine, stPLine1, sRect, sCircle,
    stPLine2, stSPLine, stEllipse, stArc, stText);
  TMapImageFormat=(mifWMF, mifBMP, mifGIF, mifJPEG, mifTIF, mifPNG, mifPSD);

  PMapImageConfig=^TMapImageConfig;
  
  TMapImageConfig=record
    PaperUnit:Integer;
    Format:TMapImageFormat;
    Width, Height:Integer;
    FileName:string;
  end;

  PAny2DPoint = ^TAny2DPoint;
  
  TAny2DPoint = packed record
    X, Y: Double;
  end;

  PAnyRect = ^TAnyRect;

	TAnyRect = packed Record
		Left, Top, Right, Bottom: Double; //Left, Top, Right, Bottom
	end;
  
  TPickMethod = (pmUnknown, pmSymbol, pmLine, pmRegion, pmText);

  PObjectMethodInfo = ^TObjectMethodInfo;

  TObjectMethodInfo = record
    TypeId:Integer;
    Method:TMethod;
  end;

  TObjectMethodList = class
  private
    FList:TList;
    function GetItemCount:Integer;
    function GetItem(Index:Integer):PObjectMethodInfo;
  public
    constructor Create;
    destructor Destroy;override;
    function Add:PObjectMethodInfo;
    function AddAndInit(const TypeId:Integer; Obj:TObject;
      pProc:Pointer):PObjectMethodInfo;
    function Insert(const Index:Integer):PObjectMethodInfo;
    function InsertAndInit(const Index, TypeId:Integer; Obj:TObject;
      pProc:Pointer):PObjectMethodInfo;
    procedure Delete(const Index:Integer);
    procedure Clear;
    function IndexOf(Obj:TObject; pProc:Pointer):Integer;
    property Count:Integer read GetItemCount;
    property Items[Index:Integer]:PObjectMethodInfo read GetItem;
  end;
  
  TStyleInfoClass = class of TBaseStyleInfo;
  
  {标记信息，可以用它来创建实际使用的Symbol接口对象}
  TBaseStyleInfo = class
  private
    FCaption: string;
    FScript: string;
    FUserID: Integer;
  public
    constructor Create;virtual;
    {创建Symobl接口对象}
    function CreateStyleInterfaceObject:Style; virtual;
    {从Style装载}
    procedure Assign(AStyle:Style); virtual; abstract;
    {设置到Style上}
    procedure ConfigToStyle(AStyle:Style); virtual; abstract;
    {存储}
    procedure LoadFromStream(Stream:TStream); virtual;
    procedure SaveToStream(Stream:TStream); virtual;
    procedure LoadFromField(BlobField:TBlobField);
    procedure SaveToField(BlobField:TBlobField);
    procedure SaveToParam(AParam:TParam; DataType: TDataType);
    procedure SaveToParameter(AParam:TParameter; DataType: TDataType);
    {用户ID，用于索引}
    property UserID:Integer read FUserID write FUserID;
    {标记的名称}
    property Caption:string read FCaption write FCaption;
    {标记的备注信息}
    property Script:string read FScript write FScript;
  end;

  {标记列表，可以用索引取得标记信息，通过调用标记信息的方法创建Symbol接口对象，
  使使用Symbol更加方便}
  TStyleInfoList = class
  private
    FList:TList;
    function GetItemCount:Integer;
    function GetItem(Index:Integer):TBaseStyleInfo;
  public
    constructor Create;
    destructor Destroy;override;
    procedure Add(Value:TBaseStyleInfo); overload;
    procedure Add(AStyleClass:TStyleInfoClass); overload;
    procedure Insert(const Index:Integer;Value:TBaseStyleInfo); overload;
    procedure Insert(const Index:Integer;AStyleClass:TStyleInfoClass); overload;
    procedure Delete(const Index:Integer);
    procedure Clear;
    function IndexByUserID(const UserId:Integer):Integer;
    function FindByUserID(const UserId:Integer):TBaseStyleInfo;
    procedure LoadFromStream(Stream:TStream);
    procedure SaveToStream(Stream:TStream);
    property ItemCount:Integer read GetItemCount;
    property Items[Index:Integer]:TBaseStyleInfo read GetItem;
  end;

  PMapPoint = ^TMapPoint;

  TMapPoint = record
    x:Double;
    y:Double;
  end;

  TMapPointList = class
  private
    FList:TList;
    FStoreManager:TStoreManager;
    function GetItemCount:Integer;
    function GetItem(Index:Integer):PMapPoint;
  protected
    procedure DoSaveToStream(Sender:TObject; Stream:TStream); virtual;
    procedure DoLoadFromStream(Sender:TObject; Stream:TStream); virtual;
  public
    constructor Create;
    destructor Destroy;override;
    procedure Assign(Source:TMapPointList);
    procedure LoadFromPoints(Pts:CMapXPoints);
    procedure ConfigPoints(Pts:CMapXPoints; bClear:Boolean);
    function CreatePointsInterfaceObject:CMapXPoints;
    procedure Add(Value:PMapPoint);overload;
    function Add:PMapPoint;overload;
    function AddXY(const x, y:Double):PMapPoint;
    procedure Insert(const Index:Integer;Value:PMapPoint);overload;
    function Insert(const Index:Integer):PMapPoint;overload;
    procedure Delete(const Index:Integer);
    procedure Clear;
    {存储对象}
    property StoreManager: TStoreManager read FStoreManager;
    property ItemCount:Integer read GetItemCount;
    property Items[Index:Integer]:PMapPoint read GetItem;
  end;

  TMapPartList = class
  private
    FList:TList;
    FStoreManager:TStoreManager;
    function GetItemCount:Integer;
    function GetItem(Index:Integer):TMapPointList;
  protected
    procedure DoSaveToStream(Sender:TObject; Stream:TStream); virtual;
    procedure DoLoadFromStream(Sender:TObject; Stream:TStream); virtual;
  public
    constructor Create;
    destructor Destroy;override;
    procedure Assign(Source:TMapPartList);
    procedure LoadFromParts(Prts:CMapXParts);
    procedure ConfigParts(Prts:CMapXParts; bClear:Boolean);
    function CreatePartsInterfaceObject:CMapXParts;
    procedure Add(Value:TMapPointList);overload;
    function Add:TMapPointList;overload;
    procedure Insert(const Index:Integer;Value:TMapPointList);overload;
    function Insert(const Index:Integer):TMapPointList;overload;
    procedure Delete(const Index:Integer);
    procedure Clear;
    {存储对象}
    property StoreManager: TStoreManager read FStoreManager;
    property ItemCount:Integer read GetItemCount;
    property Items[Index:Integer]:TMapPointList read GetItem;
  end;

  {系统工具和用户工具的基类}
  TMapToolClass=class of TBaseMapTool;

  TToolList=class;
  
  TBaseMapTool=class
  private
    FGlyph: TBitmap;
    FCursorType: Integer;
    FToolType: Integer;
    FToolId: Integer;
    FCursorIcon: string;
    FCaption: string;
    FCollection: TToolList;
    FScript: string;
    FMsgHandle: THandle;
    FMsgString: string;
    FUserType: Integer;
    FOnTurnTool: TNotifyEvent;
    FTurnTool: TBaseMapTool;
    procedure SetCursorIcon(Value: string);
    procedure SetGlyph(const Value: TBitmap);
  protected
    procedure GlyphChanged(Sender:TObject);
    function GetMapX:TMapXObject; virtual; abstract;
    procedure SetMapX(Value:TMapXObject); virtual; abstract;
    procedure EndTheTool; virtual;
  public
    constructor Create(aCollection:TToolList); virtual;
    destructor Destroy;override;
    {是否为用户工具
        工具分为两种，一种是MapX系统工具，是MapX预先提供好的，因此
    这些工具的ToolId不能动态分配，而在类信息中指定为固定的ToolId。
        如果自定义工具为系统工具，而没有覆盖IsUserMapTool函数，将
    该函数的返回值设置为False时，安装该工具将出现错误。}
    class function IsUserMapTool:Boolean; virtual; abstract;
    {工具的当前操作是否被完成}
    function IsComplete:Boolean; virtual; abstract;
    {取消当前工具的操作}
    function Cancel:Boolean; virtual;
    {工具是否为地图的全局当前工具
        所谓全局当前工具，指该工具的ToolId与地图的CurrentTool相同。
    因为我们根据需要可能开发出很多的自定义工具（地图状态），可能出
    先多个工具的ToolId与地图的CurrentTool相同，又因为所有的工具一
    旦安装，将在整个程序周期内运行，为了区分当前是否为该工具，需要
    使用IsMapXCurrentTool或IsLocalCurrentTool方法判断。
        该方法一般不被使用，因为可能其它工具的ToolId与地图的CurrentTool
    相同。从而导致错误的判断。}
    function IsMapXCurrentTool:Boolean;
    {工具是否为地图的本地当前工具
        因为地图工具要在工具列表中添加，该方法就是指出是否为该组工具
    的当前工具。}
    function IsLocalCurrentTool:Boolean;
    {容器对象}
    property Collection:TToolList read FCollection;
    {消息对象}
    property MsgHandle:THandle read FMsgHandle write FMsgHandle;
    {消息字符串}
    property MsgString:string read FMsgString write FMsgString;
    {工具的编号}
    property ToolId:Integer read FToolId write FToolId;
    {工具的类型}
    property ToolType:Integer read FToolType write FToolType;
    {用户类型}
    property UserType:Integer read FUserType write FUserType;
    {光标的类型}
    property CursorType:Integer read FCursorType write FCursorType;
    {设置光标的图标，当光标类型为用户自定义时有效}
    property CursorIcon:string read FCursorIcon write SetCursorIcon;
    {工具标题，一般用在按钮或菜单的文本}
    property Caption:string read FCaption write FCaption;
    {用做Hint的内容}
    property Script:string read FScript write FScript;
    {图标，用做按钮或菜单的图标}
    property Glyph: TBitmap read FGlyph write SetGlyph;
    {MapX对象}
    property MapX:TMapXObject read GetMapX write SetMapX;
    {返回到的状态
        在真正开发的时候，往往不直接调用下面代码：
        TurnTool.Collection.SetCurrentTool(TurnTool)
    使状态返回，因为如果这样，开发者的其它处理工作将不被执行，从而导致
    地图的当前状态与界面工具状态不匹配}
    property TurnTool:TBaseMapTool read FTurnTool write FTurnTool;
    {返回到某一状态的事件
        调用EndTheTool方法时将触发该事件，开发者可以在事件处理过程中写
    其它代码，用于做相应的处理。例如，当返回到选择状态时，开发者需要设
    置菜单的单选状态，然后才能调用
        SetCurrentMapTool('TPointSelectTool', DoOnTurnTool)
    使点击选择状态为当前状态}
    property OnTurnTool:TNotifyEvent read FOnTurnTool write FOnTurnTool; 
  end;

  TToolNofityEvent=procedure (Sender:TObject; AToolObj:TBaseMapTool) of object;
  
  TToolList = class
  private
    FList:TList;
    FCurrentToolObject: TBaseMapTool;
    FAfterSetCurrentTool: TToolNofityEvent;
    function GetItemCount:Integer;
    function GetItem(Index:Integer):TBaseMapTool;
  public
    constructor Create;
    destructor Destroy;override;
    {增加工具}
    procedure Add(Value:TBaseMapTool);
    {插入工具}
    procedure Insert(const Index:Integer;Value:TBaseMapTool);
    {删除工具}
    procedure Delete(const Index:Integer);
    {清除所有工具}
    procedure Clear;
    {取得新的工具编号}
    function GetNewToolId:Integer;
    {设置当前工具}
    procedure SetCurrentTool(aToolObj:TBaseMapTool); overload;
    procedure SetCurrentTool(const ToolId:Integer); overload;
    procedure SetCurrentTool(const ClassName:string); overload;
    {查找工具}
    function IndexByToolId(const ToolId:Integer):Integer;
    function FindByToolId(const ToolId:Integer):TBaseMapTool;
    function IndexByClassName(const ClassName:string):Integer;
    function FindByClassName(const ClassName:string):TBaseMapTool;
    {工具的数量}
    property ItemCount:Integer read GetItemCount;
    {取得某一个工具}
    property Items[Index:Integer]:TBaseMapTool read GetItem;
    {当前工具}
    property CurrentToolObject:TBaseMapTool read FCurrentToolObject;
    {应用工具后触发事件}
    property AfterSetCurrentTool:TToolNofityEvent read FAfterSetCurrentTool write FAfterSetCurrentTool;
  end;

  TMapFieldType=(mftUnknown, mftString, mftInteger, mftSmallint, mftBoolean,
                 mftFloat, mftBCD, mftDateTime, mftBinary);
  
  TMapField = class
    FieldName:string;
    DisplayLabel:string;
    FieldType:TMapFieldType;
    Length:Integer;
    Prec:Integer;
    Scale:Integer;
    PhyIndex:Integer;
    Data:Pointer;
    procedure LoadFromStream(Stream:TStream);
    procedure SaveToStream(Stream:TStream);
  end;

  TMapFieldList = class
  private
    FList:TList;
    function GetItemCount:Integer;
    function GetItem(Index:Integer):TMapField;
  public
    constructor Create;
    destructor Destroy;override;
    procedure Add(Value:TMapField);overload;
    function Add:TMapField;overload;
    function AddAndInit(const FieldName:string; const FieldType:TMapFieldType;
      const Length, Prec, Scale:Integer):TMapField;
    procedure Insert(const Index:Integer;Value:TMapField);overload;
    function Insert(const Index:Integer):TMapField;overload;
    function InsertAndInit(const Index:Integer; const FieldName:string;
      const FieldType:TMapFieldType; const Length, Prec, Scale:Integer):TMapField;
    procedure Delete(const Index:Integer);
    procedure Clear;
    function IndexOf(const AName:string):Integer;
    function FindItem(const AName:string):TMapField;
    function FieldByName(const AName:string):TMapField;
    procedure LoadFromStream(Stream:TStream);
    procedure SaveToStream(Stream:TStream);
    property ItemCount:Integer read GetItemCount;
    property Items[Index:Integer]:TMapField read GetItem;
  end;

  TMapRowValue = class
  private
    FValue: Variant;
    FFieldInfo: TMapField;
  public
    constructor Create;
    destructor Destroy;override;
    procedure SaveToStream(Stream:TStream);
    procedure LoadFromStream(Stream:TStream);
    property Value:Variant read FValue write FValue;
    property FieldInfo:TMapField read FFieldInfo;
  end;

  TMapRowValueList = class
  private
    FList:TList;
    function GetItemCount:Integer;
    function GetItem(Index:Integer):TMapRowValue;
  public
    constructor Create;
    destructor Destroy;override;
    procedure Add(Value:TMapRowValue);overload;
    function Add:TMapRowValue;overload;
    procedure Insert(const Index:Integer;Value:TMapRowValue);overload;
    function Insert(const Index:Integer):TMapRowValue;overload;
    procedure Delete(const Index:Integer);
    procedure Clear;
    procedure LoadFromFile(const FileName:string);
    procedure SaveToFile(const FileName:string);
    procedure LoadFromStream(Stream:TStream);
    procedure SaveToStream(Stream:TStream);
    property ItemCount:Integer read GetItemCount;
    property Items[Index:Integer]:TMapRowValue read GetItem;
  end;

var
  StyleClasses:TList;


//取得垂线交点//
procedure GetVerticalCrossPoint(pt1,pt2, pt:TAny2DPoint;
  var pt0:TAny2DPoint);
//点是否在直线的BoundsRect内//
function PointInLineBoundsRect(pt1,pt2, pt:TAny2DPoint):Boolean;
function PointOnPolyLine (x, y, w:Double;Polygon: Points;
  var Index:Integer; var pt0:TAny2DPoint; var Dist: Double):Boolean;
function GetStyleInfoClass(const StyleClassName:string):TStyleInfoClass;
function PtInRect(Rect:TAnyRect;Pt:TAny2DPoint):Boolean;
function GeoPoint(const x, y:Double):TAny2DPoint;
function GeoRect(const pt1, pt2:TAny2DPoint):TAnyRect; overload;
function GeoRect(const Left, Top, Right, Bottom:Double):TAnyRect; overload;
function RectToGeoRect(const ARect:TRect):TAnyRect;
function GeoRectToRect(const ARect:TAnyRect):TRect;
function WideRect(ALeft, ATop, AWidth, AHeight: Double): TAnyRect;
function MakeRect(Pt1, Pt2 : TPoint) : TRect;
procedure OffsetGeoRect(var ARect:TAnyRect; const dx, dy: Double);
procedure InflateGeoRect(var ARect:TAnyRect; const dx, dy: Double);
procedure ScaleGeoRect(var ARect:TAnyRect; const sx, sy: Double);
procedure NormalRect(var Rect:TAnyRect);
procedure NormalLinePoint(var pt1, pt2:TAny2DPoint);
procedure NormalValue(var v1, v2: Double);

implementation

uses
  StreamIOAPIs, DBConsts, AppDebug;

procedure GetVerticalCrossPoint(pt1,pt2, pt:TAny2DPoint;
  var pt0:TAny2DPoint);
var
  a,b,c,d,dx,dy:Double;
begin
  dx:=pt2.X-pt1.X;
  dy:=pt2.Y-pt1.Y;
  if dx=0 then//垂直线，直接分析点到直线横向坐标差，要求差值小于w//
  begin
    pt0.x:=pt1.x;
    pt0.y:=pt.y;
  end
  else if dy=0 then//水平线，直接分析点到直线纵向坐标差，要求差值小于w//
  begin
    pt0.x:=pt.x;
    pt0.y:=pt1.y;
  end
  else
  begin
    a:=dy/dx;   //取得斜率//
    b:=a*pt1.x-pt1.y;
    c:=-1/a;   //取得垂线斜率//
    d:=c*pt.x-pt.y;
    pt0.x:=(b-d)/(a-c);  //取得垂线和该直线焦点横向坐标//
    pt0.y:=a*pt0.x-b;// pt1.y-a*(pt1.x-pt0.x);       //取得垂线和该直线焦点纵向坐标//
  end;
end;

function PointInLineBoundsRect(pt1,pt2, pt:TAny2DPoint):Boolean;
var
  ARect:TAnyRect;
begin
  ARect:=GeoRect(pt1, pt2);
  Result:=PtInRect(ARect, pt);
end;

function PointOnLine(pt1, pt2, pt:TAny2DPoint; w: Double;
  var pt0:TAny2DPoint; var dist:Double): boolean;
begin
  GetVerticalCrossPoint(pt1, pt2, pt, pt0);
  Result:=PointInLineBoundsRect(pt1, pt2, pt0);
  if Result then
  begin
    dist:=(pt.x-pt0.x)*(pt.x-pt0.x)+(pt.y-pt0.y)*(pt.y-pt0.y);
    Result:=dist<w*w;
  end;
end;

function PointOnPolyLine (x, y, w:Double;Polygon: Points;
  var Index:Integer; var pt0:TAny2DPoint; var Dist: Double):Boolean;
var
  i:integer;
  ptprev,ptcur:Point;
  ptlast:integer;
  mindist:Double;
  minpt0:TAny2DPoint;
begin
  Index:=-1;
  mindist:=0;
  ptcur := Polygon.Item[1];
  ptlast:=Polygon.Count;
  for i:=2 to ptlast do
  begin
    ptprev := ptcur;
    ptcur := Polygon.Item[i];
    if pointonline(GeoPoint(ptprev.x,ptprev.y),
                   GeoPoint(ptcur.x,ptcur.y),
                   GeoPoint(x,y),
                   w, pt0, dist) then
    begin
      if (Index=-1)or(dist<mindist) then
      begin
        Index:=i;
        mindist:=dist;
        minpt0:=pt0;
      end;
    end;
  end;
  Result:=Index>0;
  Dist:=mindist;
  pt0:=minpt0;
end;

function GetStyleInfoClass(const StyleClassName:string):TStyleInfoClass;
var
  i:Integer;
begin
  Result:=nil;
  for i:=0 to StyleClasses.Count-1 do
    if CompareText(TStyleInfoClass(StyleClasses.Items[i]).ClassName, StyleClassName)=0 then
    begin
      Result:=StyleClasses.Items[i];
      Exit;
    end;
end;

function PtInRect(Rect:TAnyRect;Pt:TAny2DPoint):Boolean;
begin
  NormalRect(Rect);
  Result := (Pt.X >= Rect.Left) and
            (Pt.X <= Rect.Right) and
            (Pt.Y >= Rect.Top) and
            (Pt.Y <= Rect.Bottom);
end;

function GeoPoint(const x, y:Double):TAny2DPoint;
begin
  Result.x:=x;
  Result.y:=y;
end;

function GeoRect(const pt1, pt2:TAny2DPoint):TAnyRect;
begin
  Result:=GeoRect(pt1.x, pt1.y, pt2.x, pt2.y);
end;

function GeoRect(const Left, Top, Right, Bottom:Double):TAnyRect;
begin
  Result.Left:=Left;
  Result.Top:=Top;
  Result.Right:=Right;
  Result.Bottom:=Bottom;
end;

function RectToGeoRect(const ARect:TRect):TAnyRect;
begin
  Result.Left:=ARect.Left;
  Result.Top:=ARect.Top;
  Result.Right:=ARect.Right;
  Result.Bottom:=ARect.Bottom;
end;

function GeoRectToRect(const ARect:TAnyRect):TRect;
begin
  Result.Left:=Trunc(ARect.Left);
  Result.Top:=Trunc(ARect.Top);
  Result.Right:=Trunc(ARect.Right);
  Result.Bottom:=Trunc(ARect.Bottom);
end;

function WideRect(ALeft, ATop, AWidth, AHeight: Double): TAnyRect;
begin
  with Result do
  begin
    Left := ALeft;
    Top := ATop;
    Right := ALeft+AWidth;
    Bottom := ATop+AHeight;
  end;
end;

function MakeRect(Pt1, Pt2 : TPoint) : TRect;
begin
  if pt1.x < pt2.x then begin
    Result.Left := pt1.x;
    Result.Right := pt2.x;
  end else begin
    Result.Left := pt2.x;