mapxapis.pas

此代码是关于mapgis的在

function GetPathsStr(List:TStrings): string;
var
  i:Integer;
begin
  Result:='';
  if List.Count=0 then Exit;
  Result:=List.Strings[0];
  for i:=1 to List.Count-1 do
    Result:=Result+';'+List.Strings[i];
end;

function SetGeoDictionaryFileSearchPath(List:TStrings):Boolean;
var
  Reg: TRegistry;
begin
  Result:=False;
  Reg:=Tregistry.Create;
  try
    Reg.RootKey :=HKEY_LOCAL_MACHINE;
    if Reg.OpenKey ('SOFTWARE\Mapinfo\MapX\5.0', True) then
    begin
      Reg.WriteString('SearchPaths', GetPathsStr(List));
      Result:=True;
    end;
    Reg.CloseKey;
  finally
    Reg.Destroy;
  end;
end;

function ToComFieldType(Value: TMapFieldType):Integer;
begin
  case Value of
    mftString    : Result:=0;
    mftBCD       : Result:=1;
    mftDateTime  : Result:=2;
    mftInteger   : Result:=3;
    mftSmallint  : Result:=4;
    mftFloat     : Result:=5;
    mftBoolean   : Result:=6;
    else           Result:=-1;
  end;
end;

function ToMapFieldType(Value: Integer):TMapFieldType;
begin
  case Value of
    0: Result:=mftString;
    1: Result:=mftBCD;
    2: Result:=mftDateTime;
    3: Result:=mftInteger;
    4: Result:=mftSmallint;
    5: Result:=mftFloat;
    6: Result:=mftBoolean;
    else
       Result:=mftUnknown;
  end;
end;

function ToMapFieldType(Value: TDataType):TMapFieldType;
begin
  case Value of
    ftUnknown:
      Result:=mftUnknown;
    ftString, ftMemo,
    ftFixedChar, ftWideString:
      Result:=mftString;
    ftSmallint:
      Result:=mftSmallint;
    ftInteger, ftAutoInc, ftWord:
      Result:=mftInteger;
    ftBoolean:
      Result:=mftBoolean;
    ftFloat, ftCurrency:
      Result:=mftFloat;
    ftBCD:
      Result:=mftBCD;
    ftDate, ftTime, ftDateTime:
      Result:=mftDateTime;
    else 
      Result:=mftBinary;
  end;
end;

procedure InitRowValuesFromStruct(Rvs:CMapXRowValues; FromFields:CMapXFields;
  ToDs:CMapXDataset);
var
  i:Integer;
  rv:RowValue;
begin
  Rvs.RemoveAll;
  for i:=1 to FromFields.Count do
  begin
    rv:=CoRowValue.Create;
    rv.Dataset:=ToDs;
    rv.Field:=FromFields.Item[i];
    Rvs.Add(rv);
  end;
end;

function CreateRowValuesFromStruct(FromFields:CMapXFields;
  ToDs:CMapXDataset):CMapXRowValues;
begin
  Result:=CoRowValues.Create;
  InitRowValuesFromStruct(Result, FromFields, ToDs);
end;

function GetFeatureRowValues(Ft:Feature; ds:CMapXDataset):CMapXRowValues;
begin
  Result:=ds.RowValues[Ft];
end;

procedure InitRowValuesFromDataSet(rvs: TMapRowValueList; Fds:CMapXFields);
var
  i:Integer;
  aItem:TMapRowValue;
begin
  rvs.Clear;
  for i:=1 to Fds.Count do
  begin
    aItem:=rvs.Add;
    with aItem.FieldInfo do
    begin
      PhyIndex:=i;
      FieldName:=Fds.Item[i].Name;
      FieldType:=ToMapFieldType(Fds.Item[i].TypeEx);
      if FieldType=mftBCD then
      begin
        Prec:=Fds.Item[i].Precision;
        Scale:=Fds.Item[i].Decimals;
      end
      else if FieldType=mftString then
      begin
        Length:=Fds.Item[i].Width;
      end;
    end;
  end;
end;

procedure InitRowValuesFromDataSet(rvs: TMapRowValueList; RomateDS: TADOQuery);
const
  GeoDataFieldName:string='FeatureData';
  GeoTypeFieldName:string='FeatureType';

  function FieldCanLoad(AField:TField):Boolean;
  begin
    Result:=(AnsiCompareText(AField.FieldName, GeoDataFieldName)=0)or
            (AnsiCompareText(AField.FieldName, GeoTypeFieldName)=0);
  end;

var
  i:Integer;
  aItem:TMapRowValue;
begin
  rvs.Clear;
  with RomateDS do
  begin
    for i:=0 to Fields.Count-1 do
    begin
      if FieldCanLoad(Fields[i]) then
      begin
        aItem:=rvs.Add;
        with aItem.FieldInfo do
        begin
          PhyIndex:=i;
          FieldName:=Fields[i].FieldName;
          FieldType:=ToMapFieldType(Fields[i].DataType);
          Length:=Fields[i].Size;
          Prec:=0;
          Scale:=0;
        end;
      end;
    end;
    Close;
  end;
end;

procedure LoadMapFields(Fds:CMapXFields; MapFields: TMapFieldList);
var
  i:Integer;
  aItem:TMapField;
begin
  MapFields.Clear;
  for i:=1 to Fds.Count do
  begin
    aItem:=MapFields.Add;
    with aItem do
    begin
      PhyIndex:=i;
      FieldName:=Fds.Item[i].Name;
      FieldType:=ToMapFieldType(Fds.Item[i].TypeEx);
      if FieldType=mftBCD then
      begin
        Prec:=Fds.Item[i].Precision;
        Scale:=Fds.Item[i].Decimals;
      end
      else if FieldType=mftString then
      begin
        Length:=Fds.Item[i].Width;
      end;
    end;
  end;
end;

procedure LoadMapFields(RomateDS: TADOQuery; MapFields: TMapFieldList);
const
  GeoDataFieldName:string='FeatureData';
  GeoTypeFieldName:string='FeatureType';

  function FieldCanLoad(AField:TField):Boolean;
  begin
    Result:=(AnsiCompareText(AField.FieldName, GeoDataFieldName)<>0)
            and
            (AnsiCompareText(AField.FieldName, GeoTypeFieldName)<>0);
  end;

var
  i:Integer;
begin
  MapFields.Clear;
  with RomateDS do
  begin
    for i:=0 to Fields.Count-1 do
    begin
      if FieldCanLoad(Fields[i]) then
        MapFields.AddAndInit(Fields[i].FieldName,
                             ToMapFieldType(Fields[i].DataType),
                             Fields[i].Size,
                             0,
                             0);
    end;
    Close;
  end;
end;

function GetTypeDefineStr_MSSQL(aItem:TMapField):string;
begin
  case aItem.FieldType of
    mftString   : Result:='char('+IntToStr(aItem.Length)+')';
    mftInteger  : Result:='int';
    mftSmallint : Result:='smallint';
    mftBoolean  : Result:='bit';
    mftFloat    : Result:='float';
    mftBCD      : Result:='decimal('+IntToStr(aItem.Prec)+','+IntToStr(aItem.Scale)+')';
    mftDateTime : Result:='datetime';
    mftBinary   : Result:='image';
  end;
end;

function GetTypeDefineStr(const ADBType:TDBType; aItem:TMapField):string;
begin
  case ADBType of
    dbtStandard    : Result:=GetTypeDefineStr_MSSQL(aItem);
    dbtAccess      : Result:=GetTypeDefineStr_MSSQL(aItem);
    dbtDBF         : Result:=GetTypeDefineStr_MSSQL(aItem);
    dbtOracle      : Result:=GetTypeDefineStr_MSSQL(aItem);
    dbtParadox     : Result:=GetTypeDefineStr_MSSQL(aItem);
    dbtSQLServer   : Result:=GetTypeDefineStr_MSSQL(aItem);
    dbtInformix    : Result:=GetTypeDefineStr_MSSQL(aItem);
    dbtDB2         : Result:=GetTypeDefineStr_MSSQL(aItem);
    dbtInterBase   : Result:=GetTypeDefineStr_MSSQL(aItem);
    dbtSybase      : Result:=GetTypeDefineStr_MSSQL(aItem);
    dbtSQLAnywhere : Result:=GetTypeDefineStr_MSSQL(aItem);
    else 
  end;
end;

procedure CreateRomateTable(RomateDS: TADOQuery; const ADBType:TDBType;
  const TableName: string; MapFields: TMapFieldList);
const
  GeoDataFieldName:string='FeatureData';
  GeoTypeFieldName:string='FeatureType';
var
  i:Integer;
  aItem:TMapField;
  FieldDefineStr:string;
begin
  {增加图形字段}
  if MapFields.IndexOf(GeoDataFieldName)=-1 then
  begin
    aItem:=MapFields.Insert(0);
    aItem.FieldName:=GeoDataFieldName;
    aItem.FieldType:=mftBinary;
    aItem.Length:=-1;
  end;

  if MapFields.IndexOf(GeoTypeFieldName)=-1 then
  begin
    aItem:=MapFields.Insert(0);
    aItem.FieldName:=GeoTypeFieldName;
    aItem.FieldType:=mftInteger;
    aItem.Length:=-1;
  end;
  {删除同名表}
  try
    with RomateDS do
    begin
      Close;
      SQL.Text:='drop table '+TableName;
      ExecSQL;
    end;
  except
  end;
  {创建表}
  with RomateDS do
  begin
    Close;
    SQL.Clear;
    SQL.Add('create table '+TableName+' (');
    for i:=0 to MapFields.ItemCount-1 do
    begin
      FieldDefineStr:=MapFields.Items[i].FieldName+' '+
                      GetTypeDefineStr(ADBType, MapFields.Items[i]);
      if i<MapFields.ItemCount-1 then
        FieldDefineStr:=FieldDefineStr+',';
      SQL.Add(FieldDefineStr);
    end;
    SQL.Add(')');
    ExecSQL;
  end;
end;

procedure GetShapeTypes(Fts:Features; List:TStrings);
var
  i:Integer;
  strtype:string;
begin
  List.Clear;
  for i:=1 to Fts.Count do
  begin
    strtype:=IntToStr(Fts.Item[i].type_);
    if List.IndexOf(strtype)=-1 then
      List.Add(strtype);
  end;
end;

function CanRegionToLine(Fts:Features):Boolean;
Var
  i: Integer;
  newtype: TOLEEnum;
  List: TStringList;
begin
  Result:=True;
  if CanCombine(Fts) then Exit;
  List:=TStringList.Create;
  try
    GetShapeTypes(Fts, List);
    for i:=0 to List.Count-1 do
    begin
      newtype:=StrToInt(List.Strings[i]);
      if (newtype<>miFeatureTypeLine)and(newtype<>miFeatureTypeRegion) then
      begin
        Result:=False;
        Exit;
      end;
    end;
  finally
    List.Free;
  end;
end;

function CanCombine(Fts:Features):Boolean;
var
  i:Integer;
  FirstType:TOLEEnum;
begin
  FirstType:=0;
  for i:=1 to Fts.Count do
  begin
    if i=1 then
      FirstType:=Fts.Item[i].type_
    else if Fts.Item[i].type_<>FirstType then
    begin
      Result:=False;
      Exit;
    end;
  end;
  Result:=True;
end;

function CombineSelectedShapes(MapX:TMapXObject; ALyr:Layer):Feature;
Var
  i: Integer;
  myfts : cmapXfeatures;
  newFeature, Style: Variant;
begin
  Result:=nil;
  myfts := ALyr.Selection.Clone;
  if myfts.Count > 1 then //至少选择两个图形//
  begin
    Style := myfts.Item[1].Style;
    newFeature := MapX.FeatureFactory.CombineFeatures(myfts.Item[1], myfts.Item[2]);
    for i := 3 to myfts.Count do
      newFeature := MapX.FeatureFactory.CombineFeatures(newFeature, myfts.Item[i]);
    newFeature.Style := Style;
    newFeature.Style.LineColor:=clBlue;
    newFeature:=ALyr.AddFeature(newFeature, EmptyParam);
    for i := 1 to myfts.Count do
      ALyr.DeleteFeature(ALyr.Selection.Item[i]);
    ALyr.Selection.ClearSelection;
    ALyr.Selection.Add(newFeature);
    Result:=Feature(IDispatch(newFeature));
  end;
end;

function GetNearestLine(Ft:Feature; const mX, mY, mW: Double; var PartIndex,
  PointIndex:Integer; var pt0:TAny2DPoint):Boolean;
var
  i:Integer;
  pts:Points;
  pt:Point;
  Dist, MinDist:Double;
  bFuncRes:Boolean;
  tmp_PtIndex:Integer;
  tmp_pt0:TAny2DPoint;
begin
  Result:=False;
  PartIndex:=0;
  PointIndex:=0;
  MinDist:=0;
  Pt:=CoPoint.Create;
  try
    for i:=1 to Ft.Parts.Count do
    begin
      pts:=ft.Parts.Item[i];
      Pt.Set_(mX, mY);
      bFuncRes:=PointOnPolyLine(mX, mY, mW, pts, tmp_PtIndex, tmp_pt0, Dist);
      if bFuncRes then
      begin
        Result:=True;
        if PartIndex=0 then
        begin
          MinDist:=Dist;
          PartIndex:=i;
          PointIndex:=tmp_PtIndex;
          pt0:=tmp_pt0;
        end
        else if Dist<MinDist then
        begin
          MinDist:=Dist;
          PartIndex:=i;
          PointIndex:=tmp_PtIndex;
          pt0:=tmp_pt0;
        end;
      end;
    end;
  finally
    Pt:=nil;
  end;
end;

function GetMethodGlobalAddress(Obj: TObject; const MethodName:string;
  var PMethod:TMethod):Boolean;
begin
  PMethod.Data := Pointer(Obj);
  PMethod.Code := Obj.MethodAddress(MethodName);
  Result:=Assigned(PMethod.Code);
end;

end.