main.pas

ODAC 6 最新版的﹐網上找了好久才找到﹐不太好找啊﹐大家一起共享

unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, DBCtrls, ExtCtrls, Grids, DBGrids, DAScript,
  OraScript, DB, MemDS, DBAccess, Ora, OdacVcl, SdoGeometry, ToolWin,
  ComCtrls, Buttons;

type
  TCreateOperation = (coNone, coPoint, coLine, coPoligon, coRectangle, coCircle);

  TfmMain = class(TForm)
    ToolBar: TPanel;
    btOpen: TButton;
    btClose: TButton;
    DBNavigator1: TDBNavigator;
    cbDebug: TCheckBox;
    btCreate: TButton;
    btDrop: TButton;
    cbDirect: TCheckBox;
    DBGrid: TDBGrid;
    FigurePanel: TPanel;
    OraSession: TOraSession;
    ConnectDialog: TConnectDialog;
    OraQuery: TOraQuery;
    DataSource: TDataSource;
    scCreate: TOraScript;
    scDrop: TOraScript;
    Splitter1: TSplitter;
    Panel2: TPanel;
    FigurePaintBox: TPaintBox;
    pnPalette: TPanel;
    btCreatePoint: TSpeedButton;
    btCreateLine: TSpeedButton;
    btCreatePoligon: TSpeedButton;
    btCreateRectangle: TSpeedButton;
    btCreateCircle: TSpeedButton;
    procedure FormCreate(Sender: TObject);
    procedure btCreateClick(Sender: TObject);
    procedure btDropClick(Sender: TObject);
    procedure cbDebugClick(Sender: TObject);
    procedure cbDirectClick(Sender: TObject);
    procedure btOpenClick(Sender: TObject);
    procedure btCloseClick(Sender: TObject);
    procedure OraQueryAfterScroll(DataSet: TDataSet);
    procedure FormDestroy(Sender: TObject);
    procedure FigurePaintBoxPaint(Sender: TObject);
    procedure btCreateFigureClick(Sender: TObject);
    procedure FigurePaintBoxMouseDown(Sender: TObject;
      Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure OraQueryAfterClose(DataSet: TDataSet);
    procedure FigurePaintBoxMouseMove(Sender: TObject; Shift: TShiftState;
      X, Y: Integer);
    procedure FormResize(Sender: TObject);
  private
    { Private declarations }
    FScaleX, FScaleY: double;
    FGeometry: TSdoGeometry;
    FOperation: TCreateOperation;
    FFigureColor: TColor;
    FPoint: TSdoPoint;
    procedure OrdinatesToPixels(XOrd, YOrd: double; var X, Y: integer);
    procedure PixelsToOrdinates(X, Y: integer; var XOrd, YOrd: double);
    procedure SaveFigure;
    procedure UpdateFigure(X, Y: integer);
  public
    { Public declarations }
  end;

var
  fmMain: TfmMain;

implementation

{$R *.dfm}

uses
  Math;

procedure TfmMain.FormCreate(Sender: TObject);
begin
  OraQuery.SparseArrays := True;
  FGeometry := TSdoGeometry.Create;
  FFigureColor := clBlack;

  cbDebug.Checked := OraQuery.Debug;
  cbDirect.Checked := OraSession.Options.Direct;
end;

procedure TfmMain.FormDestroy(Sender: TObject);
begin
  FGeometry.Free;
end;

procedure TfmMain.btCreateClick(Sender: TObject);
begin
  scCreate.Execute;
end;

procedure TfmMain.btDropClick(Sender: TObject);
begin
  scDrop.Execute;
end;

procedure TfmMain.cbDebugClick(Sender: TObject);
begin
  OraQuery.Debug := cbDebug.Checked;
  scCreate.Debug := cbDebug.Checked;
  scDrop.Debug := cbDebug.Checked;
end;

procedure TfmMain.cbDirectClick(Sender: TObject);
begin
  OraSession.Options.Direct := cbDirect.Checked;
end;

procedure TfmMain.btOpenClick(Sender: TObject);
var
  i: integer;
begin
  OraQuery.Open;
  for i := 0 to pnPalette.ControlCount - 1 do
    if pnPalette.Controls[i] is TSpeedButton then
      TSpeedButton(pnPalette.Controls[i]).Enabled := True;
end;

procedure TfmMain.btCloseClick(Sender: TObject);
var
  i: integer;
begin
  OraQuery.Close;
  for i := 0 to pnPalette.ControlCount - 1 do
    if pnPalette.Controls[i] is TSpeedButton then
      TSpeedButton(pnPalette.Controls[i]).Enabled := False;
end;

procedure TfmMain.OraQueryAfterScroll(DataSet: TDataSet);
begin
  FGeometry.Load(OraQuery.GetObject('GEOMETRY_OBJECT'));
  FigurePaintBox.Invalidate;
  FOperation := coNone;
end;

procedure TfmMain.FigurePaintBoxPaint(Sender: TObject);
const
  SInvalidData = 'Invalid geomerty data';

  procedure DrawAxes;
  var
    i: integer;
    x, y: integer;
  begin
    with FigurePaintBox, FigurePaintBox.Canvas do begin
      Brush.Style := bsSolid;
      Brush.Color := clWhite;
      FillRect(Rect(0, 0, Width, Height));

      Pen.Style := psSolid;
      Pen.Color := clBlue;
      Font.Color := clBlue;

      MoveTo(20, Height - 20);
      LineTo(Width - 30, Height - 20);
      LineTo(Width - 35, Height - 15);
      MoveTo(Width - 30, Height - 20);
      LineTo(Width - 35, Height - 25);

      MoveTo(20, Height - 20);
      LineTo(20, 5);
      LineTo(25, 10);
      MoveTo(20, 5);
      LineTo(15, 10);

      for i := 1 to 15 do begin
        OrdinatesToPixels(i, i, x, y);
        MoveTo(x, Height - 15);
        LineTo(x, Height - 25);
        TextOut(x - 5, Height - 15, IntToStr(i));
        MoveTo(15, y);
        LineTo(25, y);
        TextOut(0, y - 7, IntToStr(i));
      end;
    end;
  end;

  procedure DrawPoint(x, y: double);
  var
    sx, sy: integer;
  begin
    OrdinatesToPixels(x, y, sx, sy);
    with FigurePaintBox.Canvas do begin
      Brush.Color := FFigureColor;
      Brush.Style := bsSolid;
      Pen.Style := psClear;
      Ellipse(sx - 3, sy - 3, sx + 3, sy + 3);
    end;
  end;

  procedure DrawPoints(i, Count: integer);
  var
    j: integer;
  begin
    for j := 0 to Count - 1 do
      DrawPoint(FGeometry.Ordinates[j * 2 + i], FGeometry.Ordinates[j * 2 + i + 1]);
  end;

  procedure CalcBoundRect(x0, y0, x1, y1, x2, y2: double; var sx1, sy1, sx2, sy2: integer);
  const
    Eps = 1E-10;

    procedure Swap(var x1, y1, x2, y2: double);
    var
      xt, yt: double;
    begin
      xt := x1;
      yt := y1;
      x1 := x2;
      y1 := y2;
      x2 := xt;
      y2 := yt;
    end;

  var
    s1, s2, d, a, b, r, k, c: double;
  begin
    // check that points are different
    if (abs(x0 - x1) <= Eps) and (abs(y0 - y1) <= Eps) or
      (abs(x0 - x2) <= Eps) and (abs(y0 - y2) <= Eps) or
      (abs(x1 - x2) <= Eps) and (abs(y1 - y2) <= Eps)
    then
      raise Exception.Create(SInvalidData);

    // check that points are not collinear
    if abs(x0 - x1) <= Eps then begin
      if abs(x1 - x2) <= Eps then
        raise Exception.Create(SInvalidData);
    end
    else begin
      k := (y0 - y1) / (x0 - x1);
      c := y0 - k * x0;
      if abs(k * x2 + c - y2) <= Eps then
        raise Exception.Create(SInvalidData);
    end;

    // swap points
    if abs(x0 - x2) <= Eps then
      Swap(x2, y2, x1, y1);
    if abs(x1 - x2) <= Eps then
      Swap(x2, y2, x0, y0);

    if abs(y1 - y0) <= Eps then
      Swap(x0, y0, x2, y2);
    if abs(y2 - y0) <= Eps then
      Swap(x0, y0, x1, y1);

    // x0 = x1
    if abs(x0 - x1) <= Eps then begin
      b := 0.5 * (sqr(y0) - sqr(y1)) / (y0 - y1);
      s2 := sqr(x0) - sqr(x2) + sqr(y0) - sqr(y2);
      a := 0.5 * (s2 - 2 * (y0 - y2) * b) / (x0 - x2);
    end
    else
    // y1 = y2
    if abs(y1 - y2) <= Eps then begin
      a := 0.5 * (sqr(x1) - sqr(x2)) / (x1 - x2);
      s2 := sqr(x0) - sqr(x2) + sqr(y0) - sqr(y2);
      b := 0.5 * (s2 - 2 * (x0 - x2) * a) / (y0 - y2);
    end
    else begin
      s1 := sqr(x0) - sqr(x1) + sqr(y0) - sqr(y1);
      s2 := sqr(x0) - sqr(x2) + sqr(y0) - sqr(y2);
      d := (y0 - y1) / (y0 - y2);
      a := 0.5 * (s1 - s2 * d) / ((x0 - x1) - (x0 - x2) * d);
      b := 0.5 * (s2 - 2 * (x0 - x2) * a) / (y0 - y2);
    end;
    r := sqrt(sqr(x0 - a) + sqr(y0 - b));

    OrdinatesToPixels(a - r, b - r, sx1, sy1);
    OrdinatesToPixels(a + r, b + r, sx2, sy2);
  end;

  procedure DrawRect(i: integer);
  var
    sx1, sy1, sx2, sy2: integer;
  begin
    OrdinatesToPixels(FGeometry.Ordinates[i], FGeometry.Ordinates[i + 1], sx1, sy1);
    OrdinatesToPixels(FGeometry.Ordinates[i + 2], FGeometry.Ordinates[i + 3], sx2, sy2);

    with FigurePaintBox.Canvas do begin
      Brush.Style := bsClear;
      Pen.Style := psSolid;
      Pen.Color := FFigureColor;
      Rectangle(sx1, sy1, sx2, sy2);
    end;
  end;

  procedure DrawCircle(i: integer);
  var
    sx1, sy1, sx2, sy2: integer;
  begin
    try
      CalcBoundRect(FGeometry.Ordinates[i], FGeometry.Ordinates[i + 1],
        FGeometry.Ordinates[i + 2], FGeometry.Ordinates[i + 3],
        FGeometry.Ordinates[i + 4], FGeometry.Ordinates[i + 5], sx1, sy1, sx2, sy2);
    except
      exit;
    end;

    with FigurePaintBox.Canvas do begin
      Brush.Style := bsClear;
      Pen.Style := psSolid;
      Pen.Color := FFigureColor;
      Ellipse(sx1, sy1, sx2, sy2);
    end;
  end;

  procedure DrawLine(posStart, posEnd: integer);
  var
    i, PointCount: integer;
    Points: array of TPoint;
  begin
    PointCount := (posEnd + 1 - posStart) div 2;
    SetLength(Points, PointCount);
    for i := 0 to PointCount - 1 do
      OrdinatesToPixels(FGeometry.Ordinates[posStart + i * 2], FGeometry.Ordinates[posStart + i * 2 + 1],
        Points[i].X, Points[i].Y);

    with FigurePaintBox.Canvas do begin
      Pen.Style := psSolid;
      Pen.Color := FFigureColor;
      Polyline(Points);
    end;
  end;

  procedure DrawArc(posStart, posEnd: integer);
  var
    i, sx1, sy1, sx2, sy2, RectX1, RectY1, RectX2, RectY2: integer;