?? unitdrawshape.pas

?? 此代碼是關于mapgis的在
?? PAS
字號:
unit UnitDrawShape;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, StdCtrls, YHBListBox, NumberEditUnit, MapXLib_TLB, Buttons, Math;

type
  TFrame_DrawShape = class(TFrame)
    GroupBox1: TGroupBox;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    BitBtn3: TBitBtn;
    BitBtn4: TBitBtn;
    GroupBox4: TGroupBox;
    Label1: TLabel;
    Label2: TLabel;
    XOffestEdit: TUpDownEditFloat;
    YOffestEdit: TUpDownEditFloat;
    GroupBox5: TGroupBox;
    ValueList: TYHBListBox;
    GroupBox3: TGroupBox;
    Label4: TLabel;
    Label3: TLabel;
    CheckBox1: TCheckBox;
    YEdit: TUpDownEditFloat;
    XEdit: TUpDownEditFloat;
    GroupBox2: TGroupBox;
    ImportPointsBtn: TButton;
    InsertPointBtn: TButton;
    DeletePointBtn: TButton;
    AddPointBtn: TButton;
    CompleteBtn: TButton;
    EditPointBtn: TButton;
    ApplyOffestBtn: TButton;
    procedure YEditKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure XEditKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure CompleteBtnClick(Sender: TObject);
    procedure AddPointBtnClick(Sender: TObject);
    procedure DeletePointBtnClick(Sender: TObject);
    procedure ValueListClick(Sender: TObject);
    procedure EditPointBtnClick(Sender: TObject);
    procedure InsertPointBtnClick(Sender: TObject);
    procedure ApplyOffestBtnClick(Sender: TObject);
    procedure XOffestEditKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure YOffestEditKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure BitBtn1Click(Sender: TObject);
    procedure BitBtn2Click(Sender: TObject);
    procedure BitBtn3Click(Sender: TObject);
    procedure BitBtn4Click(Sender: TObject);
  private
    { Private declarations }
    Ft:Feature;
    IsComplete:Boolean;
    function CreateShape(const v_x, v_y:Double):Feature;
    function AddPointToShape(const v_x, v_y:Double):Boolean;
    procedure GetInputPointValue(var v_x, v_y:Double);
    procedure LoadFeaturePoints(aFt:Feature);
    procedure SetComplete;
  public
    { Public declarations }
    procedure SelectionChanged;
    procedure EditFeature(aFt:Feature);
  end;

implementation

uses UnitGISShell, UnitShellAPIs, MapXStyles, BusinessDialogs, MapXAPIs,
  MapXBase, MapXTools, MapXConsts;

{$R *.dfm}

function TFrame_DrawShape.CreateShape(const v_x, v_y:Double): Feature;
var
  aToolObj:TBaseMapTool;
begin
  CheckEditLayer;
  MyGIS.GMapTools.m_Layer.Layer:=EditLayer;
  aToolObj:=MyGIS.GMapTools.m_Map.GetToolObjectByToolId(MyGIS.GMapTools.m_Map.MapX.CurrentTool);
  if aToolObj=nil then
    WarningAbort('系統錯誤', '無法取得工具對象！');
  case aToolObj.UserType of
    MAP_TOOL_ADDSYMBOL:begin//標記
      Result:=MyGIS.GMapTools.m_Layer.AddSymbol(v_x, v_y, STYLE_LAYERSTYLE, False, ID_ACTION_CREATE);
      IsComplete:=True;
    end;
    MAP_TOOL_ADDLINE, MAP_TOOL_ADDPLINE:begin//線段
      Result:=MyGIS.GMapTools.m_Layer.AddLine(v_x, v_y, v_x, v_y, STYLE_LAYERSTYLE, False, ID_ACTION_CREATE);
      IsComplete:=False;
    end;
    MAP_TOOL_ADDRECT, MAP_TOOL_ADDREGION:begin//矩形
      Result:=MyGIS.GMapTools.m_Layer.AddRectangle(v_x, v_y, v_x, v_y, '', STYLE_LAYERSTYLE, False, ID_ACTION_CREATE);
      IsComplete:=False;
    end;
    MAP_TOOL_ADDCIRCLE, MAP_TOOL_ADDELLIPSE:begin//圓、橢圓
      Result:=MyGIS.GMapTools.m_Layer.AddCircle(v_x, v_y, 1, STYLE_LAYERSTYLE, True, ID_ACTION_CREATE);
      IsComplete:=False;
    end;
    else begin
      Result:=nil;
      IsComplete:=True;
      WarningAbort('提示', '請設置為增加圖形模式！');
    end;
  end;
end;

procedure TFrame_DrawShape.YEditKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key=vk_return then
    AddPointBtnClick(AddPointBtn);
end;

procedure TFrame_DrawShape.XEditKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key=vk_return then YEdit.SetFocus;
end;

procedure TFrame_DrawShape.CompleteBtnClick(Sender: TObject);
var
  aToolObj:TBaseMapTool;
  Tool_Min, Tool_Max:Integer;
begin
  CheckEditLayer;
  MyGIS.GMapTools.m_Layer.Layer:=EditLayer;
  aToolObj:=MyGIS.GMapTools.m_Map.GetToolObjectByToolId(MyGIS.GMapTools.m_Map.MapX.CurrentTool);
  if aToolObj=nil then
    WarningAbort('系統錯誤', '無法取得工具對象！');
  GetAddObjectToolRange(Tool_Min, Tool_Max);
  if (aToolObj.UserType<Tool_Min)or(aToolObj.UserType>Tool_Max) then
    WarningAbort('提示', '請設置為增加圖形模式！');
  SetComplete;
end;

procedure TFrame_DrawShape.SelectionChanged;
begin
  SetComplete;

  ValueList.Items.Clear;
  XEdit.Value:=0;
  YEdit.Value:=0;
  CheckBox1.Checked:=False;

  if (EditLayer<>nil)and(EditLayer.Editable)and
     (EditLayer.Selection.Count>0) then
  begin
    //顯示公共屬性面板//
    //如果為單一圖形，則顯示特性面板//
    if EditLayer.Selection.Count=1 then
      EditFeature(EditLayer.Selection.Item[1]);
  end;
end;

function TFrame_DrawShape.AddPointToShape(const v_x, v_y:Double):Boolean;
begin
  case Ft.type_ of
    miFeatureTypeRegion, miFeatureTypeLine:begin
      if ValueList.Count=1 then
        Ft.Parts.Item[1].Item[2].Set_(v_x, v_y)
      else
        Ft.Parts.Item[1].AddXY(v_x, v_y, EmptyParam);
      Ft.Update(EmptyParam, EmptyParam);
      Result:=True;
    end;
    else begin
      IsComplete:=True;
      Result:=False;
    end;
  end;
end;

procedure TFrame_DrawShape.SetComplete;
begin
  IsComplete:=True;
  Ft:=nil;
  ValueList.Items.Clear;
end;

procedure TFrame_DrawShape.AddPointBtnClick(Sender: TObject);
var
  v_x, v_y:Double;
  aStr:string;
  Seed:Double;
begin
  Seed:=MyGIS.GMapTools.MapX.Bounds.Width/8;
  {分析當前圖形是否已經生成，如果已經生成，應該追加或修改節點，否則創建圖形}
  if Ft=nil then
  begin
    if not IsComplete then
      WarningAbort('系統錯誤', '對象未被創建卻標志沒有完成！');
    GetInputPointValue(v_x, v_y);
    Ft:=CreateShape(v_x, v_y);
    aStr:='('+IntToStr(ValueList.Items.Count+1)+') X:'+FloatToStr(v_x)+',Y:'+FloatToStr(v_y);
    ValueList.Items.Add(aStr);
    GoToFeature(MyGIS.GMapTools.MapX, Ft, True, Seed);
  end
  else if not IsComplete then
  begin
    if not ShapeCanAddPoint(Ft, 1) then
      WarningAbort('提示', '該圖形不允許增加點！');
    {分析是否已經完成圖形編輯，如果已經完成，則清空列表，并設置Ft為空；
    如果沒有完成編輯，則應該追加或修改節點。}
    GetInputPointValue(v_x, v_y);
    if not AddPointToShape(v_x, v_y) then Exit;
    aStr:='('+IntToStr(ValueList.Items.Count+1)+') X:'+FloatToStr(v_x)+',Y:'+FloatToStr(v_y);
    ValueList.Items.Add(aStr);
    GoToFeature(MyGIS.GMapTools.MapX, Ft, True, Seed);
  end;
  if IsComplete then
  begin
    Ft:=nil;
    ValueList.Items.Clear;
  end;
  {完成該點輸入，返回到X坐標編輯框}
  XEdit.SetFocus;
end;


procedure TFrame_DrawShape.GetInputPointValue(var v_x, v_y: Double);
var
  pt:Point;
begin
  if CheckBox1.Checked then
  begin
    if ValueList.ItemIndex=-1 then
      WarningAbort('提示', '請選擇相對的點！');
    pt:=Ft.Parts.Item[1].Item[ValueList.ItemIndex];
    v_x:=pt.X+XEdit.Value;
    v_y:=pt.Y+YEdit.Value;
  end
  else
  begin
    v_x:=XEdit.Value;
    v_y:=YEdit.Value;
  end;
end;

procedure TFrame_DrawShape.LoadFeaturePoints(aFt: Feature);

var
  i:Integer;
  aStr:string;
  pt:Point;

  procedure AddPointToList;
  begin
    aStr:='('+IntToStr(i)+') X:'+FloatToStr(pt.X)+',Y:'+FloatToStr(pt.Y);
    ValueList.Items.Add(aStr);
  end;
  
begin
  ValueList.Items.BeginUpdate;
  try
    ValueList.Items.Clear;
    case aFt.type_ of
      miFeatureTypeSymbol,
      miFeatureTypeText:begin
        pt:=aFt.Point;
        AddPointToList;
      end;
      else begin
        for i:=1 to aFt.Parts.Item[1].Count do
        begin
          pt:=aFt.Parts.Item[1].Item[i];
          AddPointToList;
        end;
      end;
    end;
  finally
    ValueList.Items.EndUpdate;
  end;
end;

procedure TFrame_DrawShape.DeletePointBtnClick(Sender: TObject);
var
  Index:Integer;
begin
  if Ft<>nil then
  begin
    if ValueList.ItemIndex=-1 then
      WarningAbort('提示', '請選擇要刪除的點！');
    if not ShapeCanDeletePoint(Ft, 1) then
      WarningAbort('提示', '該圖形不允許刪除點！');
    Index:=ValueList.ItemIndex;
    Ft.Parts.Item[1].Remove(Index+1);
    Ft.Update(EmptyParam, EmptyParam);
    LoadFeaturePoints(Ft);
    ValueList.ItemIndex:=min(Index, ValueList.Count-1);
  end;
end;

procedure TFrame_DrawShape.ValueListClick(Sender: TObject);
var
  pt:Point;
begin
  if ValueList.ItemIndex=-1 then Exit;
  pt:=GetShapePoint(Ft, 1, ValueList.ItemIndex+1);
  XEdit.Value:=pt.X;
  YEdit.Value:=pt.Y;
end;

procedure TFrame_DrawShape.EditPointBtnClick(Sender: TObject);
var
  Index:Integer;
  aStr:string;
  pt:Point;
begin
  if Ft<>nil then
  begin
    Index:=ValueList.ItemIndex;
    if Index=-1 then
      WarningAbort('提示', '請選擇要修改的點！');
    pt:=GetShapePoint(Ft, 1, Index+1);
    pt.Set_(XEdit.Value, YEdit.Value);
    Ft.Update(EmptyParam, EmptyParam);
    aStr:='('+IntToStr(Index)+') X:'+XEdit.Text+',Y:'+YEdit.Text;
    ValueList.Items[Index]:=aStr;
  end;
end;

procedure TFrame_DrawShape.InsertPointBtnClick(Sender: TObject);
var
  Index:Integer;
begin
  if Ft<>nil then
  begin
    if not ShapeCanAddPoint(Ft, 1) then
      WarningAbort('提示', '該圖形不允許插入點！');
    if ValueList.ItemIndex=-1 then
      WarningAbort('提示', '請選擇一個點要前插的點！');
    Index:=ValueList.ItemIndex;
    Ft.Parts.Item[1].AddXY(XEdit.Value, YEdit.Value, Index+1);
    ft.Update(EmptyParam, EmptyParam);
    LoadFeaturePoints(Ft);
    ValueList.ItemIndex:=Index;
  end;
end;

procedure TFrame_DrawShape.ApplyOffestBtnClick(Sender: TObject);
begin
  CheckEditLayer;
  OffestShapes(EditLayer.Selection, XOffestEdit.Value, YOffestEdit.Value);
end;

procedure TFrame_DrawShape.XOffestEditKeyDown(Sender: TObject;
  var Key: Word; Shift: TShiftState);
begin
  if Key=vk_return then YOffestEdit.SetFocus;
end;

procedure TFrame_DrawShape.YOffestEditKeyDown(Sender: TObject;
  var Key: Word; Shift: TShiftState);
begin
  if Key=vk_return then
  begin
    ApplyOffestBtnClick(ApplyOffestBtn);
    XOffestEdit.SetFocus;
  end;
end;

procedure TFrame_DrawShape.BitBtn1Click(Sender: TObject);
var
  i:Integer;
  ft:Feature;
  mstyle:Style;
begin
  CheckEditLayer;
  ft:=GetFirstShapeInSelction(EditLayer.Selection, miFeatureTypeSymbol);
  if ft<>nil then
    mstyle:=ft.Style.Clone
  else
    mstyle:=CoStyle.Create;
  if not mstyle.PickSymbol then Exit;
  for i:=1 to EditLayer.Selection.Count do
  begin
    ft:=EditLayer.Selection.Item[i];
    if ft.type_=miFeatureTypeSymbol then
    begin
      ft.Style:=mstyle;
      ft.Update(EmptyParam, EmptyParam);
    end;
  end;
end;

procedure TFrame_DrawShape.BitBtn2Click(Sender: TObject);
var
  i:Integer;
  ft:Feature;
  mstyle:Style;
begin
  CheckEditLayer;
  ft:=GetFirstShapeInSelction(EditLayer.Selection, miFeatureTypeLine);
  if ft<>nil then
    mstyle:=ft.Style.Clone
  else
    mstyle:=CoStyle.Create;
  if not mstyle.PickLine then Exit;
  for i:=1 to EditLayer.Selection.Count do
  begin
    ft:=EditLayer.Selection.Item[i];
    if ft.type_=miFeatureTypeLine then
    begin
      ft.Style:=mstyle;
      ft.Update(EmptyParam, EmptyParam);
    end;
  end;
end;

procedure TFrame_DrawShape.BitBtn3Click(Sender: TObject);
var
  i:Integer;
  ft:Feature;
  mstyle:Style;
begin
  CheckEditLayer;
  ft:=GetFirstShapeInSelction(EditLayer.Selection, miFeatureTypeRegion);
  if ft<>nil then
    mstyle:=ft.Style.Clone
  else
    mstyle:=CoStyle.Create;
  if not mstyle.PickRegion then Exit;
  for i:=1 to EditLayer.Selection.Count do
  begin
    ft:=EditLayer.Selection.Item[i];
    if ft.type_=miFeatureTypeRegion then
    begin
      ft.Style:=mstyle;
      ft.Update(EmptyParam, EmptyParam);
    end;
  end;  
end;


procedure TFrame_DrawShape.BitBtn4Click(Sender: TObject);
var
  i:Integer;
  ft:Feature;
  mstyle:Style;
begin
  CheckEditLayer;
  ft:=GetFirstShapeInSelction(EditLayer.Selection, miFeatureTypeText);
  if ft<>nil then
    mstyle:=ft.Style.Clone
  else
    mstyle:=CoStyle.Create;
  if not mstyle.PickText then Exit;
  for i:=1 to EditLayer.Selection.Count do
  begin
    ft:=EditLayer.Selection.Item[i];
    if ft.type_=miFeatureTypeText then
    begin
      ft.Style:=mstyle;
      ft.Update(EmptyParam, EmptyParam);
    end;
  end;  
end;

procedure TFrame_DrawShape.EditFeature(aFt: Feature);
begin
  SetComplete;

  ValueList.Items.Clear;
  XEdit.Value:=0;
  YEdit.Value:=0;
  CheckBox1.Checked:=False;

  Ft:=aFt;
  LoadFeaturePoints(Ft);
  case Ft.type_ of
    miFeatureTypeRegion,
    miFeatureTypeLine:begin
      IsComplete:=False;
    end;
    else begin
      IsComplete:=True;
    end;
  end;
end;

end.
?? 文件大小 13180 K
?? 上傳用戶 downloader_006
?? 所屬分類 Delphi控件源碼
??? 相關標簽

#mapgis #代碼
?? 快捷鍵說明

復制代碼 Ctrl + C
搜索代碼 Ctrl + F
全屏模式 F11
切換主題 Ctrl + Shift + D
顯示快捷鍵 ?
增大字號 Ctrl + =
減小字號 Ctrl + -
亚洲欧美第一页_禁久久精品乱码_粉嫩av一区二区三区免费野_久草精品视频

?? unitdrawshape.pas

?? 快捷鍵說明
