ezsystem.pas

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

    Result.Degrees := -Result.Degrees;
End;

{-------------------------------------------------------------------------------}
{                  TEzBufferedRead - class implementation                         }
{-------------------------------------------------------------------------------}
{$WARNINGS OFF}

Constructor TEzBufferedRead.Create( F: TStream; BuffSize: integer );
Begin
  Inherited Create;

  FStream := F;
  If FStream.Size < BuffSize Then
    BuffSize := FStream.Size;
  FSizeOfBuffer := BuffSize;
  GetMem( PBuffer, FSizeOfBuffer );

  FSectorInBuffer := -1;

  Seek( F.Position, 0 );

End;

Destructor TEzBufferedRead.Destroy;
Begin
  FreeMem( PBuffer, FSizeOfBuffer );

  Inherited Destroy;
End;

{procedure TEzBufferedRead.ResetPos;
begin
  FSectorInBuffer := -1;
  FStream.Seek(FPosition,0);
end; }

Function TEzBufferedRead.Seek( Offset: Longint; Origin: Word ): Longint;
Var
  TmpSector: LongInt;
Begin
  //Origin:= soFromBeginning; allways
  TmpSector := Offset Div FSizeOfBuffer;
  If FSectorInBuffer = TmpSector Then
  Begin
    FOffsetInBuffer := Offset Mod FSizeOfBuffer;
    //Result := TmpSector * FSizeOfBuffer + FOffsetInBuffer;
    Exit;
  End;
  FStream.Seek( TmpSector * FSizeOfBuffer, 0 );
  FOffsetInBuffer := Offset Mod FSizeOfBuffer; // offset in current buffer
  FBytesInBuffer := FStream.Read( PBuffer^, FSizeOfBuffer );
  FPosition := FStream.Position;
  FSectorInBuffer := TmpSector;
  //Result := TmpSector * FSizeOfBuffer + FOffsetInBuffer;
End;

{$R-}
Function TEzBufferedRead.Read( Var Buffer; Count: Longint ): Longint;
Var
  LocalBuffer: PChar;
  BufSize, N: Integer;

  Function ReadNextBuffer: Boolean;
  Begin
    // read next buffer and return false if cannot
    FStream.Position := FPosition;
    FBytesInBuffer := FStream.Read( PBuffer^, FSizeOfBuffer );
    FPosition := FStream.Position;
    Inc( FSectorInBuffer );
    FOffsetInBuffer := 0;
    Result := ( FBytesInBuffer > 0 );
  End;

  Function DoRead( Var Buff; Cnt: Longint ): Longint;
  Var
    N, Diff: Longint;
    Temp: PChar;
  Begin
    If FOffsetInBuffer + Cnt <= FBytesInBuffer Then
    Begin
      // in the buffer is full data
      Move( PBuffer^[FOffsetInBuffer], Buff, Cnt );
      Inc( FOffsetInBuffer, Cnt );
      Result := Cnt;
    End
    Else
    Begin
      // in the buffer is partial data
      N := FBytesInBuffer - FOffsetInBuffer;
      Move( PBuffer^[FOffsetInBuffer], Buff, N );
      Result := N;
      If Not ReadNextBuffer Then Exit;
      Diff := Cnt - N;
      Temp := @Buff;
      Inc( Temp, N );
      Move( PBuffer^[FOffsetInBuffer], Temp^, Diff );
      Inc( FOffsetInBuffer, Diff );
      Inc( Result, Diff );
    End;
  End;

Begin
  Result := 0;
  If Count < 1 Then Exit;
  If Count > FSizeOfBuffer Then
  Begin
    LocalBuffer := @Buffer;
    BufSize := FSizeOfBuffer;
    While Count > 0 Do
    Begin
      If Count > BufSize Then
        N := BufSize
      Else
        N := Count;
      Inc( Result, DoRead( LocalBuffer^, N ) );
      Inc( LocalBuffer, N );
      Dec( Count, N );
    End;
  End
  Else
    Result := DoRead( Buffer, Count );
End;

Function TEzBufferedRead.Write( Const Buffer; Count: Longint ): Longint;
Begin
  { -- not implemented -- }
  Result := 0;
End;
{$WARNINGS ON}

Procedure SortList( ol: TList );

  Procedure QuickSort( L, R: Integer );
  Var
    I, J: Integer;
    P, T: TObject;
  Begin
    Repeat
      I := L;
      J := R;
      P := ol[( L + R ) Shr 1];
      Repeat
        While Longint( ol[I] ) < Longint( P ) Do
          Inc( I );
        While Longint( ol[J] ) > Longint( P ) Do
          Dec( J );
        If I <= J Then
        Begin
          T := ol[I];
          ol[I] := ol[J];
          ol[J] := T;
          Inc( I );
          Dec( J );
        End;
      Until I > J;
      If L < J Then
        QuickSort( L, J );
      L := I;
    Until I >= R;
  End;

Begin
  If ol.Count > 0 Then
    QuickSort( 0, ol.Count - 1 );
End;

Function DeleteFileChecking( Const FileName: String ): Boolean;
Begin
  Result := false;
  If FileExists( FileName ) Then
  Begin
    Try
      TFileStream.Create( FileName, fmOpenReadWrite Or fmShareExclusive ).Free;
    Except
      Exit;
    End;
    Result := SysUtils.DeleteFile( FileName );
  End;
End;

{Delete a file and send it to the trash can
 is not working correctly !!!}
{$IFDEF FALSE}

Function DeleteFileWithUndo( Const sFileName: String ): boolean;
Var
  fos: TSHFileOpStruct;
Begin
  FillChar( fos, SizeOf( fos ), 0 );
  With fos Do
  Begin
    wFunc := FO_DELETE;
    pFrom := PChar( sFileName );
    fFlags := FOF_ALLOWUNDO Or FOF_NOCONFIRMATION Or FOF_SILENT;
  End;
  Result := ( 0 = ShFileOperation( fos ) );
End;
{$ENDIF}

{ -- Create TBitmap object from TIcon -- }

Function CreateBitmapFromIcon( Icon: TIcon; BackColor: TColor ): TBitmap;
Var
  IWidth, IHeight: Integer;
Begin
  IWidth := Icon.Width;
  IHeight := Icon.Height;
  Result := TBitmap.Create;
  Try
    Result.Width := IWidth;
    Result.Height := IHeight;
    With Result.Canvas Do
    Begin
      Brush.Color := BackColor;
      FillRect( Rect( 0, 0, IWidth, IHeight ) );
      Draw( 0, 0, Icon );
    End;
  Except
    Result.Free;
    Raise;
  End;
End;

Function AddSlash( Const Path: String ): String;
Begin
  result := Path;
  If ( Length( result ) > 0 ) And ( result[length( result )] <> '\' ) Then
    result := result + '\'
End;

Function RemoveSlash( Const Path: String ): String;
Var
  rlen: integer;
Begin
  result := Path;
  rlen := length( result );
  If ( rlen > 0 ) And ( result[rlen] = '\' ) Then
    Delete( result, rlen, 1 );
End;

Function GetTemporaryLayerName( Const Path, Prefix: String ): String;
Var
  FileName: Array[0..1023] Of char;
Begin
  GetTempFileName( PChar( Path ), PChar( Prefix ), 0, FileName );
  result := FileName;
End;

Function GetTemporaryFileName( Const Prefix: String ): String;
Var
  TempPath: Array[0..1023] Of char;
  FileName: Array[0..1023] Of char;
Begin
  GetTempPath( 1023, TempPath );
  GetTempFileName( TempPath, PChar( Prefix ), 0, FileName );
  result := FileName;
End;

Function SystemDirectory: String;
Var
  buffer: Array[0..MAX_PATH] Of char;
Begin
  GetSystemDirectory( buffer, sizeof( buffer ) );
  result := AddSlash( StrPas( buffer ) );
End;

Const
  A2 = 'TAlignPalette';
  //A3 = 'TPropertyInspector';
  A4 = 'TAppBuilder';

Function DelphiRunning: boolean;
Var
  H2, {H3,} H4: Hwnd;
Begin
  H2 := FindWindow( A2, Nil );
  //H3 := FindWindow(A3, nil);
  H4 := FindWindow( A4, Nil );
  Result := ( H2 <> 0 ) {and (H3 <> 0)} And ( H4 <> 0 );
End;

{-------------------------------------------------------------------------}

Function WindowsDirectory: String;
Var
  buffer: Array[0..MAX_PATH] Of char;
Begin
  GetWindowsDirectory( buffer, SizeOf( buffer ) );
  result := AddSlash( StrPas( buffer ) );
End;

Function MessageToUser( Const Msg, Caption: String; AType: Word ): Word;
Begin
  Result := Application.Messagebox( pchar( Msg ), pchar( Caption ), MB_OK Or AType );
End;

Procedure SetupCursors;
Begin
  With Screen Do          
  Begin
    Cursors[crZoomIn] := Windows.LoadCursor( HInstance, 'ZOOMIN' );
    Cursors[crZoomOut] := LoadCursor( HInstance, 'ZOOMOUT' );
    Cursors[crScrollingUp] := LoadCursor( HInstance, 'SCROLLING_UP' );
    Cursors[crScrollingDn] := LoadCursor( HInstance, 'SCROLLING_DN' );
    Cursors[crRealTimeZoom] := LoadCursor( HInstance, 'REALTIMEZ' );
    Cursors[crHidden] := LoadCursor( HInstance, 'CR_HIDDEN' );
    Cursors[crDrawCross] := LoadCursor( HInstance, 'DRAW_CROSS' );
    Cursors[crRotate] := LoadCursor( HInstance, 'ROTATE' );
  End;
End;

Procedure DisposeCursors;
Begin
  With Screen Do
  Begin
    Cursors[crZoomIn] := 0;
    Cursors[crZoomOut] := 0;
    Cursors[crScrollingUp] := 0;
    Cursors[crScrollingDn] := 0;
    Cursors[crRealTimeZoom] := 0;
    Cursors[crHidden] := 0;
    Cursors[crDrawCross] := 0;
    Cursors[crRotate] := 0;
  End
End;

Procedure AddMarker( DrawBox: TEzBaseDrawBox; Const X, Y: Double; SetInView: Boolean );
Var
  TmpPlace: TEzPlace;
  Extents: TEzRect;
  CX, CY, TmpWidth, TmpHeight, TmpMarginX, TmpMarginY: Double;
Begin
  With DrawBox, Ez_Preferences Do
  Begin
    If Ez_Symbols.Count = 0 Then Exit;

    TmpPlace := TEzPlace.CreateEntity( Point2D( X, Y ) );
    With TmpPlace.Symboltool.FSymbolStyle Do
    Begin
      If SymbolMarker > Ez_Symbols.Count - 1 Then
        SymbolMarker := 0;
      Index := SymbolMarker;
      Height := Grapher.getrealsize( DefSymbolStyle.height );
      TmpPlace.UpdateExtension;
      TempEntities.Add( TmpPlace );
    End;
    If Not SetInView Then Exit;
    TmpPlace.UpdateExtension;
    Extents := TmpPlace.FBox;
    With Extents Do
    Begin
      CX := ( Emin.X + EMax.X ) / 2;
      CY := ( Emin.Y + EMax.Y ) / 2;
    End;
    With Grapher.CurrentParams.VisualWindow Do
    Begin
      TmpWidth := ( Emax.X - Emin.X ) / 2;
      TmpHeight := ( Emax.Y - Emin.Y ) / 2;
    End;
    TmpMarginX := 0;
    TmpMarginY := 0;
    With Extents Do
    Begin
      Emin.X := CX - TmpWidth - TmpMarginX;
      Emax.X := CX + TmpWidth + TmpMarginX;
      Emin.Y := CY - TmpHeight - TmpMarginY;
      Emax.Y := CY + TmpHeight + TmpMarginY;
    End;
    Grapher.SetViewTo( Extents );
    Repaint;
  End;
End;

{ freelist }

Procedure freelist( Var alist: TList );
Var
  i: Integer;
Begin
  If alist = Nil Then Exit;
  For i := 0 To alist.count - 1 Do
    TObject( alist[i] ).free;
  FreeAndNil( alist );
End;

{ GetListOfVectors }

Function GetListOfVectors( Entity: TEzEntity ): TList;
Var
  I, n, Idx1, Idx2: Integer;
  V, SrcV: TEzVector;
Begin
  If Entity.EntityID In [idPolyline, idPolygon] Then
    SrcV := Entity.Points
  Else
    SrcV := Entity.DrawPoints;
  Result := TList.Create;
  n := 0;
  If SrcV.Parts.Count < 2 Then
  Begin
    Idx1 := 0;
    Idx2 := SrcV.Count - 1;
  End
  Else
  Begin
    Idx1 := SrcV.Parts[n];
    Idx2 := SrcV.Parts[n + 1] - 1;
  End;
  Repeat
    V := TEzVector.Create( Succ( Idx2 - Idx1 ) );
    For I := Idx1 To Idx2 Do
      V.Add( SrcV[I] );
    Result.Add( V );
    If SrcV.Parts.Count < 2 Then
      Break;
    Inc( n );
    If n >= SrcV.Parts.Count Then
      Break;
    Idx1 := SrcV.Parts[n];
    If n < SrcV.Parts.Count - 1 Then
      Idx2 := SrcV.Parts[n + 1] - 1
    Else
      Idx2 := SrcV.Count - 1;
  Until false;
End;

{ ExplodeSelection }

Procedure ExplodeSelection( DrawBox: TEzBaseDrawBox; PreserveOriginals: Boolean );
Var
  Idx, J, K, NewRecno: Integer;
  TmpEnt, TmpEnt2: TEzEntity;
  TempL: TList;
  Cnt: TEzEntityID;
  Entities: Array[TEzEntityID] Of TEzEntity;
  AvoidList: TIntegerList;
Begin
  With DrawBox Do
  Begin
    For Cnt := Low( TEzEntityID ) To High( TEzEntityID ) Do