unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ActiveX, ComObj, AutoCAD_TLB;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure UseWCS;
    procedure UseOCS;
  end;

type
  TPosition = Array [0..2] of double;

const
  x = 0; y = 1; z = 2;

function AcPoint(X, Y, Z: Double): OleVariant;
function PosToVar(p: TPosition): OleVariant;
function VarToPos(v: olevariant): TPosition;
function Distance(a, b: TPosition): double;
function VectorCross(a, b : TPosition): TPosition;
function VectorScale(vector: TPosition; s: double): TPosition;
Function VectorLength(vector: TPosition): double;
Function VectorNormalize(vector: TPosition): TPosition;
Procedure GetArbitraryAxes(normal: TPosition; var XAxis, YAxis: TPosition);

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  UseWCS; // Switch to the WCS
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  UseOCS; // Switch to a UCS that is parallel to a selected object
end;

function AcPoint(X, Y, Z: Double): OleVariant;
begin
  Result := VarArrayCreate([0, 2], VT_R8);
  Result[0] := X;
  Result[1] := Y;
  Result[2] := Z;
end;

// Convert 3D point (array [0..2] of double)
// to a variant array of VT_R8's

function PosToVar(p: TPosition): OleVariant;
var
  i : integer;
begin
  Result := VarArrayCreate([0, High(p)], VT_R8);
  For i := 0 to High(p) do
    Result[i] := p[i];
end;

function VarToPos(v: OleVariant): TPosition;
var
  i : integer;
begin
  For i := VarArrayLowBound(v, 1) to VarArrayHighBound(v, 1) do
    Result[i] := v[i];
end;

// Obtain the cross product of two vectors (array[0..2] of double)
Function VectorCross(a, b: TPosition): TPosition;
begin
  Result[x] := (a[y]*b[z])-(b[y]*a[z]);
  Result[y] := (a[z]*b[x])-(b[z]*a[x]);
  Result[z] := (a[x]*b[y])-(b[x]*a[y]);
end;

// Obtain the distance between two points (array[0..2] of double)

function Distance(a, b: TPosition): double;
var
  s : double;
  i : integer;
begin
  s := 0.0;
  for i := 0 to 2 do s := s + sqr(a[i]-b[i]);
  result := sqrt(s);
end;

// Uniformly Scale a vector by a specified factor

Function VectorScale(vector: TPosition; s : double): TPosition;
var
  i : integer;
begin
  For i := 0 to 2 do Result[i] := vector[i] * s;
end;

// Return the length of a vector

Function VectorLength(vector: TPosition): double;
const
  origin : TPosition = (0.0, 0.0, 0.0);
begin
  Result := Distance(origin, vector);
end;

// Scale a vector to 1-unit in length:

Function VectorNormalize(vector: TPosition): TPosition;
var
  i : integer;
begin
  Result := VectorScale(vector, 1.0 / VectorLength(vector));
end;

// The one and only Arbitrary Axis Algorithm
// Fills in the XAxis and YAxis arrays with
// the X and Y axis unit vectors.

Procedure GetArbitraryAxes(normal : TPosition; var XAxis, YAxis: TPosition);
const
  phi = 1.0 / 64.0;
  WorldY : TPosition = (0.0, 1.0, 0.0);
  WorldZ : TPosition = (0.0, 0.0, 1.0);
begin
  if (abs(normal[x]) < phi) and (abs(normal[y]) < phi) then
    XAxis := VectorCross(WorldY, Normal)
  else
    XAxis := VectorCross(WorldZ, Normal);
  VectorNormalize(XAxis);
  YAxis := VectorCross(Normal, XAxis);
  VectorNormalize(YAxis);
end;

Function SelectObject(Document: OleVariant): OleVariant;
begin
  Document.SelectionSets.Add('TEMP');
  Document.SelectionSets.Item('TEMP').SelectOnScreen;
  Result := Document.SelectionSets.Item('TEMP').Item(0);
  Document.SelectionSets.Item('TEMP').Delete;
end;

// Example shows how set the ActiveUCS to the WCS

procedure TForm1.UseWCS;
var
  Acad, vUCS: OleVariant;
  UCS : AcadUCS;
  Util : AcadUtility;
begin
  Acad := GetActiveOleObject('AutoCAD.Application');
  ucs := Acad.ActiveDocument.ActiveUCS;
  ucs.Origin := AcPoint(0.0, 0.0, 0.0);
  ucs.XVector := AcPoint(1.0, 0.0, 0.0);
  ucs.YVector := AcPoint(0.0, 1.0, 0.0);
  Acad.ActiveDocument.ActiveUCS := ucs;
end;

// Make the current UCS parallel to the OCS of a
// selected object. Note that this is not equivalent
// to using UCS/Entity since the origin of the new
// UCS is not set to a point relative to the object.
//
// Requires the user to select a single 2D object

Procedure TForm1.UseOCS;
var
  Acad, Entity: OleVariant;
  NewXAxis, NewYAxis: TPosition;
begin
  Acad := GetActiveOleObject('AutoCAD.Application');
  Entity := SelectObject(Acad.ActiveDocument);
  GetArbitraryAxes(VarToPos(Entity.Normal), NewXAxis, NewYAxis);
  Acad.ActiveDocument.ActiveUCS.XVector := PosToVar(NewXAxis);
  Acad.ActiveDocument.ActiveUCS.YVector := PosToVar(NewYAxis);
  Acad.ActiveDocument.ActiveUCS := Acad.ActiveDocument.ActiveUCS
end;

end.