sgconsts.pas

CAD转换工具 CAD转换工具 CAD转换工具 CAD转换工具

  until (K >= ARightPos);
end;

function CompareDXFPointByXCoord(Item1, Item2: Pointer): Integer;
begin
  if(PdxfPoint(Item1)^.X> PdxfPoint(Item2)^.X) then
    Result := +1
  else if(PdxfPoint(Item1)^.X = PdxfPoint(Item2)^.X) then
    Result := 0
  else
    Result := -1;
end;

function CompareDXFPointByYCoord(Item1, Item2: Pointer): Integer;
begin
  if(PdxfPoint(Item1)^.Y> PdxfPoint(Item2)^.Y) then
    Result := +1
  else if(PdxfPoint(Item1)^.Y = PdxfPoint(Item2)^.Y) then
    Result := 0
  else
    Result := -1;
end;

function CompareFPointByXCoord(Item1, Item2: Pointer): Integer;
begin
  if(PFPoint(Item1)^.X> PFPoint(Item2)^.X) then
    Result := +1
  else if(PFPoint(Item1)^.X = PFPoint(Item2)^.X) then
    Result := 0
  else
    Result := -1;
end;

function CompareFPointByYCoord(Item1, Item2: Pointer): Integer;
begin
  if(PFPoint(Item1)^.Y> PFPoint(Item2)^.Y) then
    Result := +1
  else if(PFPoint(Item1)^.Y = PFPoint(Item2)^.Y) then
    Result := 0
  else
    Result := -1;
end;

procedure ClearList(AList: TList);
var
  I: Integer;
begin
  if AList = nil then
    Exit;
  for I := 0 to AList.Count - 1 do
    TObject(AList[I]).Free;
  AList.Clear;
end;

procedure ClearRecordList(AList: TList);
var
  I: Integer;
begin
  if AList = nil then
    Exit;
  for I := 0 to AList.Count - 1 do
    Dispose(AList[I]);
  AList.Clear;
end;

procedure ClearRecordListOfList(AListOfList: TList);
var
  I, K: Integer;
  vList: TList;
begin
  if AListOfList = nil then
    Exit;
  for I := 0 to AListOfList.Count - 1 do
    if AListOfList[I] <> nil then
    begin
      vList := AListOfList[I];
      for K := 0 to TList(vList).Count - 1 do
        if TList(vList).Items[K] <> nil then
          Dispose(TList(vList).Items[K]);
      TList(vList).Free;
    end;
  AListOfList.Clear;
end;

procedure ClearListWithNilCheck(List: TList);
var
  I: Integer;
begin
  if List = nil then
    Exit;
  for I := 0 to List.Count - 1 do
    if List[I] <> nil then
      TObject(List[I]).Free;
  List.Clear;
end;

procedure FreeList(var AList: TList);
begin
  ClearList(AList);
  if AList <> nil then
    AList.Free;
  AList := nil;
end;

procedure FreeRecordList(var AList: TList);
begin
  ClearRecordList(AList);
  if AList <> nil then
    AList.Free;
  AList := nil;
end;

procedure FreeRecordListOfList(var AListOfList: TList);
begin
  if AListOfList = nil then Exit;
  ClearRecordListOfList(AListOfList);
  if AListOfList <> nil then
    AListOfList.Free;
  AListOfList := nil;
end;

function FindAutoCADSHXPaths(APaths: TStringList): Boolean;
const
  ACADRegPath = 'Software\Autodesk\AutoCAD';
var
  S, vRegPath, vDir: string;
  vStrLst: array[0..3] of TStringList;
  I, J, K, vPos: Integer;
  function GetKeyNames(ANameLst: TStrings; const AValName: string;
    var AValue: string): Boolean;
  var
    vReg: TRegistry;
  begin
    Result := False;
    ANameLst.Clear;
    vReg := TRegistry.Create;
    try
      vReg.RootKey := HKEY_CURRENT_USER;
      if vReg.OpenKey(vRegPath,False) then
      begin
        Result := True;
        vReg.GetKeyNames(ANameLst);
        if (AValName <> '') and vReg.ValueExists(AValName) then
          AValue := vReg.ReadString(AValName)
        else
          AValue := '';
      end;
    finally
      vReg.Free;
    end;
  end;
  function IsSHXInFolder(const AFolder: string): Boolean;
  var
    vSr: TSearchRec;
    S: string;
    vLen: Integer;
  begin
    S := AFolder;
    vLen := Length(S);
    if vLen > 0 then
      if S[vLen] <> '\' then S := S + '\';
    Result := FindFirst(S + '*.shx', faAnyFile, vSr) = 0;
    FindClose(vSr);
  end;

begin
  Result := False;
  if not Assigned(APaths) then Exit;
  for I := 0 to 3 do
    vStrLst[I] := TStringList.Create;
  try
    vRegPath := ACADRegPath;
    GetKeyNames(vStrLst[0], '', S);
    for I := 0 to vStrLst[0].Count - 1 do
    begin
      vRegPath := ACADRegPath + '\' + vStrLst[0][I];
      GetKeyNames(vStrLst[1], '', S);
      for J := 0 to vStrLst[1].Count - 1 do
      begin
        vRegPath := vRegPath + '\' + vStrLst[1][J] + '\Profiles';
        GetKeyNames(vStrLst[2], '', S);
        for K := 0 to vStrLst[2].Count - 1 do
        begin
          vRegPath := vRegPath + '\' + vStrLst[2][K] + '\General';
          GetKeyNames(vStrLst[3], 'ACAD', S);
          while S <> '' do
          begin
            vPos := AnsiPos(';', S);
            if vPos = 0 then Break;
            vDir := Copy(S, 1, vPos - 1);
            if IsSHXInFolder(vDir) then APaths.Add(vDir);
            Delete(S, 1, vPos);
          end;
        end;
      end;
    end;
  finally
    for I := 0 to 3 do
      vStrLst[I].Free;
  end;
  Result := APaths.Count > 0;
end;

function Min(const A, B: Double): Double;
begin
  if A < B then
    Result := A
  else
    Result := B;
end;

function Max(const A, B: Double): Double;
begin
  if A > B then
    Result := A
  else
    Result := B;
end;

function GetIntersectingPoint(const Line1, Line2: TsgLine; var IntersectionMode: TIntersectionMode): TFPoint;
var
  K1, K2, B1, B2: Double;
begin
  Result := cnstFPointZero;
  IntersectionMode := imPoint;
  if IsEqual(Line1.Point2.X, Line1.Point1.X) then
  begin
    Result.X := Line1.Point2.X;
    if not IsEqual(Line2.Point2.X, Line2.Point1.X) then
    begin
      K2 := (Line2.Point2.Y - Line2.Point1.Y) / (Line2.Point2.X - Line2.Point1.X);
      B2 := Line2.Point1.Y - Line2.Point1.X * K2;
      Result.Y := B2 + Result.X * K2;
    end
    else
      if IsEqual(Line1.Point1.X, Line2.Point1.X) then
        IntersectionMode := imLine
      else
        IntersectionMode := imNone;
  end
  else
  if IsEqual(Line2.Point2.X, Line2.Point1.X) then
  begin
    Result.X := Line2.Point1.X;
    if not IsEqual(Line1.Point2.X, Line1.Point1.X) then
    begin
      K1 := (Line1.Point2.Y - Line1.Point1.Y) / (Line1.Point2.X - Line1.Point1.X);
      B1 := Line1.Point1.Y - Line1.Point1.X * K1;
      Result.Y := B1 + Result.X * K1
    end
    else
      if IsEqual(Line1.Point1.X, Line2.Point1.X) then
        IntersectionMode := imLine
      else
        IntersectionMode := imNone;
  end
  else
  begin
    K2 := (Line2.Point2.Y - Line2.Point1.Y) / (Line2.Point2.X - Line2.Point1.X);
    K1 := (Line1.Point2.Y - Line1.Point1.Y) / (Line1.Point2.X - Line1.Point1.X);
    B1 := Line1.Point1.Y - Line1.Point1.X * K1;
    B2 := Line2.Point1.Y - Line2.Point1.X * K2;
    if not IsEqual(K1, K2) then
    begin
      Result.X := (B2 - B1) / (K1 - K2);
      Result.Y := K1 * Result.X + B1;
    end
    else
      if IsEqual(B1, B2) then
        IntersectionMode := imLine
      else
        IntersectionMode := imNone;
  end;
end;

function GetIntresectingRectAndLine(const ARect: TFRect; const ALine: TsgLine; var IntersectionMode: TIntersectionMode): TsgLine;
var
  vIntersectPt: array[0..3] of TFPoint;
  vRectLine: TsgLine;
  vRect: TFRect;
  I, J: Integer;
  Temp: TFPoint;
  vIM: TIntersectionMode;
  A: TsgFloat;
begin
  vRect := ARect;
  if ARect.Top < ARect.Bottom then
  begin
    vRect.Top := ARect.Bottom;
    vRect.Bottom := ARect.Top;
  end;
  //Left line
  vRectLine.Point1 := vRect.TopLeft;
  vRectLine.Point2.X := vRect.Left;
  vRectLine.Point2.Y := vRect.Bottom;
  vIntersectPt[0] := GetIntersectingPoint(vRectLine, ALine, vIM);
  if (vIM <> imPoint)or
     (vRectLine.Point1.Y < vIntersectPt[0].Y)or(vIntersectPt[0].Y < vRectLine.Point2.Y) then
    vIntersectPt[0].X := MaxTsgFloat;
  //Bottom line
  vRectLine.Point1 := vRectLine.Point2;
  vRectLine.Point2 := vRect.BottomRight;
  vIntersectPt[1] := GetIntersectingPoint(vRectLine, ALine, vIM);
  if (vIM <> imPoint)or
     (vRectLine.Point1.X > vIntersectPt[1].X)or(vIntersectPt[1].X > vRectLine.Point2.X) then
    vIntersectPt[1].X := MaxTsgFloat;
  //Right line
  vRectLine.Point1 := vRectLine.Point2;
  vRectLine.Point2.X := vRect.Right;
  vRectLine.Point2.Y := vRect.Top;
  vIntersectPt[2] := GetIntersectingPoint(vRectLine, ALine, vIM);
  if (vIM <> imPoint)or
     (vRectLine.Point1.Y > vIntersectPt[2].Y)or(vIntersectPt[2].Y > vRectLine.Point2.Y) then
    vIntersectPt[2].X := MaxTsgFloat;
  //Top line
  vRectLine.Point1 := vRectLine.Point2;
  vRectLine.Point2 := vRect.TopLeft;
  vIntersectPt[3] := GetIntersectingPoint(vRectLine, ALine, vIM);
  if (vIM <> imPoint)or
     (vRectLine.Point1.X < vIntersectPt[3].X)or(vIntersectPt[3].X < vRectLine.Point2.X) then
    vIntersectPt[3].X := MaxTsgFloat;
  for I := 0 to 2 do
    for J := 0 to 2 - I do
      if vIntersectPt[J].X > vIntersectPt[J + 1].X then
      begin
        Temp := vIntersectPt[J];
        vIntersectPt[J] := vIntersectPt[J + 1];
        vIntersectPt[J + 1] := Temp;
      end;
  Result.Point1 := vIntersectPt[0];
  I := 1;
  while (Abs(vIntersectPt[0].X - vIntersectPt[I].X) < FAccuracy)and(Abs(vIntersectPt[0].Y - vIntersectPt[I].Y) < FAccuracy)and(I < 3) do
    Inc(I);
  Result.Point2 := vIntersectPt[I];
  A := MaxTsgFloat;
  if (not CompareMem(@Result.Point1.X, @A, SizeOf(Result.Point1.X)))and(not CompareMem(@Result.Point2.X, @A, SizeOf(Result.Point1.X))) then
    IntersectionMode := imLine
  else
    if (not CompareMem(@Result.Point1.X, @A, SizeOf(Result.Point1.X)))and(CompareMem(@Result.Point1.X, @A, SizeOf(Result.Point1.X))) then
      IntersectionMode := imPoint
    else
      IntersectionMode := imNone;
end;

function MaxTsgFloat: Extended;
begin
  case SizeOf(TsgFloat) of
    4: Result := MaxSingle;
    8: Result := MaxDouble;
    10: Result := MaxExtended;
  else
    Result := MaxSingle;
  end;
end;

function DistanceF(APoint1, APoint2: TFPoint): TsgFloat;
begin
  Result := Sqrt(Sqr(APoint2.X - APoint1.X) + Sqr(APoint2.Y - APoint1.Y) + Sqr(APoint2.Z - APoint1.Z));
end;

function DistanceI(APoint1, APoint2: TPoint): Double;
var
  P1X, P2X, P1Y, P2Y: Double;
begin
  P1X := APoint1.X;
  P2X := APoint2.X;
  P1Y := APoint1.Y;
  P2Y := APoint2.Y;
  Result := Sqrt(Sqr(P2X - P1X) + Sqr(P2Y - P1Y));
end;

procedure SwapInts(var A,B);
asm
	MOV	ECX,[EAX]
	XCHG	ECX,[EDX]
	MOV	[EAX],ECX
end;

function IsEqual(const AVal1, AVal2: TsgFloat): Boolean;
begin
  Result := Abs(AVal1 - AVal2) < fAccuracy;
end;

function IsEqualPoints(const Point1, Point2: TPoint): Boolean;
begin
  Result := (Point1.X = Point2.X) and (Point1.Y = Point2.Y);
end;

function IsEqualFPoints(const Point1, Point2: TFPoint): Boolean;
begin
  Result := (Abs(Point1.X - Point2.X) < fAccuracy) and (Abs(Point1.Y - Point2.Y) < fAccuracy) and
    (Abs(Point1.Z - Point2.Z) < fAccuracy);
end;

function IsEqualF2DPoints(const Point1, Point2: TF2DPoint): Boolean;
begin
  Result := (Abs(Point1.X - Point2.X) < fAccuracy) and (Abs(Point1.Y - Point2.Y) < fAccuracy);
end;

{$IFNDEF SGDEL_6}
function WideUpperCase(const S: WideString): WideString;
var
  Len: Integer;
begin
  Len := Length(S);
  SetString(Result, PWideChar(S), Len);
  if Len > 0 then CharUpperBuffW(Pointer(Result), Len);
end;
{$ENDIF}

initialization
  sgClientRect := Rect(MaxInt, 0, -1, -1);

end.