Форум: "Прочее";
Текущий архив: 2006.12.10;
Скачать: [xml.tar.bz2];
ВнизПомогите создать функцию, умеющая красиво сокращать текст Найти похожие ветки
← →
DelphiLexx © (2006-11-21 11:02) [0]Помогите создать функцию, которая умела бы хорошо сокращать передаваемую фразу, если она превыщает 20 символов, например:
Полное название: МАРГАНЕЦ ДОБАВКА ПРЕМИКСОВ
Сокращенное название: МАРГАНЕЦ ДОБ ПРМ
← →
Сергей М. © (2006-11-21 11:17) [1]Красота - понятие растяжимое.
Мне вот кажется, что красивей ДОБАВКА = ДБВ, да и ДБК тоже симпатюшно...
ПРиводи свой критерий "красивости", а уж за помощью, думаю, дело не встанет)
← →
ЮЮ © (2006-11-21 11:26) [2]Не возр со. б об-ны этой ф-ей
Не удается до 20-ти сократить? :) А проблема откуда? Своих проблем не хватает?
← →
Elen © (2006-11-21 12:02) [3]
> DelphiLexx
А что за проблема сокращай до второй согласной после гласной
← →
DelphiLexx © (2006-11-21 12:26) [4]
> А что за проблема сокращай до второй согласной после гласной
Идея хорошая. С кодом не мог бы помочь.
← →
clickmaker © (2006-11-21 12:33) [5]а лучше убирай вообще все гласные. Если потом согласных останется, больше трех, убирай несогласных )
← →
Плохиш © (2006-11-21 12:33) [6]
> Идея хорошая. С кодом не мог бы помочь.
Так бы сразу и говорил "Код давай", а то начал юлить "Помогите создать функцию".
← →
Горгер © (2006-11-21 13:01) [7]unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Memo1: TMemo;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
function StrTok(var arg:string):string;
begin
result:=Copy(arg,1,Pos(" ",arg)-1);
delete(arg,1,Pos(" ",arg));
end;
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var s,ss:string;
i,j,k:byte;
sglcount:byte;
begin
for i:=0 to Memo1.Lines.Count-1 do begin
s:=Memo1.Lines.Strings[i]+" ";
While Length(s)>0 do begin
sglcount:=0;
ss:=StrTok(s);
ss:=copy(ss,1,4);
for j:=1 to Length(ss)-1 do begin
if Pos(ss[j],"ауоАУО")>0 then inc(sglcount);
end; {FOR J...}
if sglcount=0 then begin
for k:=1 to length(ss) do begin
if k>1 then if Pos(ss[k],"ЕИЫЮЭ")>0 then delete(ss,k,1);end; end;
ss:=copy(ss,1,3);
ShowMessage(ss);
end
end;
end;
end.
← →
Elen © (2006-11-21 13:21) [8]
> Идея хорошая. С кодом не мог бы помочь
за НЕ МОГvar e,s:string;w,r,n,i:integer;
begin
s:="Марганец новый вкусный";e:="";
i:=1;
while i<length(s) do begin
if (i=1)or(s[i]=" ") then n:=0;
while (s[i]<>" ")and(n<2) do begin
if (pos(AnsiLowerCase(s[i]),"уеаоыюия")>0) then inc(n);
e:=e+s[i]; inc(i);
end;
inc(i); e:=e+" ";
end;
caption:=e;
← →
RWolf © (2006-11-21 13:26) [9]не стал бы доверять создание сокращений машине...
← →
clickmaker © (2006-11-21 13:28) [10]
> [9] RWolf © (21.11.06 13:26)
Да. Лучше Маше. Секретарше )
← →
RWolf © (2006-11-21 13:37) [11]
> [10]
Маша, по крайней мере, явные ляпы заменит...
← →
DelphiLexx © (2006-11-21 13:59) [12]
> ss:=StrTok(s);
Что это за функция
← →
Elen © (2006-11-21 14:03) [13]
> Что это за функция
в [7] все написано сразу после implementation
← →
МихаилМ (2006-11-21 16:50) [14]DelphiLexx - халявчег :)
← →
vasIzmax © (2006-11-21 18:23) [15]
> Горгер © (21.11.06 13:01)
Дополнение к библиотеке кодов. Мож и когда пригодится :))). Мож открыть по аналогии с сотовыми телефонами сайтик "Скачай бесплатно код". :)))
← →
TUser © (2006-11-21 18:34) [16]> Сергей М. © (21.11.06 11:17) [1]
Разве всегда проблема может быть четко сформулирована? Могу привести примеры совершенно реальных проблем, где это не так.
← →
TUser © (2006-11-21 18:35) [17]... решаемых програмно, забыл добавить.
← →
DelphiLexx © (2006-11-22 09:28) [18]
> DelphiLexx - халявчег :)
function StrShorten(const Value: String): String;
var
S: TStringList;
I: Integer;
a: string;
function FoundEngLetter(Text: string): boolean;
var
i: integer;
begin
{если в слове есть английская буква, то предполагется, что это формула}
for i:=0 to Length(Text) do
begin
Result := false;
if Pos(AnsiLowerCase(Text[i]), "qwertyuioplkjhgfdsazxcvbnm") <> 0 then
begin
Result := true;
break;
end;
end;
end;
begin
Result := "";
S := TStringList.Create;
try
S.DelimitedText := Value;
for I := 0 to S.Count - 1 do
if (Length(S[I]) > 3) and (not FoundEngLetter(S[i])) then
begin
Result := Result + Copy(S[I], 1, Length(S[I]) div 2);
a := copy(Result, Length(Result), 1);
if Pos(AnsiLowerCase(a), "уеаоыюия) <> 0 then
Delete(Result, Length(Result), 1);
Result := Result + ". ";
end
else
Result := Result + S[I] + " ";
finally
S.Free;
end;
end;
← →
Горгер © (2006-11-22 18:18) [19]function StrTok(var arg:string):string;
begin
result:=Copy(arg,1,Pos(" ",arg)-1);
delete(arg,1,Pos(" ",arg));
end;
← →
Горгер © (2006-11-22 18:21) [20]function StrTok(var arg:string):string; возвращает из строки подстроку начиная с первого символа до пробела, после чего удаляет из исходного аргумента эту подстроку. Таким образом можно выделить из текста все слова последовательно одно за другим ( поскольку аргумент передается по ссылке).
← →
kaif © (2006-11-23 00:16) [21]copy(s, 20) + " ТЫРЫ - ПЫРЫ..."
← →
Oreolek © (2006-11-23 03:25) [22]Удаляешь в слове гласные оставляешь 3 первых буквы.
СОздаешь словарь сокращений.
Продаешь программу,чтобы вернуть деньги на потраченное пиво
Борешься с крекерами
Знакомишься с крекерами
Жружишь с крекерами
Нанимаешь крекеров,чтобы они тебе сделалаи зашиту на пррограмму и снова ее продаешь
Крекеры тебя предают и туту же выставляют крек
Ругаешься с крекерами и их выгоняешь
Продаешь программу
а дальше вы знаете...
← →
Ппп (2006-11-23 07:23) [23]Oreolek © (23.11.06 03:25) [22]
Вин2к?
← →
Elen © (2006-11-23 08:18) [24]
> Жружишь с крекерами
Э-э-э может Жужжиш? или лучше Гудиш?
Страницы: 1 вся ветка
Форум: "Прочее";
Текущий архив: 2006.12.10;
Скачать: [xml.tar.bz2];
Память: 0.5 MB
Время: 0.042 c