ezsystem.pas

来自「很管用的GIS控件」· PAS 代码 · 共 2,202 行 · 第 1/5 页

Unit EzSystem;

{***********************************************************}
{     EzGIS/CAD Components                                  }
{   (c) 2003 EzSoft Engineering                             }
{         All Rights Reserved                               }
{***********************************************************}

{$I EZ_FLAG.PAS}
Interface

Uses
  SysUtils, Windows, Classes, Graphics, Controls, StdCtrls, Forms,
  EzBaseGIS, EzBase, EzBaseExpr, EzLib, EzEntities, IniFiles;

Const
  { mouse cursors used in the system }
  crZoomIn = 1;
  crZoomOut = 2;
  crScrollingUp = 3;
  crScrollingDn = 4;
  crRealTimeZoom = 5;
  crHidden = 6;
  crDrawCross = 7;
  crRotate = 8;
  { buffered read }
  SIZE_LONGBUFFER = 100 * 1024;

Type

  {-------------------------------------------------------------------------------}
  {                  TEzBufferedRead                                              }
  {-------------------------------------------------------------------------------}

  PCharArray = ^TCharArray;
  TCharArray = Array[0..0] Of Char;

  TEzBufferedRead = Class( TStream )
  Private
    FStream: TStream;
    FBytesInBuffer: Integer;
    FSectorInBuffer: Integer;
    FOffsetInBuffer: Integer;
    PBuffer: PCharArray;
    FSizeOfBuffer: Integer;
    FPosition: Integer; // internal position
  Public
    Constructor Create( F: TStream; BuffSize: Integer );
    Destructor Destroy; Override;
    Function Read( Var Buffer; Count: Longint ): Longint; Override;
    Function Seek( Offset: Longint; Origin: Word ): Longint; Override;
    Function Write( Const Buffer; Count: Longint ): Longint; Override;
    //procedure ResetPos;
  End;


  {------------------------------------------------------------------------------}
  {                  Miscelaneous                                                }
  {------------------------------------------------------------------------------}

Procedure EzGISError( Const ErrStr: String );
Procedure SortList( ol: TList );
Function GetTemporaryLayerName( Const Path, Prefix: String ): String;
Function GetTemporaryFileName( Const Prefix: String ): String;
Function WindowsDirectory: String;
Function SystemDirectory: String;
{$IFDEF FALSE}
Function DeleteFileWithUndo( Const sFileName: String ): boolean;
{$ENDIF}
Function AddSlash( Const Path: String ): String;
Function RemoveSlash( Const Path: String ): String;
Function CreateBitmapFromIcon( Icon: TIcon; BackColor: TColor ): TBitmap;
Function MessageToUser( Const Msg, Caption: String; AType: Word ): Word;
Function DelphiRunning: boolean;
Procedure AddMarker( DrawBox: TEzBaseDrawBox; Const X, Y: Double; SetInView: Boolean );
Function DeleteFileChecking( Const FileName: String ): Boolean;
Procedure CombineSelection( DrawBox: TEzBaseDrawBox; DeleteOriginals: Boolean );
Procedure ExplodeSelection( DrawBox: TEzBaseDrawBox; PreserveOriginals: Boolean );
Procedure ReadFile( Const Path: String; FileList: TStrings );
Procedure freelist( Var alist: TList );
Function GetListOfVectors( Entity: TEzEntity ): TList;
Function CreateIfNotExists( Const FileName: String ): TFileStream;
Function CreateDllList( FieldList: TStringList ): String;
Function HasAttr( Const FileName: String; Attr: Word ): Boolean;
Function DegMinSec2Extended( Const DegMinSec: TDegMinSec ): Double;
Function Extended2DegMinSec( Const RealDeg: Double ): TDegMinSec;
Procedure DeleteDuplicatedVertexes( Ent: TEzEntity );
Function LoadSingleSelEntity( DrawBox: TEzBaseDrawBox;
  Var Layer: TEzBaseLayer;
  Var Recno: Integer ): TEzEntity;
Procedure ShowGuideLines( DrawBox: TEzBaseDrawBox;
  HGuideLines, VGuideLines: TEzDoubleList );
Procedure SendToBack( DrawBox: TEzBaseDrawBox );
Procedure BringToFront( DrawBox: TEzBaseDrawBox );
Procedure PaintDrawBoxFSGrid( DrawBox: TEzBaseDrawBox; const WCRect: TEzRect );
function Dark(Col: TColor; Percent: Byte): TColor;
Function Perimeter( Vect: TEzVector; MustClose: Boolean ): Double;
Procedure BlinkEntity( DrawBox: TEzBaseDrawBox; Layer: TEzBaseLayer; RecNo: Integer );
Procedure BlinkEntityIndirect( DrawBox: TEzBaseDrawBox; Entity: TEzEntity );
Procedure BlinkEntities( DrawBox: TEzBaseDrawBox );
Procedure HiliteEntity( Entity: TEzEntity; DrawBox: TEzBaseDrawBox );
Procedure UnHiliteEntity( Entity: TEzEntity; DrawBox: TEzBaseDrawBox );
Function CreateBufferFromEntity( Entity: TEzEntity; CurvePoints: Integer;
  Distance: Double ): TEzEntity;
Function Field2Exprtype( Layer: TEzBaseLayer; FieldNo: Integer ): TExprtype;
procedure SaveFont(FStream: TIniFile; Section: string; smFont: TFont);
procedure LoadFont(FStream: TIniFile; Section: string; smFont: TFont);
Function Dpi2Units( iUnits: TEzScaleUnits; Dpis, Value: integer ): Double;
Function Units2Dpi( iUnits: TEzScaleUnits; Dpis: Integer; Value: Double ): integer;
Function Units2Inches( iUnits: TEzScaleUnits; Value: Double ): Double;
Function Inches2Units( iUnits: TEzScaleUnits; Value: Double ): Double;
Procedure EzWriteStrToStream( Const TextToWrite: String; stream: TStream );
Function EzReadStrFromStream( stream: TStream ): String;
Function StringIndex( Const SearchString: String; const StrList: Array Of String ): Integer;
Function GetCurrentColorDepth: Integer;
Procedure SaveFormPlacement( const IniFilename: string; Frm: TForm; Additional: TStrings);
Procedure RestoreFormPlacement( const IniFilename: string; Frm: TForm;
  ShwNormal: Boolean; Additional: TStrings );
Function RemoveStrDelim( Const S: String ): String;
function DeleteFilesSameName( const Filename: string ): Boolean;
Function AddBrackets( const Value: string): string;
Function ReadFloatFromIni( IniFile: TIniFile; Const Section, Ident: string; Const Default: Double): Double;
Function ReadIntFromIni( IniFile: TIniFile; Const Section, Ident: string; Default: Integer): Integer;
Procedure WriteFloatToIni( IniFile: TIniFile; Const Section, Ident: string; Value: Double);
Function GetValidLayerName( const OrigLayerName: string): string;
Function TrimCrLf(const s: string): string;
Function ComplColor(Clr: TColor):TColor;
Procedure GetMessageboxFont( afont: TFont );
Function DefaultFontName: string;
function DefaultFont: TFont;
Function DefaultFontHandle: HFont;
Function GetParentFormHWND( Control: TWinControl ): HWND;
Procedure HideFormTitleBar(Form: TForm);
Procedure ShowFormTitleBar(Form: TForm);

{$IFDEF LEVEL4}
{$IFNDEF LEVEL5}
Procedure FreeAndNil( Var Obj );
{$ENDIF}
{$ENDIF}

{ global variables }

Var
  Ez_Preferences: TEzPreferences; // ezbase
  Ez_Symbols: TEzSymbols; // ezbasegis
  Ez_VectorFonts: TEzVectorFonts; // ezentities
  Ez_LineTypes: TEzSymbols; // ezbasegis
  Ez_Hatches: TEzHatchList; // ezentities
  { this temporary entity is used in several situations }
  GlobalTempEntity: TEzEntity;

Implementation

Uses
  EzExprLex, EzExprYacc, EzLexLib, EzYaccLib, EzConsts, Ezpolyclip,
  EzGraphics, ezrtree;

{$IFDEF LEVEL4}
{$IFNDEF LEVEL5}

Procedure FreeAndNil( Var Obj );
Var
  P: TObject;
Begin
  P := TObject( Obj );
  TObject( Obj ) := Nil; // clear the reference before destroying the object
  P.Free;
End;
{$ENDIF}
{$ENDIF}

{This function will return the number of bits per pixel
 (8, 16, 24...) for the current desktop resolution }

Function GetCurrentColorDepth: Integer;
Var
  topDC: HDC;
Begin
  topDC := GetDC( 0 );
  Try
    Result := GetDeviceCaps( topDC, BITSPIXEL ) * GetDeviceCaps( topDC, PLANES );
  Finally
    ReleaseDC( 0, topDC );
  End;
End;

Function StringIndex( Const SearchString: String; const StrList: Array Of String ): Integer;
Var
  I: Integer;
Begin
  Result := -1;
  For I := 0 To High( StrList ) Do
    If CompareText( SearchString, StrList[I] ) = 0 Then
    Begin
      Result := I;
      Break;
    End;
End;

{-------------------------------------------------------------------------------}
{ End of section of expression evaluator                                        }
{-------------------------------------------------------------------------------}

Function Dpi2Units( iUnits: TEzScaleUnits; Dpis, Value: integer ): Double;
Begin
  result := Value / Dpis;
  If iUnits = suMms Then
    result := result * 25.4
  Else If iUnits = suCms Then
    result := result * 2.54;
End;

Function Units2Dpi( iUnits: TEzScaleUnits; Dpis: Integer; Value: Double ): integer;
Var
  u: Double;
Begin
  u := Value;
  If iUnits = suMms Then
    u := Value / 25.4
  Else If iUnits = suCms Then
    u := Value / 2.54;
  result := trunc( u * Dpis );
End;

Function Units2Inches( iUnits: TEzScaleUnits; Value: Double ): Double;
Begin
  result := Value;
  If iUnits = suMms Then
    result := result / 25.4
  Else If iUnits = suCms Then
    result := result / 2.54;
End;

Function Inches2Units( iUnits: TEzScaleUnits; Value: Double ): Double;
Begin
  result := Value;
  If iUnits = suMms Then
    result := result * 25.4
  Else If iUnits = suCms Then
    result := result * 2.54;
End;

{ Field2Exprtype }

Function Field2Exprtype( Layer: TEzBaseLayer; FieldNo: Integer ): TExprtype;
Begin
  Result := ttString;
  If Layer.DBTable = Nil Then Exit;

  Case Layer.DBTable.FieldType( FieldNo ) Of
    'C': Result := ttString;
    'N', 'F', 'T': Result := ttFloat;
    'D', 'I': Result := ttInteger;
    'L': Result := ttBoolean;
  End;
End;

{ CreateBufferFromEntity }

Function CreateBufferFromEntity( Entity: TEzEntity; CurvePoints: Integer;
  Distance: Double ): TEzEntity;
Var
  TmpEnt, TmpPolygon, TmpArc1, TmpArc2: TEzEntity;
  subject, clipping, clipresult: TEzEntityList;
  RefLength, Scale: Double;
  p1, p2, pc, p1s, p2s, p1arc1, p2arc1, p1arc2, p2arc2: TEzPoint;
  I, J, part: Integer;
  Matrix: TEzMatrix;
Begin
  Result := Nil;
  If Entity.EntityID = idPlace Then
  Begin
    p1 := Entity.Points[0];
    Result := TEzEllipse.CreateEntity( Point2D( P1.X - Distance / 2,
      P1.Y - Distance / 2 ),
      Point2D( P1.X + Distance / 2, P1.Y + Distance / 2 ) );
  End
  Else If Entity.EntityID In [idPolyline, idPolygon, idSpline, idRectangle,
    idArc, idEllipse] Then
  Begin
    { now, for every entity, generate a polygon around it }
    subject := TEzEntityList.Create;
    clipping := TEzEntityList.Create;
    clipresult := TEzEntityList.Create;
    Try
      Try
        { transform every line segment into a polygon }
        For i := 0 To Entity.DrawPoints.Count - 2 Do
        Begin
          p1 := Entity.DrawPoints[i];
          p2 := Entity.DrawPoints[i + 1];
          { calculate the center of line segment }
          pc := Point2D( ( p1.x + p2.x ) / 2, ( p1.y + p2.y ) / 2 );
          { calculate a reference length for scaling }
          RefLength := Dist2D( pc, p1 );
          If RefLength = 0 Then
            RefLength := Distance;
          { now scale the line segment }
          Scale := 1 + ( Distance / 2 ) / RefLength;
          Matrix := Scale2D( Scale, Scale, pc );
          p1s := TransformPoint2D( p1, Matrix );
          p2s := TransformPoint2D( p2, Matrix );

          { rotate p1s to the right  }
          Matrix := Rotate2D( System.Pi / 2, p1 );
          p2arc1 := TransformPoint2D( p1s, Matrix );
          { rotate p1s to the left  }
          Matrix := Rotate2D( -System.Pi / 2, p1 );
          p1arc1 := TransformPoint2D( p1s, Matrix );

          { now the opposite point }
          { rotate p2s to the right  }
          Matrix := Rotate2D( System.Pi / 2, p2 );
          p2arc2 := TransformPoint2D( p2s, Matrix );
          { rotate p1s to the left  }
          Matrix := Rotate2D( -System.Pi / 2, p2 );
          p1arc2 := TransformPoint2D( p2s, Matrix );

          { now, create two arcs with these points calculated }
          TmpArc1 := TEzArc.CreateEntity( p1arc1, p1s, p2arc1 );
          TEzArc( TmpArc1 ).PointsInCurve := CurvePoints;
          TmpArc2 := TEzArc.CreateEntity( p1arc2, p2s, p2arc2 );
          TEzArc( TmpArc2 ).PointsInCurve := CurvePoints;
          Try
            { now, build the polygon points with this }
            TmpPolygon := TEzPolygon.CreateEntity( [Point2D( 0, 0 )] );
            With TmpPolygon.Points Do
            Begin
              Clear;
              For J := 0 To TmpArc1.DrawPoints.Count - 1 Do
                Add( TmpArc1.DrawPoints[J] );
              Add( p1arc2 );
              For J := 0 To TmpArc2.DrawPoints.Count - 1 Do
                Add( TmpArc2.DrawPoints[J] );
              Add( p1arc1 );
            End;
          Finally
            TmpArc1.Free;
            TmpArc2.Free;
          End;
          { it is the last line segment ?}
          If i = 0 Then
          Begin
            If Entity.DrawPoints.Count = 2 Then
            Begin
              clipresult.Add( TmpPolygon );
            End
            Else
              subject.Add( TmpPolygon );
          End
          Else
          Begin
            FreeAndNil( Clipping );
            clipping := TEzEntityList.Create;
            clipping.Add( TmpPolygon );
            Ezpolyclip.polygonClip( pcUNION, subject, clipping, clipresult, Nil );
            If i < Entity.DrawPoints.Count - 2 Then
            Begin
              FreeAndNil( subject );
              subject := TEzEntityList.Create;
              For j := 0 To clipresult.Count - 1 Do
                subject.Add( clipresult[j] );
              clipresult.ExtractAll;
            End;
          End;
        End;
        Result := TEzPolygon.CreateEntity( [Point2D( 0, 0 )] );
        Result.Points.Clear;
        part := 0;
        For I := 0 To clipresult.count - 1 Do
        Begin
          If I > 0 Then
          Begin
            If I = 1 Then
              Result.Points.Parts.Add( 0 );
            Result.Points.Parts.Add( part );
          End;
          TmpEnt := clipresult[I];
          For J := 0 To TmpEnt.Points.Count - 1 Do
          Begin
            Result.Points.Add( TmpEnt.Points[J] );
            Inc( part );
          End;
        End;
        With TEzPolygon( Result ) Do
        Begin
          If Entity Is TEzOpenedEntity Then
            Pentool.Assign( TEzOpenedEntity( Entity ).PenTool );
          If Entity Is TEzClosedEntity Then
            Brushtool.Assign( TEzClosedEntity( Entity ).BrushTool );
        End;
      Except
        MessageTouser( SWrongBuffer, smsgerror, MB_ICONERROR );
        Abort;
      End;
    Finally
      subject.free;
      clipping.free;
      clipresult.free;
    End;
  End
  Else
    EzGISError( SCannotCreateBuffer );
End;

{ LoadSingleSelEntity }

Function LoadSingleSelEntity( DrawBox: TEzBaseDrawBox; Var Layer: TEzBaseLayer;
  Var Recno: Integer ): TEzEntity;
Var
  SelLayer: TEzSelectionLayer;
Begin
  Result := Nil;
  If DrawBox.Selection.NumSelected <> 1 Then
    Exit;
  { Caller is responsible for freeing the TEzEntity result }
  With DrawBox Do
  Begin
    SelLayer := Selection.Items[0];
    Layer := SelLayer.Layer;
    Recno := SelLayer.SelList[0];
    Layer.Recno := Recno;
    Result := Layer.RecLoadEntity;
  End;
  //Result.DrawBox:= DrawBox;
End;

{ SendToBack }

Procedure SendToBack( DrawBox: TEzBaseDrawBox );
Var
  SelLayer: TEzSelectionLayer;
  Layer: TEzBaseLayer;
  FirstRecno: Integer;
Begin
  With DrawBox Do
  Begin
    If Selection.NumSelected <> 1 Then
      Exit;
    selLayer := Selection.Items[0];