Форум: "Основная";
Текущий архив: 2003.09.08;
Скачать: [xml.tar.bz2];

Вниз

мастера, помогите, 2 часа бъюсь над проблемой, есть строка   Найти похожие ветки 

← →
Layner   (2003-08-25 11:38) [0]

"Один;Два;Три;Четыре;Пять;Шесть;". Каждое слово отделяет точка с запятой. Нужно получить слово, по порядковому номеру, т.е. сделать ф-ю, где входной парамер цифра, а возврашает ф-я слово из этой строки. Т.е. например get_slovo_func(5) возвратит слово "Пять" , get_slovo_func(3) возвратит слово "Три" и т.п.

Я сделал ф-ю возвращающая кол-во слов,


function TForm1.get_num_bd(Stroka: string): Integer;
var
i:integer;
begin
Result:=0;
for i:=0 to Length(Stroka) do
if Copy(Stroka,i,1)=";" then
Result:=Result+1;
end;


---

← →
Layner   (2003-08-25 11:40) [1]

А по порядковому номеру не могу... Помогите разобраться, работаю только с ф-ми Pos, Copy, Delete

---

← →
Palladin   (2003-08-25 11:42) [2]

1
result:=0;
while pos(";",Stroka)<>0 do
begin
result:=result+1;
stroka:=copy(stroka,pos(";",stroka)+1,length(stroka);
end;

2
result:=0;
for i:=1 to length(stroka) if stroka[i]=";" then result:=result+1;

---

← →
MBo   (2003-08-25 11:42) [3]

TStringList.DelimitedText

---

← →
Palladin   (2003-08-25 11:43) [4]

найди по одной ошибке в каждом куске :)

---

← →
snake1977   (2003-08-25 11:45) [5]

n-номер лексемы
s-строка исходник
l-разделитель лексем в твоем случае ";"
Function GetLex(n:Integer; s:String; l:String):String;
Var i:Integer;
lx,st:String;
Begin
If S<>"" Then
Begin
lx:="";
i:=1;
st:=s;
Delete(st,Length(l)+1,Length(st)-Length(l));
While (st<>l) and (s<>"") do
Begin
lx:=lx+s[1];
Inc(i);
Delete(s,1,1);
st:=s;
Delete(st,Length(l)+1,Length(st)-Length(l));
End;
Delete(s,1,Length(l));
If n>1 Then lx:=GetLex(n-1,s,l);
End
Else
lx:="";
GetLex:=lx;
End;

---

← →
Polevi   (2003-08-25 11:51) [6]

Function GetLex(n:Integer; s:String; l:String):String;
var
sl:TStringList;
begin
sl:=TStringList.Create;
try
sl.Text:=StringReplace(s,l,#13#10,[rfReplaceAll]);
Result:=sl[n];
finally
sl.Free;
end;
end;

---

← →
Layner   (2003-08-25 11:51) [7]

Спасибо! Уже пробую 2 способами, Palladin и snake1977.

---

← →
Layner   (2003-08-25 11:58) [8]

Polevi © (25.08.03 11:51)
Самый компактный код, его и использую!! Большущее спасибо, как и всем откликнувшимся!!!!!!!!!!!

---

← →
Palladin   (2003-08-25 12:00) [9]

а я то думал ты со строками учишься работать...

Function GetLex(n:Integer; s:String; l:String):String;
begin
with TStringList.Create do
try
Text:=StringReplace(s,l,#13#10,[rfReplaceAll]);
Result:=Items[n];
finally
Free;
end;
end;

---

← →
Мастаки (хором)   (2003-08-25 12:06) [10]

>>Layner (25.08.03 11:51) [7]
попробуй способом MBo © (25.08.03 11:42) [3] :-)
Зачем городить огород - все давно реализовано :-)

---

← →
Palladin   (2003-08-25 12:07) [11]

если разделитель один то конечно MBo, если разделителем строка, то звиняйте...

---

← →
Андрей Сенченко   (2003-08-25 13:00) [12]

Palladin © (25.08.03 12:07) [11]

Если неправильно указать разделитель, то и ваш с Polevi вариант не прокатит.
GetLex(2,"w1,w2,w3,w4,w5",";")
Вышибет по "List Index Out of bounds"

Под каждый конкретный случай нужно подбирать подходящее решение.

---

← →
Palladin   (2003-08-25 13:05) [13]

> Андрей Сенченко © (25.08.03 13:00) [12]

И правильно вышибет! Для этого и существует try except

---

← →
George Karkuzashvili   (2003-08-25 13:55) [14]

Смею предложить компонент из моей библиотеки:

В ствойство Text - Исходный текст
В свойство Delimiter - Разделитель
в Свойство Part - Номер

Функция Activate - Сделает все что надо

То что надо достаем из свойства Substring

Успеха!

unit TextFunctions;

interface

uses
SysUtils, Classes;

type
TPatternMode = (qspmPatternCount,qspmPatternSubstitute);

TPatternCount = class(TComponent)
private
FText: TStrings;
FSearchString: String;
FReplaceString: String;
FCount: Integer;
FStringIndex : Integer;
FActiveMode : TPatternMode;
procedure SetSearchString(const Value: String);
procedure SetText(const Value: TStrings);
procedure SetStringIndex(const Value: Integer);
procedure SetActiveMode(const Value: TPatternMode);
procedure SetReplaceString(const Value: String);
{ Private declarations }
protected
{ Protected declarations }
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Count: Integer read FCount;
procedure Activate;
{ Public declarations }
published
property ActiveMode : TPatternMode read FActiveMode write SetActiveMode default qspmPatternCount;
property Text: TStrings read FText write SetText;
property SearchString: String read FSearchString write SetSearchString;
property ReplaceString: String read FReplaceString write SetReplaceString;
property StringIndex: Integer read FStringIndex write SetStringIndex default -1;
{ Published declarations }
end;

TPartitionString = class(TComponent)
private
FDelimiter: String;
FText: String;
FPart: Integer;
FSubstring: String;
procedure SetDelimiter(const Value: String);
procedure SetPart(const Value: Integer);
procedure SetText(const Value: String);
protected
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Substring: String read FSubstring;
procedure Activate;
published
property Delimiter: String read FDelimiter write SetDelimiter;
property Text: String read FText write SetText;
property Part: Integer read FPart write SetPart;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents("QSL Text Functions", [TPatternCount,TPartitionString]);
end;

{ TPatternCount }

procedure TPatternCount.Activate;
var s : TStrings;
i,ii : Integer;
a : String;
begin
a := "";
s := TStringList.Create;
s.Assign(FText);
FCount := 0;
if FText.Count = 0 then
Exit
else
begin
if FSearchString = "" then
begin
FCount := -1;
Exit;
end else
begin
for i := 0 to FText.Count - 1 do
begin
if FStringIndex = -1 then ii := i else ii := FStringIndex;
if ii = i then
while Pos(FSearchString,s[i]) > 0 do
begin
Inc(FCount);
a := s[i];
if FActiveMode = qspmPatternCount then
delete(a,1, Pos(FSearchString,a) + Length(FSearchString) - 1);
if FActiveMode = qspmPatternSubstitute then
begin
a := StringReplace(a,FSearchString,FReplaceString,[rfReplaceAll]);
If a <> FText.Strings[i] then FText.Strings[i] := a;
end;
s[i] := a;
end;
end;
end;
end;
s.Clear;
end;

constructor TPatternCount.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FText := TStringList.Create;
FStringIndex := -1;
FActiveMode := qspmPatternCount;
end;

destructor TPatternCount.Destroy;
begin
FText.Free;
inherited Destroy;
end;

procedure TPatternCount.SetActiveMode(const Value: TPatternMode);
begin
if FActiveMode <> Value then
FActiveMode := Value;
end;

procedure TPatternCount.SetReplaceString(const Value: String);
begin
FReplaceString := Value;
end;

procedure TPatternCount.SetSearchString(const Value: String);
begin
if FSearchString <> Value then
FSearchString := Value;
end;

procedure TPatternCount.SetStringIndex(const Value: Integer);
begin
if FStringIndex <> Value then
FStringIndex := Value;
end;

procedure TPatternCount.SetText(const Value: TStrings);
begin
FText.Assign(Value);
end;

{ TPartitionString }

procedure TPartitionString.Activate;
var i : Integer;
s : String;
begin
FSubstring := "";
s := FText;
for i := 1 to FPart - 1 do
begin
delete(s,1, Pos(FDelimiter,s) + Length(FDelimiter) - 1);
end;
if Pos(FDelimiter,s) = 0 then
FSubstring := s
else
FSubstring := Copy(s,1,Pos(FDelimiter,s) - 1);
end;

constructor TPartitionString.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FDelimiter := ";";
end;

destructor TPartitionString.Destroy;
begin

inherited Destroy;
end;

procedure TPartitionString.SetDelimiter(const Value: String);
begin
if FDelimiter <> Value then
FDelimiter := Value;
end;

procedure TPartitionString.SetPart(const Value: Integer);
begin
if Value < 1 then FPart := 1 else
FPart := Value;
end;

procedure TPartitionString.SetText(const Value: String);
begin
if FText <> Value then
FText := Value;
end;

end.


---

← →
George Karkuzashvili   (2003-08-25 14:00) [15]

Извиняюсь, забыл указать нужный компонент - TPartitionString

С уважением,

Георгий

---

← →
kull   (2003-08-25 15:25) [16]

MBo - рулез форева.
А то километры кода расписали уже...

---

Страницы: 1 вся ветка

Форум: "Основная";
Текущий архив: 2003.09.08;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.49 MB
Время: 0.007 c