Create site free
FAQ по Delphi (3) - Программирование - Компьютеры, телекоммуникации, ПО... - Форум
Регистрация | Вход
 

Страница 3 из 3«123
Форум » Компьютеры, телекоммуникации, ПО... » Программирование » FAQ по Delphi
FAQ по Delphi
Vovich Дата: Четверг, 29.04.2010, 00:16 | Сообщение # 1
Люблю и это здорово!
Группа: Администраторы
ICQ: 380341657
Сообщений: 1010
Статус: Offline














 
Vovich Дата: Четверг, 29.04.2010, 10:05 | Сообщение # 21
Люблю и это здорово!
Группа: Администраторы
ICQ: 380341657
Сообщений: 1010
Статус: Offline


Изменение регистра букв.

В Delphi есть три функции для изменения регистра: upcase, lowercase, uppercase. Но они работают только для латинского алфавита. Чтобы сделать аналогичные функции для русского алфавита я использовал то, что в кодировке Windows-1251 буквы расставлены по алфавиту, как большие, так и маленькие. То есть номер большой буквы связан с номером маленькой константой. И в русском, и в английском алфавитах маленькие буквы находятся за большими с разностью в 32 символа. Здесь реализованы четыре функции: upcase и locase для изменения регистра одного символа, и uppercase и lowercase для изменения регистра строки

Code
function UpCase(ch: char): char;
begin
   if (ch in ['a'..'z', 'а'..'я'])
     then result := chr(ord(ch) - 32)
     else result := ch;
end;

function LoCase(ch: char): char;
begin
   if (ch in ['A'..'Z', 'А'..'Я'])
     then result := chr(ord(ch) + 32)
     else result := ch;
end;

function UpperCase(s: string): string;
var
   i: integer;
begin
   result := s;
   for i := 1 to length(result) do
     if (result[i] in ['a'..'z', 'а'..'я'])
       then result[i] := chr(ord(result[i]) - 32);
end;

function LowerCase(s: string): string;
var
   i: integer;
begin
   result := s;
   for i := 1 to length(result) do
     if (result[i] in ['A'..'Z', 'А'..'Я'])
       then result[i] := chr(ord(result[i]) + 32);
end;

procedure TForm1.Button1Click(Sender: TObject);
const
   s = 'zZцЦ.';
var
   i: integer;
begin
   Form1.Caption := 'DownCase: ';
   for i := 1 to Length(s) do
     Form1.Caption := Form1.Caption + LoCase(s[i]);
   Form1.Caption := Form1.Caption + ' UpCase: ';
   for i := 1 to Length(s) do
     Form1.Caption := Form1.Caption + UpCase(s[i]);
   Form1.Caption := Form1.Caption + ' UpperCase: ' +
     UpperCase(s);
   Form1.Caption := Form1.Caption + ' LowerCase: ' +
     LowerCase(s);
end;


 
Vovich Дата: Четверг, 29.04.2010, 10:08 | Сообщение # 22
Люблю и это здорово!
Группа: Администраторы
ICQ: 380341657
Сообщений: 1010
Статус: Offline


Посчитать строку с формулой

В Delphi нет функции, которая бы позволяла посчитать строку с формулой. Но есть множество способов реализовать это самому. Здесь я привел самый простой из них. Он не очень быстрый, но при нынешних скоростях компьютеров
для многих целей он подойдет. Принцип его заключается в следующем. Сначала строка оптимизируется – выкидываются все пробелы, точки и запятые меняются на установленный разделяющий знак (DecimalSeparator). Все числа и параметры (например, x), содержащиеся в строке "обособляются" символом #. В дальнейшем это позволяет избежать путаницы с экспонентой, минусами и. т. д. Следующий шаг – замена, если нужно, всех параметров на их значения. И, наконец, последний шаг, подсчет получившейся строки. Для этого программа ищет все операции с самым высоким приоритетом (это скобки). Считает их значение, вызывая саму себя (рекурсивная функция),
и заменяет скобки и их содержимое на их значение, обособленное #. Дальше она выполняет то же самое для операции с более низким приоритетом и так до сложения с вычитанием.

Каждый шаг выделен в отдельную процедуру. Это позволяет быстрее считать функцию, если она не меняется, а меняются только значения параметров.

Вот модуль с этими методами.

Code
unit Recognition;

interface

uses
   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Math;

type
   TVar = set of char;

procedure Preparation(var s: String; variables: TVar);
function ChangeVar(s: String; c: char; value: extended): String;
function Recogn(st: String; var Num: extended): boolean;

implementation

procedure Preparation(var s: String; variables: TVar);
const
   operators: set of char = ['+','-','*', '/', '^'];
var
   i: integer;
   figures: set of char;
begin
   figures := ['0','1','2','3','4','5','6','7','8','9', DecimalSeparator] + variables;

// " "
   repeat
     i := pos(' ', s);
     if i <= 0 then break;
     delete(s, i, 1);
   until 1 = 0;

   s := LowerCase(s);

// ".", ","
   if DecimalSeparator = '.' then begin
     i := pos(',', s);
     while i > 0 do begin
       s[i] := '.';
       i := pos(',', s);
     end;
   end else begin
     i := pos('.', s);
     while i > 0 do begin
       s[i] := ',';
       i := pos('.', s);
     end;
   end;

// Pi
   repeat
     i := pos('pi', s);
     if i <= 0 then break;
     delete(s, i, 2);
     insert(FloatToStr(Pi), s, i);
   until 1 = 0;

// ":"
   repeat
     i := pos(':', s);
     if i <= 0 then break;
     s[i] := '/';
   until 1 = 0;

// |...|
   repeat
     i := pos('|', s);
     if i <= 0 then break;
     s[i] := 'a';
     insert('bs(', s, i + 1);
     i := i + 3;
     repeat i := i + 1 until (i > Length(s)) or (s[i] = '|');
     if s[i] = '|' then s[i] := ')';
   until 1 = 0;

// #...#
   i := 1;
   repeat
     if s[i] in figures then begin
       insert('#', s, i);
       i := i + 2;
       while (s[i] in figures) do i := i + 1;
       insert('#', s, i);
       i := i + 1;
     end;
     i := i + 1;
   until i > Length(s);
end;

function ChangeVar(s: String; c: char; value: extended): String;
var
   p: integer;
begin
   result := s;
   repeat
     p := pos(c, result);
     if p <= 0 then break;
     delete(result, p, 1);
     insert(FloatToStr(value), result, p);
   until 1 = 0;
end;

function Recogn(st: String; var Num: extended): boolean;
const
   pogr = 1E-5;
var
   p, p1: integer;
   i, j: integer;
   v1, v2: extended;
   func: (fNone, fSin, fCos, fTg, fCtg, fArcsin, fArccos, fArctg, fArcctg, fAbs, fLn, fLg, fExp);
   Sign: integer;
   s: String;
   s1: String;

   function FindLeftValue(p: integer; var Margin: integer; var Value: extended): boolean;
   var
     i: integer;
   begin
     i := p - 1;
     repeat i := i - 1 until (i <= 0) or (s[i] = '#');
     Margin := i;
     try
       Value := StrToFloat(copy(s, i + 1, p - i - 2));
       result := true;
     except
       result := false
     end;
     delete(s, i, p - i);
   end;

   function FindRightValue(p: integer; var Value: extended): boolean;
   var
     i: integer;
   begin
     i := p + 1;
     repeat i := i + 1 until (i > Length(s)) or (s[i] = '#');
     i := i - 1;
     s1 := copy(s, p + 2, i - p - 1);
     result := TextToFloat(PChar(s1), value, fvExtended);
     delete(s, p + 1, i - p + 1);
   end;

   procedure PutValue(p: integer; NewValue: extended);
   begin
     insert('#' + FloatToStr(v1) + '#', s, p);
   end;

begin
   Result := false;
   s := st;

// ()
   p := pos('(', s);
   while p > 0 do begin
     i := p;
     j := 1;
     repeat
       i := i + 1;
       if s[i] = '(' then j := j + 1;
       if s[i] = ')' then j := j - 1;
     until (i > Length(s)) or (j <= 0);
     if i > Length(s) then s := s + ')';
     if Recogn(copy(s, p + 1, i - p - 1), v1) = false then Exit;
     delete(s, p, i - p + 1);
     PutValue(p, v1);

     p := pos('(', s);
   end;

// sin, cos, tg, ctg, arcsin, arccos, arctg, arcctg, abs, ln, lg, log, exp
   repeat
     func := fNone;
     p1 := pos('sin', s);
     if p1 > 0 then begin
       func := fSin;
       p := p1;
     end;
     p1 := pos('cos', s);
     if p1 > 0 then begin
       func := fCos;
       p := p1;
     end;
     p1 := pos('tg', s);
     if p1 > 0 then begin
       func := fTg;
       p := p1;
     end;
     p1 := pos('ctg', s);
     if p1 > 0 then begin
       func := fCtg;
       p := p1;
     end;
     p1 := pos('arcsin', s);
     if p1 > 0 then begin
       func := fArcsin;
       p := p1;
     end;
     p1 := pos('arccos', s);
     if p1 > 0 then begin
       func := fArccos;
       p := p1;    end;
     p1 := pos('arctg', s);
     if p1 > 0 then begin
       func := fArctg;
       p := p1;
     end;
     p1 := pos('arcctg', s);
     if p1 > 0 then begin
       func := fArcctg;
       p := p1;
     end;
     p1 := pos('abs', s);
     if p1 > 0 then begin
       func := fAbs;
       p := p1;
     end;
     p1 := pos('ln', s);
     if p1 > 0 then begin
       func := fLn;
       p := p1;
     end;
     p1 := pos('lg', s);
     if p1 > 0 then begin
       func := fLg;
       p := p1;
     end;
     p1 := pos('exp', s);
     if p1 > 0 then begin
       func := fExp;
       p := p1;
     end;
     if func = fNone then break;

     case func of
       fSin, fCos, fCtg, fAbs, fExp: i := p + 2;
       fArctg: i := p + 4;
       fArcsin, fArccos, fArcctg: i := p + 5;
       else i := p + 1;
     end;
     if FindRightValue(i, v1) = false then Exit;
     delete(s, p, i - p + 1);
     case func of
       fSin: v1 := sin(v1);
       fCos: v1 := cos(v1);
       fTg: begin
         if abs(cos(v1)) < pogr then Exit;
         v1 := sin(v1) / cos(v1);
       end;
       fCtg: begin
         if abs(sin(v1)) < pogr then Exit;
         v1 := cos(v1) / sin(v1);
       end;
       fArcsin: begin
         if Abs(v1) > 1 then Exit;
         v1 := arcsin(v1);
       end;
       fArccos: begin
         if abs(v1) > 1 then Exit;
         v1 := arccos(v1);
       end;
       fArctg: v1 := arctan(v1);
//      fArcctg: v1 := arcctan(v1);
       fAbs: v1 := abs(v1);
       fLn: begin
         if v1 < pogr then Exit;
         v1 := Ln(v1);
       end;
       fLg: begin
         if v1 < 0 then Exit;
         v1 := Log10(v1);
       end;
       fExp: v1 := exp(v1);
     end;
     PutValue(p, v1);
   until func = fNone;

// power
   p := pos('^', s);
   while p > 0 do begin
     if FindRightValue(p, v2) = false then Exit;
     if FindLeftValue(p, i, v1) = false then Exit;
     if (v1 < 0) and (abs(Frac(v2)) > pogr) then Exit;
     if (abs(v1) < pogr) and (v2 < 0) then Exit;
     delete(s, i, 1);
     v1 := Power(v1, v2);
     PutValue(i, v1);
     p := pos('^', s);
   end;

// *, /
   p := pos('*', s);
   p1 := pos('/', s);
   if (p1 > 0) and ((p1 < p) or (p <= 0)) then p := p1;
   while p > 0 do begin
     if FindRightValue(p, v2) = false then Exit;
     if FindLeftValue(p, i, v1) = false then Exit;
     if s[i] = '*'
       then v1 := v1 * v2
       else begin
         if abs(v2) < pogr then Exit;
         v1 := v1 / v2;
       end;
     delete(s, i, 1);
     PutValue(i, v1);

     p := pos('*', s);
     p1 := pos('/', s);
     if (p1 > 0) and ((p1 < p) or (p <= 0)) then p := p1;
   end;

// +, -
   Num := 0;
   repeat
     Sign := 1;
     while (Length(s) > 0) and (s[1] <> '#') do begin
       if s[1] = '-' then Sign := -Sign
         else if s[1] <> '+' then Exit;
       delete(s, 1, 1);
     end;
     if FindRightValue(0, v1) = false then Exit;
     if Sign < 0
       then Num := Num - v1
       else Num := Num + v1;
   until Length(s) <= 0;

   Result := true;
end;

end.

А это пример использования этого модуля. Он рисует график функции, введенной в Edit1. Константы left и right определяют края графика, а YScale – масштаб по Y.

Code
uses Recognition;

procedure TForm1.Button1Click(Sender: TObject);
const
   left = -10;
   right = 10;
   YScale = 50;
var
   i: integer;
   Num: extended;
   s: String;
   XScale: single;
   col: TColor;
begin
   s := Edit1.Text;
   preparation(s, ['x']);
   XScale := PaintBox1.Width / (right - left);
   randomize;
   col := RGB(random(100), random(100), random(100));
   for i := round(left * XScale) to round(right * XScale) do
     if recogn(ChangeVar(s, 'x', i / XScale), Num) then
       PaintBox1.Canvas.Pixels[round(i - left * XScale),
         round(PaintBox1.Height / 2 - Num * YScale)] := col;
end;


 
Vovich Дата: Пятница, 30.04.2010, 20:29 | Сообщение # 23
Люблю и это здорово!
Группа: Администраторы
ICQ: 380341657
Сообщений: 1010
Статус: Offline


Метка "До окончания осталось .... " в вашем приложении

The Unofficial Newsletter of Delphi Users - by Robert Vivrette
Метка " До окончания осталось .... " в вашем приложении.
Matt Hamilton - mhamilton@bunge.com.au
Перевод Руденко Е.В. janer@newmail.ru
Еще небольшая хитрость! Показано, как сделать в вашем приложении метку , показывающую " оставшееся время" (как, например, в диалоге при загрузке файлов в Internet Explorer).

Этот пример предполагает, что в вашей программе есть некоторый цикл (например " while not EOF" или что-то похожее) и компонент Progress bar.

Во-первых, вам необходим компонент TTimer для обновления Метки. Такой способ обновления Метки более эффективен, чем обновление каждую итерацию вашего цикла, поскольку остающееся время не меняется так часто. Сбросьте таймер по умолчанию и установите интервал его обновления в несколько секунд.

Теперь, перед началом вашего цикла разместите следующий код:

Code
ProgressBar1.Tag := GetTickCount;
Timer1.Enabled := True;  
Далее , в событие OnTimer используйте следующий код:  
procedure TForm1.Timer1Timer(Sender: TObject);
var
    h, m: Integer;
    s: string;
begin
    with ProgressBar1 do
       if Position < >  0 then
       begin
          m := Trunc((Int(GetTickCount) - Tag) * (Max - Position) / Position / 60000);
          h := Trunc(m / 60);
          m := m - h * 60;  
          if h = 1 then
             s := '1 час и '
          else if h >  1 then
             s := '%0:d часов и  ';  

          if m = 0 then
             s := s + '<  1 минута'
          else if m = 1 then
             s := s + '1 минута'
          else if m >  1 then
             s := s + '%1:d минут';  

          Label1.Caption := Format(s + ' остается', [h, m]);
       end;
end;

Заметьте, что Label1 в данном примере и есть метка " остающегося времени" . Отметьте также, что тип GetTickCount установлен в Integer, чтобы устранить различные предупреждения.


 
Vovich Дата: Пятница, 30.04.2010, 20:33 | Сообщение # 24
Люблю и это здорово!
Группа: Администраторы
ICQ: 380341657
Сообщений: 1010
Статус: Offline


Как отсортировать последовательный список в базе данных / Как вставить запись в середину списка.

> У кого-нибудь есть идея, как упорядочить такой список элегантным способом?
Arthur Hoornweg
> У меня была подобная проблема со списком адресов поставщиков, которые были записаны в произвольном порядке.
> Наилучший путь - создать такое поле, которое позволит вам вставить запись между существующими.
> SQL данные не упорядочены по умолчанию, так что проблема вставки между двумя записями совсем не очевидна..
> Мы использовали длинное целое число , которое менялось , например, на 1000 от записи к записи. Когда мы хотели вставить новую запись между двумя существующими, то устанавливали это число между номерами двух записей и потом сортировали список. Получалось то, что надо.

Мы также создали хранимую процедуру, которая запускалась ночью и перенумеровывала все записи с инкрементом 1000. До определенного числа записей все это работает хорошо. Для небольшого диапазона записей инкремент можно даже увеличить до 2000 или 5000.

Jeff Wright
}
Предположим, что однажды созданный Первичный ключ не может быть изменен.
{
Лучшее решение, которое я нашел для этого, использовать
вещественное число для первичного ключа.
Когда вам необходимо вставить запись между двумя существующими,
то для ее ключа берется число ,
лежащее в диапазоне между ключами существующих записей.

Bill Todd - TeamB
}
Из-за ограничения точности вещественных чисел (15 знаков) возникают трудности
при вставке большого числа записей

{
Вот решение:
Эта функция выделяет дробную часть вещественного числа.

function getDeciFrac(aForValue: Double): String;
var
tmpStr: String;
i, DeciPos: SmallInt;
begin
tmpStr := FloatToStr(aForValue);
DeciPos := Pos('.', tmpStr);
ifDeciPos> 0 then tmpStr := Copy(tmpStr, DeciPos+1, Length(tmpStr))
else tmpStr := '';
Result := '';
for i:=1 to (Length(tmpStr)-1) do begin
Result := Result + '0';
end;
Result := '0.'+Result;
end;
Эта функция вычисляет вещественное число , лежащее между первым
и вторым значениями.
Например: Если заданы числа '10.10 & 10.11',
то эта функция возвратит '10.101'.
{
Знает ли кто-нибудь функцию, которая вычисляет соседние числа с плавающей точкой
Volker W. Walter
}
Да! при небольшой модификации эта функция может использоваться для поиска
Следующего и Предыдущего числа с плавающей точкой.
function getInBewteenfFloat(FirstVal, SecondVal: Double): Double;
var
DeciFracStr: String;
tmpFloat: Double;
runCount: SmallInt;
begin
Result := 0;
runCount := 1;
if ((FirstVal=SecondVal) or
((FirstVal=0) and (SecondVal< =1))) then begin
MessageDlg('Cannot be inserted !',mtError,[mbOK],0);
Exit;
end;
if (SecondVal=0) then begin
Result := Trunc(FirstVal)+1;
Exit;
end;
if (FirstVal> 0) then DeciFracStr := getDeciFrac(FirstVal)
else DeciFracStr := getDeciFrac(SecondVal);
while runCount< =15 do begin
if(FirstVal> 0) then begin
tmpFloat := FirstVal + StrToFloat(DeciFracStr + '1');
end else begin
tmpFloat := SecondVal - StrToFloat(DeciFracStr + '1');
end;
DeciFracStr := DeciFracStr + '0';
{
Вы не можете точно сравнить два вещественных числа.
Всегда возникает ошибка из-за потери точности, вызванная ограничением на
число цифр в десятичной части числа.
}
tmpFloat := StrToFloat(FloatToStr(tmpFloat));
if (tmpFloat> FirstVal) and(tmpFloat(*< )SecondVal) then begin
Result := tmpFloat;
Exit;
end;
inc(runCount);
end;
if(Length(FloatToStr(Result))> 16) then Result := 0;
if(Result< 0) then begin
Result := 0;
MessageDlg('Cannot be inserted !',mtError,[mbOK],0);
end;
end;

Вы должны создать поле RecPosNo с вещественным значением величины в таблице, куда вы хотите вставлять записи.
Это поле должно быть первичным ключем и также первым среди существующих ключевых полей. (Для демонстрации используется таблица Employee.db , расположенная в '\Program Files\Borland\ Delphi 5\Demos\Data' .) Полный исходный код данного проекта FloatIns.Zip приложен к данной статье.
Скачайте
http://www.undu.com/libs/FloatIns.Zip
& распакуйте в директорию.
Создайте алиас " FloatIns" типа PARADOX, установите
путь к \FloatIns\Data директории.
Предложенную функцию можно использовать в событиях BeforeInsert &
AfterInsert event.
Скомпилируйте и запустите FloatIns. используйте кнопку
Insert для вставки записей.

Примечание: Не позволяйте пользователю вводить/модифицировать величину RecPosNo или Primary key.

 
Форум » Компьютеры, телекоммуникации, ПО... » Программирование » FAQ по Delphi
Страница 3 из 3«123
Поиск: