Сайт заготовки для Дельфи&Pascal

Удалить из нее все слова, начинающиеся с буквы «а».

NetSoftWare — Tue, 29 May 2012 04:17:20 GMT


Дана строка символов до точки. Удалить из нее все слова, начинающиеся с буквы «а».




uses crt;
var s,sub:string;
 i,n:integer;
 a:array[1..100] of string;
 ch:char;
begin
clrscr;
writeln('Input str');
readln(s);
i:=0;n:=0;
repeat
inc(i);
if (s[i]=' ')and(s[i+1]<>' ') then begin
 inc(n);
 a[n]:=sub;
 sub:='';
 end
else if (s[i]<>' ')and(s[i]<>'.') then sub:=sub+s[i];
until i=length(s);
if sub<>'' then begin
inc(n);
a[n]:=sub;
end;
writeln;
writeln('Input char');
readln(ch);
for i:=1 to n do
 if a[i][1]<>ch then write(a[i],' ');
end.


автор KaLLIaK 
http://programmersforum.ru/member.php?u=208004
с сайта 
http://programmersforum.ru/showthread.php?t=202877

Как сложить конверт для CD/DVD диска из бумаги.

NetSoftWare — Sun, 27 May 2012 04:33:01 GMT

Мне часто присылают удивительные картинки из раздела удивительные факты.
Как упаковать CD в лист A4. Просто и изящно.

Программа для перевода числа в строку (сумма прописью)

NetSoftWare — Fri, 18 May 2012 18:25:06 GMT

http://netsoftware.ucoz.ru/57_perevod_summy_v_stroku.zip

Статья про программу на Delphi для перевода суммы в строку имела некоторый успех на сайте решил выложить пример подобной программы.

1. При запуске программа передает содержимое буфера обмена в компонент для ввода чисел.
2. Происходит преобразование числа в сумму прописью
3. Выдает результат в буфер обмена
4. по нажатию Esc программа закрывается

вариант настройки через среду Windows shell

1. скачиваете программу (вместе с исходный текстом на Delphi)
http://netsoftware.ucoz.ru/57_perevod_summy_v_stroku.zip

2. Создаем ярлык на рабочем столе для быстрого доступа к функциям программы

3. в свойствах ярлыка выставляем быстрый запуск

Исходник программы
http://netsoftware.ucoz.ru/publ/summa_propisju_dlja_fastreport_4_0_paskal_versija/1-1-0-5

Как определить время простоя компьютера и убрать заставку

NetSoftWare — Fri, 18 May 2012 05:38:49 GMT

Нужна программа, которая через определенное время (например каждые 5 секунд, но чтобы можно самому казать временной период) смещает курсор мыши в случайном направлении на случайное количество пикселов, но не более например пяти (с возможностью указания этого числа). простенькая форма с двумя эдитами: в первом указываем интервал, во втором максимальное число пикселов, на которое может сместиться курсор.

Чтобы вывести время простоя компьютера нужно написать следующую функцию:

function CheckIddleTime: DWord;
var
   LastInput: TLastInputInfo;
begin
   LastInput.cbSize := SizeOf(TLastInputInfo);
   GetLastInputInfo(LastInput);
   Result := GetTickCount - LastInput.dwTime;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
Label1.Caption:= 'Время простоя: ' + vartostr(CheckIddleTime/1000)+' секунд(ы)';
end;

далее напишем программу по просьбе shadowgm

изменим процедуру следующим образом

procedure TForm1.Timer1Timer(Sender: TObject);
var dx,dy:integer;
    OldX,OldY:integer;
    lpPoint: TPoint;
begin
Label1.Caption:= 'Âðåìÿ ïðîñòîÿ: ' + vartostr(Round(CheckIddleTime/1000))+' ñåêóíä(û)';
if first then
form1.CoolTrayIcon1.HideMainForm;
first:=false;
if (Round(CheckIddleTime/1000))>Strtoint(edit1.text) then begin
GetCursorPos(lpPoint);
dx:= random(11) - 5;
dy:= random(11) - 5;
SetCursorPos(OldX + dx, OldY+dy);
OldX := OldX + dx;
OldY := OldY + dy;
sleep(100);
SetCursorPos(lpPoint.X, lpPoint.Y);
end;
end;

для сохранения параметров программы напишем не большую обработку

procedure TForm1.FormCreate(Sender: TObject);
var F:textfile;
    s:string;
begin
if fileage('set.ini')>0 then begin
    AssignFile(f,'set.ini');
    reset(f);
    readln(f,s);
    form1.Edit1.Text:=s;
    closefile(F);
end;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var f:textfile;
begin
rewrite(f,'set.ini');
writeln(f,edit1.text);
closefile(F);
end;
пример программы можно скачать /55_vremja_prostoja_kompjutera.rar

cooltray на основании
http://www.delphiexpert.ru/view_download.php?id=30

время простоя компьютера - на основании
http://www.delphicomponent.ru/257-delphi-kak-vyvesti-vremya-prostoya-kompyutera.html

успехов!

Из данного предложения вычеркнуть слова, содержащие заданную букву.

NetSoftWare — Thu, 17 May 2012 09:30:33 GMT

программа на Паскале (pascal)

Из данного предложения вычеркнуть слова, содержащие заданную букву.

uses crt;
const
   SymbolWord :set of char = ['A'..'Z','a'..'z','0'..'9','а'..'я','А'..'Я','-'];

   Function GetTextFromUslovie(s:string;Charvalue:Char):string;
   var x:integer;
       s2:string;
       L:integer;
       start:integer;
       chr:boolean;
   begin
     s2:='';
     l:=length(s);
     start:=1; // начала слова
     chr:=true;
     while x        if s[x] in SymbolWord then begin
        if s[x]=Charvalue then chr:=false;
        s2:=s2+s[x];
        end else begin
           if not chr then begin
            delete(s,start,x-start);
            x:=x-start;
           end;
           chr:=true;
           start:=x;
           s2:='';
        end;
     x:=x+1;
     end;
     result:=s;
   end;

begin
    writeln(GetTextFromUslovie('Из данного предложения вычеркнуть слова, содержащие заданную букву.','с'));

end.

Где взять набор утилит для восстановления БД FireBird

NetSoftWare — Thu, 17 May 2012 08:36:10 GMT

где найти файл fbclient.dll
где найти файл fbguard.exe
где найти файл fbrmclib.dll
где найти файл fbsvcmgr.exe
где найти файл fbtracemgr.exe
где найти файл fb_lock_print.exe
где найти файл gbak.exe
где найти файл gdef.exe
где найти файл gfix.exe
где найти файл gpre.exe
где найти файл gsec.exe
где найти файл gsplit.exe
где найти файл gstat.exe
где найти файл ib_util.dll
где найти файл icudt30.dll
где найти файл icuin30.dll
где найти файл icuuc30.dll
где найти файл instclient.exe
где найти файл instreg.exe
где взять файл instsvc.exe
где взять файл isql.exe
где взять файл nbackup.exe
где взять файл qli.exe
Где взять gfix.exe

/Fb_ut.zip

Получить полный текст хранимой процедуры FireBird

NetSoftWare — Thu, 17 May 2012 08:06:56 GMT

Как получить полный текст процедуры из базы данных FireBird

начало этого разговора было положено в конференциях
http://www.sql.ru/forum/actualthread.aspx?tid=901951
отдельное спасибо автору сайта ibase.ru
Источник http://www.ibase.ru/devinfo/sysqry.htm

1. Получение списка полей и их типов по таблицам:

select R.RDB$RELATION_NAME, R.RDB$FIELD_POSITION, R.RDB$FIELD_NAME,
F.RDB$FIELD_LENGTH, F.RDB$FIELD_TYPE, F.RDB$FIELD_SCALE, F.RDB$FIELD_SUB_TYPE
from RDB$FIELDS F, RDB$RELATION_FIELDS R
where F.RDB$FIELD_NAME = R.RDB$FIELD_SOURCE and R.RDB$SYSTEM_FLAG = 0
order by R.RDB$RELATION_NAME, R.RDB$FIELD_POSITION

Если вам не нравится нумерация полей с 0, то можно вместо R.RDB$FIELD_POSITION написать R.RDB$FIELD_POSITION+1. Для получения списка полей конкретной таблицы нужно добавить соответствующее условие к where - and RDB$RELATION_NAME = 'MYTABLE'.

Функция Delphi позволяет получить полный текст процедуры вмести с заголовком входных и выходных параметров.

ParamSm:TIBQuery; // ссылка на объект SQL
FunctionName:string // имя процедуры

Function GetAllBodyFromProcedure(ParamSm:TIBQuery;FunctionName:string):string;

Function GetSQLFromMod(Nametext:string):string;
begin
Result:='select pr.rdb$procedure_name,'+#13+#10+
'pr.rdb$procedure_source,'+#13+#10+
'pp.rdb$parameter_name,'+#13+#10+
'pp.rdb$parameter_type,'+#13+#10+
'fs.rdb$field_name,'+#13+#10+
'fs.rdb$field_type,'+#13+#10+
'fs.rdb$field_length,'+#13+#10+
'fs.rdb$field_scale,'+#13+#10+
'fs.rdb$field_sub_type,'+#13+#10+
'fs.rdb$segment_length,'+#13+#10+
'fs.rdb$dimensions,'+#13+#10+
'cr.rdb$character_set_name,'+#13+#10+
'co.rdb$collation_name,'+#13+#10+
'pp.rdb$parameter_number,'+#13+#10+
'fs.rdb$character_length,'+#13+#10+
'pp.rdb$description,'+#13+#10+
'pr.rdb$description,'+#13+#10+
'fs.rdb$default_source,'+#13+#10+
'fs.rdb$field_precision,'+#13+#10+
'cast(0 as integer),'+#13+#10+
'pp.rdb$field_source,'+#13+#10+
'fs.rdb$default_source,'+#13+#10+
'cast(0 as integer),'+#13+#10+
'cast(null as varchar(64)),'+#13+#10+
'cast(null as varchar(64)),'+#13+#10+
'cast(null as varchar(64)),'+#13+#10+
'cr.rdb$default_collate_name'+#13+#10+
''+#13+#10+
'from rdb$procedures pr'+#13+#10+
'left join rdb$procedure_parameters pp on pp.rdb$procedure_name = pr.rdb$procedure_name'+#13+#10+
'left join rdb$fields fs on fs.rdb$field_name = pp.rdb$field_source'+#13+#10+
'left join rdb$character_sets cr on fs.rdb$character_set_id = cr.rdb$character_set_id'+#13+#10+
'left join rdb$collations co on ((fs.rdb$collation_id = co.rdb$collation_id) and'+#13+#10+
'(fs.rdb$character_set_id = co.rdb$character_set_id))'+#13+#10+
'where pr.rdb$procedure_name = '+#39+Nametext+#39+''+#13+#10+
'order by pp.rdb$parameter_type, pp.rdb$parameter_number';
end;
Function DeeleteProbel(s:string):string;
var l,x:integer;
s2:string;
begin
l:=length(s);
s2:='';
for X:=1 to l do begin
   if s[x]=' ' then else   s2:=s2+s[x];
end;
result:=s2;
end;
Function GetTypeFromFieBird(fullname:string;DataType,Precision,Scale,Length_m,SubType:integer):string;

var i:integer;
    s:string;
begin
      s:='    '+DeeleteProbel(fullname)+' ';
      case DataType of
        7 : begin
               if Precision = 0 then
                 s:=s+'SMALLINT'
               else
                 s:=s+'NUMERIC('+IntToStr(Precision)+','+IntToStr(-Scale)+')';
             end;
        8 : begin
               if Precision = 0 then
                 s:=s+'INTEGER'
               else
                 s:=s+'NUMERIC('+IntToStr(Precision)+','+IntToStr(-Scale)+')';
             end;

        9 : s:=s+'TIMESTAMP';
        10 : s:=s+'FLOAT';
        12 : s:=s+'DATE';
        13 : s:=s+'TIME';
        14 : s:=s+'CHAR('+IntToStr(Length_m)+')';
        16 : begin
               if Precision = 0 then
                 s:=s+'BIGINT'
               else
                 s:=s+'NUMERIC('+IntToStr(Precision)+','+IntToStr(-Scale)+')';
             end;
        17 : s:=s+'BOOLEAN';
        27 : begin
               if Scale = 0 then
                 s:=s+'DOUBLE PRECISION'
               else
                 s:=s+'NUMERIC(15,'+IntToStr(-Scale)+')';
             end;
        35 : s:=s+'TIMESTAMP';
        37 : s:=s+'VARCHAR('+IntToStr(Length_m)+')';
        45, 261 : s:=s+'BLOB SUBTYPE '+IntToStr(SubType);
    end;
    result:=s;
    end;

Function GetAllParam(s:string):string;
var fullname:string;
    DataType,Precision,Scale,Length_m,SubType:integer;
    s2:string;
    first:boolean;
    inputParam:boolean;
    firstInputparam:boolean;
begin
   s2:='';
   ParamSm.SQL.Text:=GetSQLFromMod(s);
   ParamSm.Open;
   first:=true;
   inputParam:=false;
   firstInputparam:=true;

   repeat
    fullname:='    '+ParamSm.Fieldbyname('rdb$parameter_name').AsString;
    DataType:=ParamSm.Fieldbyname('rdb$field_type').AsInteger;

    if ParamSm.Fieldbyname('rdb$parameter_type').AsInteger=0 then begin inputParam:=true;
    if firstInputparam then s2:=s2+' ('+#13+#10;
    firstInputparam:=false;
    end;

    if ParamSm.Fieldbyname('rdb$parameter_type').AsInteger=1 then begin if first then begin
    s2:=copy(s2,1,length(s2)-3);
    if inputParam then s2:=s2+')';
    s2:=s2+' '+#13+#10+'returns ('+#13+#10;
    end;
    first:=false;
    end;

    Precision:=ParamSm.Fieldbyname('rdb$field_precision').AsInteger;
    Scale:=ParamSm.Fieldbyname('rdb$field_scale').AsInteger;
    Length_m:=ParamSm.Fieldbyname('rdb$field_length').AsInteger;
    SubType:=ParamSm.Fieldbyname('rdb$field_sub_type').AsInteger;
     ParamSm.next;
     s2:=s2+GetTypeFromFieBird(fullname,DataType,Precision,Scale,Length_m,SubType)+','+#13+#10;
   until   ParamSm.eof;
   if not first then begin
   s2:=copy(s2,1,length(s2)-3);
   s2:=s2+')'+#13+#10;
   end else begin
   s2:=copy(s2,1,length(s2)-3);
   s2:=s2+')'+#13+#10;
   end;
   s2:=s2+'as'+#13+#10;

   result:=s2;

end;
Function GetCaption(sname:string;title:string='create procedure'):string;
begin
result := title+' '+DeeleteProbel(sname);
end;
Function GetAllProcedure(sname:string):string;
var s2:string;
    Text:string;
begin
s2:=GetCaption(sname);
s2:=s2+GetAllParam(sname);
ParamSm.SQL.Text:='SELECT * FROM RDB$PROCEDURES WHERE RDB$PROCEDURE_NAME ="'+sname+'"';
ParamSm.open;
Text:=ParamSm.FieldByName('RDB$PROCEDURE_SOURCE').AsString;
result:=s2+text;
end;

begin
result:=GetAllProcedure(Functionname);
end;

Как перевести число в тип строка в Pascal или IntToStr(I : Longint)

NetSoftWare — Mon, 14 May 2012 08:02:22 GMT


{Str.PAS}
 
{ Пример программы для процедуры Str }
 
Function IntToStr(I : Longint) : String;
{ Преобразовывает значение типа Integer в строку }
Var S : String [11];
Begin
 Str(I, S);
 IntToStr:=S;
End;
 
Begin
 WriteLn(IntToStr(-5322)); { '-5332' }
End.

Пример создания объектов типа TCombobox в режиме работы программы

NetSoftWare — Sun, 17 Jul 2011 05:31:06 GMT

пример создания объектов типа TCombobox в режиме работы программы

var a2:array of Tcombobox; { объявляем массив неограниченного числа элементов а2 типа Tcombobox;
}
    X:integer;
begin
// на форме уже есть один combobox1
// может быть с текстом
{
combobox1.AddItem('123',NIL);
combobox1.AddItem('888',NIL);
}

SetlengtH(a2,10); // задаем размер массива из 10 элементов

for x:=0 to 9 do begin
    a2[x]:=Tcombobox.Create(form1); { выполняем создание массива . задаем родительский элемент }

    a2[x].parent:=form1; { где создаем объект. можно поставить Panel1 или другой компонент }
    a2[x].left:=50;
    a2[x].top:=25*x;
    a2[x].Items.Text:=form1.ComboBox1.Items.Text; // список элементов
    a2[x].text:=inttostR(X); // текущий текст
end;

end;