pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

systools: Add unit stText and corresponding example project (examples/text)

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6150 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2018-01-28 21:46:36 +00:00
parent 606cac7767
commit ac0360cf8c
7 changed files with 672 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

85
components/systools/examples/text/EXTEXT.lpi Normal file
View File

@@ -0,0 +1,85 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<General>
<Flags>
<UseDefaultCompilerOptions Value="True"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="EXTEXT"/>
<Scaled Value="True"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<XPManifest>
<DpiAware Value="True"/>
</XPManifest>
<Icon Value="0"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<FormatVersion Value="2"/>
<Modes Count="0"/>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="laz_systools"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="EXTEXT.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="Extext"/>
</Unit0>
<Unit1>
<Filename Value="ExTextU.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="STDlg"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="EXTEXT"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

42
components/systools/examples/text/EXTEXT.lpr Normal file
View File

@@ -0,0 +1,42 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
program Extext;
uses
Forms, Interfaces, LclVersion,
ExTextU in 'ExTextU.pas' {STDlg};
{$R *.res}
begin
Application.Scaled := True;
{$IF lcl_fullversion >= 1080000}
Application.Scaled := True;
{$ENDIF}
Application.Initialize;
Application.CreateForm(TSTDlg, STDlg);
Application.Run;
end.

127
components/systools/examples/text/ExTextU.lfm Normal file
View File

@@ -0,0 +1,127 @@
object STDlg: TSTDlg
Left = 254
Height = 274
Top = 164
Width = 428
ActiveControl = LoadBtn
Caption = 'StText Example'
ClientHeight = 274
ClientWidth = 428
Color = clBtnFace
Font.Color = clBlack
OnClose = FormClose
OnCreate = FormCreate
LCLVersion = '1.9.0.0'
object Label1: TLabel
Left = 6
Height = 15
Top = 16
Width = 32
Caption = 'Name'
ParentColor = False
end
object Label2: TLabel
Left = 208
Height = 15
Top = 16
Width = 23
Caption = 'Size:'
ParentColor = False
end
object Label3: TLabel
Left = 320
Height = 15
Top = 16
Width = 44
Caption = 'Cur. Pos'
ParentColor = False
end
object Memo1: TMemo
Left = 90
Height = 217
Top = 48
Width = 329
HideSelection = False
OnKeyUp = Memo1KeyUp
OnMouseUp = Memo1MouseUp
ReadOnly = True
ScrollBars = ssVertical
TabOrder = 8
TabStop = False
end
object LoadBtn: TButton
Left = 8
Height = 33
Top = 48
Width = 75
Caption = 'Load'
Default = True
OnClick = LoadBtnClick
TabOrder = 0
end
object SeekBtn: TButton
Left = 8
Height = 33
Top = 170
Width = 75
Caption = 'Seek'
OnClick = SeekBtnClick
TabOrder = 3
end
object FlushBtn: TButton
Left = 8
Height = 33
Top = 232
Width = 75
Caption = 'Flush'
OnClick = FlushBtnClick
TabOrder = 4
end
object Edit1: TEdit
Left = 40
Height = 23
Top = 12
Width = 159
ReadOnly = True
TabOrder = 5
end
object Edit2: TEdit
Left = 236
Height = 23
Top = 12
Width = 53
ReadOnly = True
TabOrder = 6
end
object Edit3: TEdit
Left = 366
Height = 23
Top = 12
Width = 53
ReadOnly = True
TabOrder = 7
end
object Edit4: TEdit
Left = 14
Height = 23
Top = 136
Width = 65
TabOrder = 2
end
object CloseFBtn: TButton
Left = 8
Height = 33
Top = 90
Width = 75
Caption = 'Close File'
OnClick = CloseFBtnClick
TabOrder = 1
end
object OD1: TOpenDialog
DefaultExt = '.TXT'
Filter = '*.txt (Text files)|*.txt|*.* (All files)|*.*'
Options = [ofOverwritePrompt]
left = 152
top = 86
end
end

230
components/systools/examples/text/ExTextU.pas Normal file
View File

@@ -0,0 +1,230 @@
(* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is TurboPower SysTools
*
* The Initial Developer of the Original Code is
* TurboPower Software
*
* Portions created by the Initial Developer are Copyright (C) 1996-2002
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* ***** END LICENSE BLOCK ***** *)
unit ExTextU;
{$IFDEF FPC}
{$mode DELPHI}
{$ENDIF}
interface
uses
{$IFNDEF FPC}
Windows, Messages,
{$ENDIF}
SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type
TSTDlg = class(TForm)
Memo1: TMemo;
OD1: TOpenDialog;
LoadBtn: TButton;
SeekBtn: TButton;
FlushBtn: TButton;
Label1: TLabel;
Edit1: TEdit;
Label2: TLabel;
Edit2: TEdit;
Label3: TLabel;
Edit3: TEdit;
Edit4: TEdit;
CloseFBtn: TButton;
procedure LoadBtnClick(Sender: TObject);
procedure SeekBtnClick(Sender: TObject);
procedure Memo1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure Memo1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FlushBtnClick(Sender: TObject);
procedure CloseFBtnClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
procedure UpdatePos;
procedure UpdateButtons(FOK : Boolean);
end;
var
STDlg: TSTDlg;
implementation
{$R *.lfm}
uses
StConst,
StBase,
StText;
var
F : TextFile;
AFO : Boolean;
procedure TSTDlg.UpdateButtons(FOK : Boolean);
begin
CloseFBtn.Enabled := FOK;
SeekBtn.Enabled := FOK;
FlushBtn.Enabled := FOK;
end;
procedure TSTDlg.FormCreate(Sender: TObject);
begin
UpdateButtons(False);
AFO := False;
end;
procedure TSTDlg.LoadBtnClick(Sender: TObject);
var
S : string;
// hC : HCursor;
begin
if (OD1.Execute) then
begin
if (AFO) then
CloseFile(F);
AFO := False;
AssignFile(F, OD1.FileName);
Reset(F);
Memo1.Enabled := True;
Memo1.Lines.BeginUpdate;
Screen.Cursor := crHourglass;
try
// Memo1.Perform(WM_SETREDRAW,0,0);
// hC := SetCursor(LoadCursor(0,IDC_WAIT));
while NOT EOF(F) do
begin
Readln(F,S);
Memo1.Lines.Add(S);
end;
finally
Screen.Cursor := crDefault;
Memo1.Lines.EndUpdate;
end;
// Memo1.Perform(WM_SETREDRAW,1,0);
// Memo1.Update;
Memo1.SelStart := 0;
Memo1.SelLength := 0;
Reset(F);
Edit1.Text := OD1.FileName;
Edit2.Text := IntToStr(TextFileSize(F));
Edit3.Text := IntToStr(TextPos(F));
// SetCursor(hC);
Memo1.SetFocus;
AFO := True;
end;
UpdateButtons(AFO);
end;
procedure TSTDlg.CloseFBtnClick(Sender: TObject);
begin
CloseFile(F);
Memo1.Clear;
AFO := False;
UpdateButtons(False);
end;
procedure TSTDlg.SeekBtnClick(Sender: TObject);
var
NP : LongInt;
begin
NP := StrToInt(Edit4.Text);
Memo1.SetFocus;
if (NP < 0) OR (NP >= TextFileSize(F)) then
begin
ShowMessage('Value out of range');
Exit;
end;
if TextSeek(F,NP) then
begin
NP := TextPos(F);
Memo1.SelStart := NP;
Memo1.SelLength := 0;
Edit3.Text := IntToStr(NP);
end else
begin
ShowMessage('Unable to seek to position');
Memo1.SetFocus;
end;
end;
procedure TSTDlg.Memo1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
UpdatePos;
end;
procedure TSTDlg.Memo1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
UpdatePos;
end;
procedure TSTDlg.UpdatePos;
var
CP : LongInt;
begin
CP := Memo1.SelStart;
if NOT TextSeek(F,CP) then
begin
ShowMessage('Unable to update file pointer');
Exit;
end;
Edit3.Text := IntToStr(TextPos(F));
end;
procedure TSTDlg.FlushBtnClick(Sender: TObject);
begin
if NOT (TextFlush(F)) then
begin
ShowMessage('Unable to flush file');
end;
Memo1.SetFocus;
end;
procedure TSTDlg.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if AFO then CloseFile(F);
end;
end.