ezsystem.pas

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

    rcPos := wpPos.rcNormalPosition;
    WriteInteger( SectionName, 'Top', rcPos.top );
    WriteInteger( SectionName, 'Left', rcPos.left );
    WriteInteger( SectionName, 'Bottom', rcPos.bottom );
    WriteInteger( SectionName, 'Right', rcPos.right );
    if Additional <> Nil then
    begin
      n:= Additional.Count;
      WriteInteger( SectionName + 'AddInfo', 'Lines',n );
      for I:= 0 to n-1 do
        WriteString( SectionName + 'AddInfo', 'Line' + IntToStr(I), Additional[I] );
    end;
  Finally
    free;
  End;

End;

const
  SQUOTE = ['''', '"'];

Function RemoveStrDelim( Const S: String ): String;
Begin
  If ( Length( S ) >= 2 ) And
     ( S[1] In SQUOTE ) And ( S[Length( S )] In SQUOTE ) Then
    Result := Copy( S, 2, Length( S ) - 2 )
  Else
    Result := S;
End;

Function AddBrackets( const Value: string ): string;
Begin
  if AnsiPos(#32, Value) > 0 then
    Result:= '[' + Value + ']'
  else
    Result:= Value;
End;

function DeleteFilesSameName( const Filename: string ): Boolean;
Var
  layname: String;
  SR: TSearchRec;
  Found: Integer;
  source: String;
Begin
  Result := True;
  layname := ChangeFileExt( FileName, '' );
  source := ExtractFilepath( FileName );
  // Remove the files in the directory
  Found := FindFirst( layname + '.*', faAnyFile, SR );
  Try
    While Result And ( Found = 0 ) Do
    Begin
      If ( SR.Name <> '.' ) And ( SR.Name <> '..' ) Then
      Begin
        // Remove attributes that could prevent us from deleting the file
        FileSetAttr( source + SR.Name, FileGetAttr( source + SR.Name ) And
          Not ( $00000001 Or $00000002 ) );
        // Delete file
        If Not SysUtils.DeleteFile( source + SR.Name ) Then
          Result := False;
      End;
      Found := FindNext( SR );
    End;
  Finally
    Sysutils.FindClose( SR );
  End;
  Result := true;
end;

Function ReadFloatFromIni( IniFile: TIniFile; Const Section, Ident: string; Const Default: Double): Double;
var
  temp: string;
  Code: Integer;
begin
  System.Str(Default:32:16,temp);
  temp:= Inifile.ReadString( Section, Ident, trim(temp) );
  System.Val( temp, Result, Code );
  If Code <> 0 then Result:= 0;
  If Abs(Result) < 1E-10 then Result:= 0;
end;

Procedure WriteFloatToIni( IniFile: TIniFile; Const Section, Ident: string; Value: Double);
var
  temp: string;
begin
  if Abs(Value) < 1E-10 then Value:= 0;
  System.Str(Value:32:16,temp);
  Inifile.WriteString( Section, Ident, trim(temp) );
end;

Function ReadIntFromIni( IniFile: TIniFile; Const Section, Ident: string; Default: Integer): Integer;
var
  temp: string;
  Code: Integer;
begin
  temp:= Inifile.ReadString( Section, Ident, IntToStr( Default ) );
  Val( temp, Result, Code );
  If Code <> 0 then Result:= 0;
end;

Function GetValidLayerName( const OrigLayerName: string): string;
Var
  I: Integer;
  Found: Boolean;
begin
  Result:= OrigLayerName;
  If (Length(Result) > 0) And Not( Result[1] In ['A'..'Z', 'a'..'z', #127..#255, '_'] ) Then
    Result:= 'A' + Result;
  repeat
    Found:= false;
    For I:= 2 to Length(Result) do
    begin
      If Not( Result[I] In ['A'..'Z', 'a'..'z', '0'..'9', '_', #127..#255] ) Then
      begin
        Found:= true;
        Break;
      end;
    end;
    if Found then
    begin
      Result := StringReplace( Result, Result[I], '_', [rfReplaceAll, rfIgnoreCase] );
    end;
  until not found;
end;

function TrimCrLf(const s: string): string;
begin
  Result:= s;
  While (Length(Result) > 0) and (Result[Length(Result)] in [#13,#10]) do
    System.Delete(Result, Length(Result), 1);
end;

Function ComplColor(Clr: TColor):TColor;
var
  r,g,b: Byte;
Begin
  r:= GetRValue(clr);
  g:= GetGValue(clr);
  b:= GetBValue(clr);
  Result:= RGB(255-r,255-g,255-b);
End;

function Dark(Col: TColor; Percent: Byte): TColor;
var
  R, G, B: Byte;
begin
  R := GetRValue(Col);
  G := GetGValue(Col);
  B := GetBValue(Col);
  R := Round(R*Percent/100);
  G := Round(G*Percent/100);
  B := Round(B*Percent/100);
  Result := RGB(R, G, B);
end;

function Light(Col: TColor; Percent: Byte): TColor;
var R, G, B: Byte;
begin
  R := GetRValue(Col);
  G := GetGValue(Col);
  B := GetBValue(Col);
  R := Round(R*Percent/100) + Round(255 - Percent/100*255);
  G := Round(G*Percent/100) + Round(255 - Percent/100*255);
  B := Round(B*Percent/100) + Round(255 - Percent/100*255);
  Result := RGB(R, G, B);
end;

Function DefaultFontHandle: HFont;
var
  ncMetrics: TNonClientMetrics;
begin
  ncMetrics.cbSize := sizeof(TNonClientMetrics);
  SystemParametersInfo(SPI_GETNONCLIENTMETRICS,
                       sizeof(TNonClientMetrics),
                       @ncMetrics, 0);
  Result:= CreateFontIndirect(ncMetrics.lfMessageFont);
End;

Procedure GetMessageboxFont( afont: TFont );
begin
  assert(assigned(afont));
  afont.Handle  := DefaultFontHandle;
end;

function DefaultFont: TFont;
Begin
  Result:= TFont.Create;
  GetMessageboxFont(Result);
End;

Function DefaultFontName: string;
var
  aFont: TFont;
Begin
  aFont:= DefaultFont;
  try
    Result:= aFont.Name;
  finally
    aFont.free;
  end;
end;

Function GetParentFormHWND( Control: TWinControl ): HWND;
begin
{$IFDEF GEN_ACTIVEX}
  Result := Windows.GetParent( Control.Handle );
{$ELSE}
  Result := GetParentForm( Control ).Handle;
{$ENDIF}
end;

Procedure ShowFormTitlebar(Form: TForm);
Var
  Save : LongInt;
begin
  with Form do
  begin
    If BorderStyle=bsNone then Exit;
    Save:=GetWindowLong(Handle,gwl_Style);
    If (Save and ws_Caption)<>ws_Caption then Begin
      Case BorderStyle of
        bsSingle,
        bsSizeable : SetWindowLong(Handle,gwl_Style,Save or
          ws_Caption or ws_border);
        bsDialog : SetWindowLong(Handle,gwl_Style,Save or
          ws_Caption or ds_modalframe or ws_dlgframe);
      End;
      Height:=Height+getSystemMetrics(sm_cyCaption);
      Refresh;
    End;
  end;
end;

Procedure HideFormTitlebar(Form: TForm);
Var
  Save : LongInt;
Begin
  with Form do
  begin
    If BorderStyle=bsNone then Exit;
    Save:=GetWindowLong(Handle,gwl_Style);
    If (Save and ws_Caption)=ws_Caption then Begin
      Case BorderStyle of
        bsSingle,
        bsSizeable : SetWindowLong(Handle,gwl_Style,Save and
          (Not(ws_Caption)) or ws_border);
        bsDialog : SetWindowLong(Handle,gwl_Style,Save and
          (Not(ws_Caption)) or ds_modalframe or ws_dlgframe);
      End;
      Height:=Height-getSystemMetrics(sm_cyCaption);
      Refresh;
    End;
  end;
end;


{PaintTo draw the visible client area of a RichEdit control to the
TCanvas. Use following method to render the complete contents to your
TCanvas.

DestDCHandle is TCanvas.Handle, R is the Rect with relation to your
canvas, RichEdit is a TRichEdit-Instance (can be invisible),
PixelsPerInch is the Resolution (for Screen e.g. 96).}
{$IFDEF FALSE}
procedure DrawRTF(DestDCHandle: HDC; const R: TRect;
  RichEdit: TRichEdit; PixelsPerInch: Integer);
var
  TwipsPerPixel: Integer;
  Range: TFormatRange;
begin
  TwipsPerPixel := 1440 div PixelsPerInch;
  with Range do
  begin
    hDC       := DestDCHandle;     // DC handle
    hdcTarget := DestDCHandle;     // ditto
    // convert the coordinates to twips (1/1440")
    rc.Left   := R.Left   * TwipsPerPixel;
    rc.Top    := R.Top    * TwipsPerPixel;
    rc.Right  := R.Right  * TwipsPerPixel;
    rc.Bottom := R.Bottom * TwipsPerPixel;
    rcPage := rc;
    chrg.cpMin := 0;
    chrg.cpMax := -1; // RichEdit.GetTextLen;
    // Free cached information
    RichEdit.Perform(EM_FORMATRANGE, 0, 0);
    // first measure the text, to find out how high the format rectangle
    // will be. The call sets fmtrange.rc.bottom to the actual height
    // required, if all characters in the selected range will fit into
    // a smaller rectangle,
    RichEdit.Perform(EM_FORMATRANGE, 0, DWord(@Range));
    // Now render the text
    RichEdit.Perform(EM_FORMATRANGE, 1, DWord(@Range));
    // Free cached information
    RichEdit.Perform(EM_FORMATRANGE, 0, 0);
  end;
end;
{$ENDIF}

{Sample 1:

procedure TForm1.Button1Click(Sender: TObject);
var
  RichEdit: TRichEdit;
  bmp: TBitmap;
  DestDCHandle: HDC;
begin
  RichEdit := TRichEdit.Create(Self);
  try
    RichEdit.Visible := False;
    RichEdit.Parent := Self;
    // Win2k, WinXP
    RichEdit.Lines.LoadFromFile('filename.rtf');
    bmp := TBitmap.Create;
    try
      bmp.width := 500;
      bmp.height := 500;
      DestDCHandle := bmp.Canvas.Handle;
      DrawRTF(DestDCHandle, Rect(0, 0, bmp.Width, bmp.Height),
        RichEdit, 96);
      Image1.Picture.Assign(bmp);
    finally
      bmp.Free;
    end;
  finally
    RichEdit.Free;
  end;
end;

Sample 2 (draw transparent):

procedure TForm1.Button1Click(Sender: TObject);
var
  RichEdit: TRichEdit;
  ExStyle: DWord;
  bmp: TBitmap;
  DestDCHandle: HDC;
begin
  RichEdit := TRichEdit.Create(Self);
  try
    RichEdit.Visible := False;
    RichEdit.Parent := Self;
    // Win2k, WinXP
    ExStyle := GetWindowLong(RichEdit.Handle, GWL_EXSTYLE);
    ExStyle := ExStyle or WS_EX_TRANSPARENT;
    SetWindowLong(RichEdit.Handle, GWL_EXSTYLE, ExStyle);
    RichEdit.Lines.LoadFromFile('filename.rtf');
    bmp := TBitmap.Create;
    try
      bmp.LoadFromFile('filename.bmp');
      DestDCHandle := bmp.Canvas.Handle;
      // Win9x
      SetBkMode(DestDCHandle, TRANSPARENT);
      DrawRTF(DestDCHandle, Rect(0, 0, bmp.Width, bmp.Height),
        RichEdit, 96);
      Image1.Picture.Assign(bmp);
    finally
      bmp.Free;
    end;
  finally
    RichEdit.Free;
  end;
end; }

function ArrayOfByteToHexString(const A: array of Byte): AnsiString;
var
   i: Integer;
   Temp: AnsiString;
begin
   Result := '';
   for i := Low(A) to High(A) do
   begin
     Temp := ' ' + IntToHex(A[i], 2);
     // following is optional
     if i mod 16 = 0 then
       Temp := Temp + #13#10
     else if (i mod 8)<>0 then
       Temp := Temp + '-';
   end;
   Result := Trim(Temp);
end;

{ tracking window movement

type
   TForm1 = class(TForm)
     ListBox1: TListBox;
   private
   public
     procedure WMWindowPosChanged(var Msg: TMessage); message WM_WINDOWPOSCHANGED;
     procedure WMWindowPosChanging(var Msg: TMessage); message WM_WINDOWPOSCHANGING;
   end;

procedure TForm1.WMWindowPosChanged(var Msg: TMessage);
begin
   ListBox1.Items.Add('Changed');
   ListBox1.TopIndex := ListBox1.Items.Count - 1;

   inherited;
end;

procedure TForm1.WMWindowPosChanging(var Msg: TMessage);
begin
   ListBox1.Items.Add('Changing');
   ListBox1.TopIndex := ListBox1.Items.Count - 1;

   inherited;
end;

You can easily obtain the desktop workarea (ie the free area excluding the
taskbar using a Windows API :

SystemParametersInfo(SPI_GETWORKAREA,0,@ARect,0);

}

Initialization
  Ez_Preferences := TEzPreferences.Create;
  Ez_Symbols := TEzSymbols.Create;
  Ez_VectorFonts := TEzVectorFonts.Create;
  Ez_LineTypes := TEzSymbols.Create;
  Ez_LineTypes.IsLineType := true;
  Ez_Hatches := TEzHatchList.Create;

  SetupCursors;

Finalization
  Ez_Preferences.Free;
  Ez_Symbols.Free;
  Ez_VectorFonts.Free;
  Ez_LineTypes.Free;
  Ez_Hatches.Free;

  DisposeCursors;

End.