Создаем ярлыки в коде.

На Delphi есть не мало различных вариантов создания ярыков в коде. И в общем-то они рабочие, но только в том случае если писать на средах младше RadStudio 2009.

Постольку поскольку 2009 студия целиком и полностью перешла на юникод, со старыми вариантами создания ярлыка так же возникли проблемы. Пытался всяко разно решить проблему методом бубна над кодом, изменением кодировок вручную и т.п. Потом мне этот беспорядок надоел и нашёл я метод решения построенный на COM объектах. В общем плюс данной реализации в том, что нету тонких мест, которые ломаются при работе со строками. Проверено лично мной, вердикт - работает :)

Источник реализации.

Привожу самую малость модернизированный код:

uses 
  Registry, 
  ActiveX, 
  ComObj, 
  ShlObj; 

type 
  ShortcutType = (_DESKTOP, _QUICKLAUNCH, _SENDTO, _STARTMENU, _OTHERFOLDER); 

////////////////////////////////////////////////////////////////////////////////
// Выдает директорию системного меню "Программы" по умолчанию
// так же выдает Application Data текущего пользователя. (нужно для Quik Launch)
function GetProgramDir(GetApp: Boolean = False): string;
var
  reg: TRegistry;
begin
  reg := TRegistry.Create;
  try
    reg.RootKey := HKEY_CURRENT_USER;
    reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', False);
    if not GetApp then
      Result := reg.ReadString('Programs')
    else
      Result := reg.ReadString('AppData');
    reg.CloseKey;
  finally
    reg.Free;
  end;
end;

function CreateShortcut(SourceFileName: string; // the file the shortcut points to
                        InkName: String; //Имя самого ярлычка (XIO)
                        Location: ShortcutType; // shortcut location
                        SubFolder,  // subfolder of location
                        WorkingDir, // working directory property of the shortcut
                        Parameters,
                        Description: string): //  description property of the shortcut
                        string;
const
  SHELL_FOLDERS_ROOT = 'Software\MicroSoft\Windows\CurrentVersion\Explorer';
  QUICK_LAUNCH_ROOT = 'Software\MicroSoft\Windows\CurrentVersion\GrpConv';
var
  MyObject: IUnknown;
  MySLink: IShellLink;
  MyPFile: IPersistFile;
  Directory, LinkName: string;
  WFileName: WideString;
  Reg: TRegIniFile;
begin

  MyObject := CreateComObject(CLSID_ShellLink);
  MySLink := MyObject as IShellLink;
  MyPFile := MyObject as IPersistFile;

  MySLink.SetPath(PChar(SourceFileName));
  MySLink.SetArguments(PChar(Parameters));
  MySLink.SetDescription(PChar(Description));

//  LinkName := ChangeFileExt(SourceFileName, '.lnk');
  LinkName := ChangeFileExt(InkName,'.lnk');//ExtractFileName(LinkName); //XIO Edit

  // Quicklauch
  if Location = _QUICKLAUNCH then
  begin
    Reg := TRegIniFile.Create(QUICK_LAUNCH_ROOT);
    try
      Directory := Reg.ReadString('MapGroups', 'Quick Launch', '');
    finally
      Reg.Free;
    end;
  end
  else
  // Other locations
  begin
    Reg := TRegIniFile.Create(SHELL_FOLDERS_ROOT);
    try
    case Location of
      _OTHERFOLDER : Directory := SubFolder;
      _DESKTOP     : Directory := Reg.ReadString('Shell Folders', 'Desktop', '');
      _STARTMENU   : Directory := Reg.ReadString('Shell Folders', 'Start Menu', '');
      _SENDTO      : Directory := Reg.ReadString('Shell Folders', 'SendTo', '');
    end;
    finally
      Reg.Free;
    end;
  end;

  if Directory <> '' then
  begin
    if (SubFolder <> '') and (Location <> _OTHERFOLDER) then
      WFileName := Directory + '\' + SubFolder + '\' + LinkName
    else
      WFileName := Directory + '\' + LinkName;

    if WorkingDir = '' then
      MySLink.SetWorkingDirectory(PChar(ExtractFilePath(SourceFileName)))
    else
      MySLink.SetWorkingDirectory(PChar(WorkingDir));

    MyPFile.Save(PWChar(WFileName), False);
    Result := WFileName;
  end;
end;

SQL синтаксис для MS Access

Нашел отличное описание слабо документированной стороны MS Access, а именно синтаксис SQL команд, которые к сожалению некоторыми деталями отличаются от стандартного SQL.

Источник - 1
А вот на MSDN'е

Бета Версия! Блокнотика.

И года как говориться не прошло. Обозревал я тут в прошлом году программку свою

Не могу сказать что с тех пор она сильно изменилась, так как эти месяцы на домашние проекты сил почти не остается. Но до бета версии все таки дотянул, что ж потихоньку дотянем и до релиз кандидата =)))

Справки пока к сожалению нет. Поэтому прежде чем разберетесь что к чему придется наверное потыкаться, хоть я и старался делать интерфейс интуитивно понятным. Но мы то знаем что это фикция, такого интерфейса не существует

Для сортировки главного списка по всевозможным правилом, вызовите на табличке контекстное меню(правая кнопка мыши) и там выберите "Сортировка". Остальное думаю сможете найти без подсказок.

Следующая версия в ближайшие недели надеюсь, как получится, но финал будет это стабильно Вопрос лишь в том, что в него войдет

А пока жду помидорки и яйца в адрес бета версии

Качать тут

Из обнаруженного за сегодня:
Список доработок которые необходимо сделать:

- Переименовать дату ухода в дату смерти.
- Спрятать дату смерти до востребования, что бы не моячила при забивании субъектов.
- Подумать о дополнительном столбце "ближайшее событие" в главной таблице.
- Поиск по реквизитам/контактам подфорсировать.
- Базу замаскировать.
- с импортом и экспоротом с Аутлуком/батом буду ещё думать. Дело не в базе, у аутлука есть возможность подключения к нему через OLE Objects, и можно там делать что угодно, опираясь на описанные APi функции. Но проблема в отличиях этих самых APi в разных версиях Офиса, пока просто в плане разобраться с этим поподробнее.
- Оживить Контекстное меню главной таблички. Доделать.
- Просмотр инфы о контакте по даблКлику в табличке
- Исключить из употребление в программе термин "Субъект"
- Подумать об объединении Напоминаний и Событий в одну группу.
- В окошках с табличками кнопки по добавлению/удалению и т.п. продублировать снизу окон. Для лучшей юзабильности.
- Для активации фильтра по категориям вместо нового окна сделать выпадающий список под кнопкой.
- Если загружен неизвестный формат фотографии, на поле фото написать "Неизвестный формат".
- В напоминаниях, реквизитах, позволено оставлять пустые записи, запретить... сделать как в справочниках.
- добавить формочку с календарем, где был бы календарь и помечено, на каких числах висят события и напоминания, ДР и т.п. ... Как в стандартных ежедневниках.
- Проверить события, подглючивают мал-мал. С добавлением и с оповещением О_о.. Запретить оставлять поля с датами пустыми.
- Не обновляется Today ("Сегодня") после добавления событий, напоминаний и т.п. После закрытия привязанных окон делать Requery().

Открыть файл и дождаться закрытия.

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

Из этой ситуации выходит задача, сделать так что бы измененный файл загружался в базу. Как это сделать? На первый взгляд легко и просто, если задуматься не так тривиально.

 Файлы ведь могут быть разных форматов, и ворд и эксель, и текстовый и может даже фотография формата GIMP. Из этого следует что CreateProcess нам не подходит, так как в коде определять какой программой открывать файл - лишние проблемы и подводные грабли. Не стоит так извращаться.
В свою очередь ShellExecute имеет другой недостаток, он хоть и способен автоматически открыть файл в ассоциированной ему программе, но он не дает хэнд процесса, что не позволяет нам дождаться завершения процесса. А раз мы не можем дождаться завершения процесса, стало быть как мы узнаем через какое время пользователю надумается сохранить изменения в файле и закрыть его, для того что бы затянуть измененный файл назад в базу. Это основная проблема на которую я наткнулся при решении задачи.

Но Google никогда не подводил, буквально час ушел на поиск нужного решения. Есть такой промежуточный метод между CreateProcess и ShellExecute. И имя его ShellExecuteEx.

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

Код процедуры:

procedure RunAndWaitShell(Executable, Parameter: STRING; ShowParameter: INTEGER);
  var
     Info: TShellExecuteInfo;
     pInfo: pShellExecuteInfo;
     exitCode: DWord;
  begin
     pInfo := @Info;
     Info.cbSize := SizeOf(Info);
     Info.fMask  := SEE_MASK_NOCLOSEPROCESS;

     Info.wnd    := application.Handle;
     Info.lpVerb := NIL;
     Info.lpFile := PChar(Executable);
     Info.lpParameters := PChar(Parameter + #0);
     Info.lpDirectory  := NIL;
     Info.nShow        := ShowParameter;
     Info.hInstApp     := 0;
     ShellExecuteEx(pInfo);
     repeat
        exitCode := WaitForSingleObject(Info.hProcess, INFINITE); //было 500
        Application.ProcessMessages;
     until (exitCode <> WAIT_TIMEOUT);
  end;

{Если форма приложения имеет свойство AlwaysOnTop заменить SEE_MASK_NOCLOSEPROCESS на SEE_MASK_FLAG_DDEWAIT }

Теперь пример использования:

//...

  RunAndWaitShell('D:\test.txt','',SW_SHOWNORMAL); //Открываем файлик, где бы он ни находился.

//Идет ожидание пока не закроется программа которая открыла файл. Если пользователь внес

//свои изменения, то мы можем их получить и записать в базу.

//Тут в общем-то берем этот же файл и пишем его  в базу, заменяя старый вариант, по желанию

//можно устроить проверку на изменения в файле.
//  ShowMessage('The End or the programm.');

//...

Такое в общем простое решение на такую в общем-то нужную в жизни задачу, если у кого-то есть более оптимальные решения - пишите :) Если что-то не понятно, тоже пишите =)

Скажем НЕТ! - оператору "GoTo"

Помню как только мы прошли для галочки оператор goto (ГоуТу), по учебной программе колледджа, я как бы его не взлюбил, особенно после того как преподавательница нам намекнула о том что его лучше не использовать и что его использование считается дурным тоном программирования.

Так вот дело понятное, сейчас работая с такими довольно массивными проектами написанными на Дельфи, иногда мне встречаются модули в которых используются эти самые операторы. Блин, я больше всего не люблю изменять такие модули(хорошо что их всего парочка), потому что как правило в них исправляя одну проблему появляется новых две, ведь кода в них не мало, писался этот код несколькими программистами до меня, и чтобы понять всю логику таких модулей приходится тратить не один час, а иногда не один день, и уж поверьте это удручает, поэтому начинающим программистам чисто так по человечески скажу - не привыкайте использовать этот оператор с "малых лет".

Теперь немного ближе к теме. Прошли мы значит в колледже этот оператор, учитель сказал нам что это "кака", но вот проходит пара лекций и вдруг нам дается официальное разрешение использовать данный оператор для создания цветового меню. Как же я тогда в душе злился. Я помню тогда подошел к преподавателю и показал ей свой вариант решения задачи, где не нужно было использовать никакого оператора Goto, и при этом все прекрасно работало, но в ответ получил примерно следующую фразу "Молодец, ты можешь так придумать, а другие не могут, поэтому пусть делают как умеют". Я помню пытался одногруппникам донести свой вариант, и объяснить почему так лучше, но понимание нашел лишь у пары человек. Остальным было пофиг.

Обычная реализация данного меню состояла в том что при нажатии определенных клавиш оператор Goto переносил курсор в нужный кусок кода который в свою очередь делал какие-то перерисовки и выполнял определенные действия и ждал следующего нажатия при надобности чтобы в очередной раз перейти в другой кусок кода. Когда одногрупники стали использовать такой вариант в своих более менее весомых(больших) программах, разобраться в их коде было сложно, и когда меня просили помочь с чем-то, я первые раза три отправлял таких лесом и рекомендовал привести код в порядок ибо было мне в лом разбираться в "стоге сена".

А теперь демонстрирую свой вариант реализации цветого меню в Паскале, с возможностью строить многоуровневые меню. Кстати в данном варианте все ещё есть недостатки, то есть, имеются "штуки" которые можно сделать ещё лучше, но это вы уж сами :)
Код моего варианта, с примером использования:

Uses crt;
 var str,str2,STR3:array[1..20]of string;
     I:integer;
     k:char;
     X11,X22:integer;

{Универсальная процедура для вывода вертикального меню, параметры описаны ниже}
Procedure menu(kl,XX,YY:integer; pun:array of string;
          fon,txt,fon1,txt1:integer;var key:char; X1:integer);
    {колич.пунк.}{место по Х}{место поУ}{имена пунк.}{нор.фон}
    {нор.текст}{выд.фон}{выд.текст}{код клавиши}{положение курсора}
      begin
       textbackground(fon);
        textcolor(txt);
       { ClrScr;}
{         GotoXY(XX,YY); Кому надо можно использовать рамку, но для вложенных менюх такой вариант не пойдет.
            write('г============МЕНЮ============¬');
          For I:=1 to kl+1 do begin
          GotoXY(XX,YY+i);
            write('¦                            ¦');
          end;
           GotoXY(XX,YY+i);
            write('L============================-');}
              For I:=1 to kl do begin
                GotoXY(XX+1,YY+i);
                  write(pun[i]);
              end;
              x1:=1;
            repeat
              if key=#80 then X1:=X1+1;
              if key=#72 then X1:=X1-1;
                     if X1>KL then X1:=1;
                     if X1<1 then X1:=KL;
              For I:=1 to kl do begin
               If x1=i then begin textcolor(txt1); textbackground(fon1); end
                 else begin textcolor(txt); textbackground(fon); end;
                   GotoXY(XX+1,YY+i);
                     write(pun[i]);
              end;
            key:=#0;
            key:=readkey;
            Until (key=#13)or(key=#27);
      end;
    {Процедура для вывода горизонтального меню, для отдельных частных случаев требует некоторой правки.
    Желающие могут усовершенствовать до универсального вида.}
        Procedure Main_menu(var Y1:integer;Key:char);
             begin
             Y1:=1;
             repeat
             GotoXY(1,1);
               write('Файлы БД    Задачи    Выход');
                 if key=#75 then Y1:=Y1-1;
                 if key=#77 then Y1:=Y1+1;
                   if Y1>3 then Y1:=1;
                   if Y1<1 then Y1:=3;
         GotoXY(1,1);
          If y1=1 then begin textcolor(15); textbackground(4); end
            else begin textcolor(15); textbackground(9); end;
             write(' Файлы БД  ');
          GotoXY(12,1);
           If y1=2 then begin textcolor(15); textbackground(4); end
            else begin textcolor(15); textbackground(9); end;
             write('  Задачи  ');
          GotoXY(22,1);
           If y1=3 then begin textcolor(15); textbackground(4); end
            else begin textcolor(15); textbackground(9); end;
             write(' Выход ');
            key:=#0;
            key:=readkey;
            Until key=#13;
           end;
     
      Begin
    {А вот и простейший пример использования данных процедур в комбинации.}
      ClrScr;
    {Заполняем массив пунктов первого меню}
      str[2]:='  Файл 1   ';
      str[3]:='  Файл 2   ';
      str[4]:='  Файл 3   ';
      str[5]:='  Файл 4   ';
      str[6]:='  Файл 5   ';
      str[7]:='  Выход    ';
   
    {Заполняем массив пунктов второго меню}
      str2[2]:=' Задача 1 ';
      str2[3]:=' Задача 2 ';
      str2[4]:=' Задача 3 ';
      str2[5]:=' Задача 4 ';
      str2[6]:=' Задача 5 ';
      str2[7]:=' Выход    ';

    {Заполняем массив пунктов третье меню(вложенность третьего уровня)}
      str3[2]:=' Ввод в файл             ';
      str3[3]:=' Дополнение файла        ';
      str3[4]:=' Удаление из файла       ';
      str3[5]:=' Замена компонент файла  ';
      str3[6]:=' Вставка компонент файла ';
      str3[7]:=' Просмотр файла          ';
      str3[8]:=' Выход                   ';
     
      Main_menu(X11,K); {вызовим главное меню(горизонтальное).}
      {Получив    в переменную X11 номер выбранного пункта, вызовим соответствующее подменю.}
      If (X11=1) then
    begin
          Menu(6,0,1,str,9,15,4,3,k,x22);
          If (k=#13) then
            Menu(7,11,X22+1,str3,9,15,4,3,k,x22);
    end;
      if (X11=2) then
        Menu(6,11,1,str2,9,15,4,3,k,x22);

      end.

Код конечно нуждается в хорошем рефакторинге, но сильно строго не судите, писал я его в 2005 году будуче не опытным студентом :) Но в качестве примера сойдет, да и основная мысль думаю ясна. Если все же что-то не понятно постите в комментариях свои вопросы, поясню.
К коду добавлю пару слов. Все операторы Goto были заменены такой конструкцией как процедура/функция, и циклами, на мой взгляд куда лучше чем перемещаться по дублирующим друг друга кускам кода которые в дальнейшем крайне тяжело править. Понятное дело что такие с позволения сказать программы, нужны наверное только студентам и тем кто делает на студентах деньги, но просто не мог смолчать =)

Это не большое отступление так сказать о наболевшем. В следующий раз постараюсь обозреть процесс создания игры-арканойда все на том же добром Турбо-Паскале, а затем уже буду потихоньку прекращать описывать "баяны" написанные на Паскале =)

Эффект "Матрицы" в Турбо-Паскаль

Ближайшие несколько постов большинству читателей покажутся совсем уж простыми, ибо накатила на меня настольгия по студенческим годам и решил я вспомнить Турбо Паскаль :)

Для начала, так скажем для разминки и открытия сезона Турбо Паскаля приведу описание простенькой программки которая будет визуально иметировать эффект "Матрицы". Ну кто из Вас, дорогие читатели не смотрел фильм "Матрица"? Я думаю таких сейчас днем с огнем не отыщешь, посему от слов постепенно переходим к делу.

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

Uses crt, Dos;
  var s,i,x,y,D,n: integer;
        r: real;
      regs: Registers;
   begin
     clrscr;
      regs.ah := 1;
      regs.ch := $20;
      regs.cl := 0;
      regs.bh := 0;
      Intr($10,regs);
      x:=1; y:=1;
      TextColor(RED);
      Writeln('                                ВНИМАНИЕ!!!');
      Writeln('Для полного эффекта просмотра разверните окно на весь экран (Alt+Enter)');
      writeln('Затем нажмите любую клавишу...');
      readkey;
      clrscr;
      REPEAT
        textattr:=10;
        r:=1;
         while r<=128 do
          r:=r+0.001;
             Randomize;
       N:=random(9);
       for I:=1 to N do begin
        d:=random(70);
        If d<10 then d:=10;
           gotoxy(x,y);
         write(CHR(d));
        y:=y+1;
       if y=25 then y:=1;
         end;
        X:=random(80);
       if x>=80 then x:=1;
        writeln;
       writeln;
      UNTIL KEYPRESSED;
         textattr:=138;
          gotoxy(32,12);
         writeln('г==============¬');
          gotoxy(32,13);
         writeln('¦ Matrix error ¦');
          gotoxy(32,14);
         writeln('L==============-');
           readln;
             gotoxy(57,24);
             TextColor(yellow);
           writeln('Автор: Мукомело Евгений');
       readln;
     end.

Теперь давайте попробуем разобрать что же мы настрочили :)
Первые строки думаю ни у кого вопросов не вызовут, а вот этот кусок:
      regs.ah := 1;
      regs.ch := $20;
      regs.cl := 0;
      regs.bh := 0;
      Intr($10,regs);
нам необходим для того что бы спрятать курсор. Если этого не сделать то по экрану будет бегать курсор и будет портить всю красоту того что мы изображаем. Для реализации используется пример из книги "Профессиональное программирование на Турбо-Паскале" А. Файсмана. Для тех кто хочет изучить всю глубину - может найти эту книгу либо погуглить, а если в крации то устанавливаются определенные параметры переменной типа Регистрс, затем инициируется вызов прерывания $10 используя при этом функционал DOS.TPU библиотеки.

И так, курсор мы спрятали. Далее по коду проводим подготовку, присваиваем первичные значения переменным, и далее.. Далее открываем цикл с постусловием, который заканчивается тогда, когда срабатывает событие нажатия клавиши на клавиатуре. А в этом самом цикле и начинается все самое интересное. Алгоритм у нас примерно следующий:
Цикл
- Выполняем импровизированную задержку, путем выполнения цикла сложения чисел.
- Далее с помощью генерации случайных (псевдослучайных) числе определяем то, какой длинны у нас будет выводимый столбец (ряд символов).
ПодЦикл
- С помощью функции генерации псевдослучайных чисел Random выберем произвольный символ из таблицы ACSII. Лично я использовал символы из диапазона от 10 до 70.
- Перемещаем курсор в нужную часть экрана с помощью gotoxy() и выводим случайный символ.
- Инкрементируем позицию курсора Y (по вертикали)
Конец ПодЦикла
- Выбираем  случайным образом, в какой позиции X (по горизонтали) будем выводить следующий ряд символов.
- Выводим новую строку, для смещения экрана вверх
Конец Цикла

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

 

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

Кстати стоит заметить, что запускать такую программу лучше всего в полноэкранном режиме (Alt+Enter), потому как в окне консоли анимации и прочие подвижные действия в DOS программах выглядят не полноценно и убого, страшно тормозя.

В следующей статье поговорим о том как плохо использовать операторы GOTO.

Узнаем о дате максимум. Модуль для работы с датой

Постольку поскольку моя профессиональная деятельность в большинстве случаев протекает именно в среде разработки Borland/CodeGear Delphi, то и рассматриваемые примеры в блогах будут приводиться соответствующие.

Давно, очень давно я увлекся написанием одной программки, которая была призвана помочь мне не забыть о важной дате, о Дне Рождении друга и т.п. Есть несколько версий программки, которые даже распространялись через инет, но не в том суть. Когда я начинал писать ту программку, первое с чем мне пришлось столкнуться - Даты.

Думаю не имеет смысла сейчас описывать тип TDateTime, кому интересно может заглянуть в запылившуюся на полке книжку либо воспользоваться Гуглом. А я тем временем, предлагаю рассмотреть модуль, который состоит из нескольких простейших казалось бы функций и процедур. Тем не менее некоторые из них придумались не за 5 и не за 10 минут. А отлаживались и того дольше. Но тем не менее прошли обкатку в реальных условиях использования и даже методом рефакторинга приведены к вполне разумному виду для понимания.

Итак привожу код модуля:

////////////////////////////////////////////////////////////////////////////////
//             ПРОЦЕДУРЫ И ФУНЦКЦИИ ДЛЯ РАБОТЫ С ДАТОЙ И ВРЕМЕНЕМ             //
//                АВТОР: МУКОМЕЛО ЕВГЕНИЙ БОГДАНОВИЧ ака XIO                  //
//                   Дата создания:  09072009                                 //
//                   Дата изменения: 25072009                                 //
////////////////////////////////////////////////////////////////////////////////
unit xDateWork;

interface

  Const
    tbdTypeDay    = 0;
    tbdTypeHour   = 1;
    tbdTypeMinute = 2;
    tbdTypeSecond = 3;

    Function GetAgeOf(XDate: TDateTime): integer;
    Function GetDaysCountOf(XDate: TDateTime): integer;
    Function GetJubiOf(XDate: TDateTime): Byte;
    Function GetZadiak(HB_Date_L:TDateTime):integer;
    Function TimeBeforeDate(DateX: TDateTime; ResType: Byte): Integer;

implementation

Uses DateUtils, SysUtils;

////////////////////////////////////////////////////////////////////////////////
//
//  ПРОЦЕДУРА: GetDateInfo
//
//  НАЗНАЧЕНИЕ: Выдает количество дней оставшихся до Дня Рождения, и возраст
//              человека.
//
//  ПАРАМЕТРЫ:
//    HB_DATE - Дата Рождения человека.
//    AGE - Возраст человека.
//    Days_Before_HB - Количество дней оставшихся до Дня Рождения.
//    Jubilee - Будет юбилейная дата или нет. 1/0
//
Procedure GetDateInfo(HB_DATE:TDateTime; var AGE:Integer; var Days_Before_HB:Integer; var Jubilee:Byte);
  Var
    Year_HB:    TDateTime; //Год рождения
    Year_Now:   TDateTime; //Текущий год
    CountYear:  TDateTime; //Количество лет
    Now_Date:   TDateTime; //Текущая дата

    CountYearI : Double;   //тоже самое по сути.. может без неё обойдемся???

    InkHB_Have: byte; //Индикатор того что Д.Р. в этом году уже был.  (0-не прошёл, 1-прошёл)
    StrDate: String[20];  //Дата рождения
    StrDate2: String[20]; //Текущая дата
    StrYear: String[20];  //текущий год
    StrYear2: String[20]; //текущий год + 1
    Ubl1: Integer; // возраст в формате Integer.
    Ubl2: String[20]; //для перевода Double в String и затем его в Integer...
    IntYear: integer; //переводим год в целое число что бы инкриментировать его.
    I: integer; // счетчик цикла.
    DTDate: TDateTime; //для преобразования строки в дату.
    CountDays1: Integer; //Количество дней до Нового года если ДР будет в след. году.
    CountDays2: Integer; //количество дней от начала года до ДР
    SumCount : Integer; //сумма количества дней, то есть количество дней оставшихся до ДР.
begin
  //Задаем начальные значения.
  Now_Date := DateOf(Now());
  Year_HB := YearOf(HB_Date);
  Year_Now := YearOf(Now());
  CountYear := Year_Now - Year_HB;
  CountYearI := CountYear;

  //Если месяц д. рождения > текущего
  //Тогда возраст в этом году ещё не прибавился на 1
  If MonthOf(HB_DATE) > MonthOf(Now_Date) then
    begin
      CountYearI := CountYearI - 1;
      InkHB_Have := 0
    end //если месяц др = текущему и день рождения больше текущего числа тогда в этом году др ещё не было.
  else If (MonthOf(HB_DATE) = MonthOf(Now_Date)) and (DayOf(HB_DATE) > DayOf(Now_Date)) then
        begin
          CountYearI := CountYearI - 1;
          InkHB_Have := 0
        end
       else //иначе ДР уже произошел
        InkHB_Have := 1;

//  AGE := CountYearI; // текущий возможный возраст.
  Ubl2 := FloatToStr(CountYearI);//переведем вещественное число в строку.
  Ubl1 := StrToInt(Ubl2); //строковое вещественное в целое.
  AGE := Ubl1; // текущий возможный возраст.
  StrDate  := DateToStr(HB_Date);
  StrDate2 := DateToStr(Now_Date);
  StrYear  := '';

  //если День Варенья ещё не произошел в этом году
  If InkHB_Have = 0 then
    begin  // у даты рождения подменяем год на текущий. для использования функции DaysBetween
      For I:=10 DownTo 7 do
        Delete(StrDate,I,1);
      For I:=7 to 10 do
        StrDate := StrDate + StrDate2[I];
      DTDate := StrToDate(StrDate);
      Days_Before_HB := DaysBetween(Now_Date,DTDate);
    end
  else
    begin
      For I:=7 to 10 do
        StrYear := StrYear + StrDate2[I]; //Записываем год текущий в виде строки.
      IntYear := StrToInt(StrYear); //Переводим текущий год в целое число.
      Inc(IntYear); //Инкрементируем.
      StrYear2 := IntToStr(IntYear); //Снова переводим в строку. уже инкрементированный вариант.
      For I:=10 DownTo 7 do
        Delete(StrDate,I,1);
      For I:= 1 to 4 do //в дате рождения подменяем год текущим годом.
        StrDate := StrDate + StrYear[I];
      StrDate2 := DateToStr(HB_DATE);// переводим значение Даты Рождения в формат строки.
      For I:=10 DownTo 7 do //Подменяем в дате Рождения год на текущий + 1
        Delete(StrDate2,I,1);
      For I:= 1 to 4 do
        StrDate2 := StrDate2 + StrYear2[I];
      DTDate := StrToDate(StrDate);

      //Далее обходим возможные ошибки связанные с тем, в каком году мы находимся...
      // Получаем количество дней до Нового Года
      CountDays1 := DaysBetween(Now_Date, StrToDate('31.12.'+StrYear));
      Try
        //пытаемся получить количество дней до ДР от начала следующего года...
        CountDays2 := DaysBetween(StrToDate('01.01.'+StrYear2), StrToDate(StrDate2));
      Except
        //если год не высокостный обрабатываем исключение связанное с ДР 29 Февраля.
        //И все же получаем количетсво дней до ДР.
        StrDate2[2] := '8';
        CountDays2 := DaysBetween(StrToDate('01.01.'+StrYear2), StrToDate(StrDate2));
      End;
      SumCount := CountDays1 + CountDays2; // получаем сумму количества дней оставшихся до ДР
      Days_Before_HB := CountDays1+CountDays2;
    end;

  If Now_Date = DTDate then //ДР наступил уже сегодня.
     Days_Before_HB := 0; //и дней осталось нуль.
  if Days_Before_HB = 0 then //раз дней осталось нуль значит ДР уже наступил или прошёл и возраст правильный.
    If (((Ubl1) mod 5) = 0)or(Ubl1 = 16)or(Ubl1 = 18) then
      Jubilee := 1
    else
      Jubilee := 0
  else //иначе ДР ещё только будет, и надо прибавить 1 чтобы понять будет Юбилей или просто ДР.
    If (((Ubl1+1) mod 5) = 0)or(Ubl1+1 = 16)or(Ubl1+1 = 18) then
      Jubilee := 1
    else
      Jubilee := 0;
end;

////////////////////////////////////////////////////////////////////////////////
//
//  ФУНКЦИЯ: GetAgeOf
//
//  НАЗНАЧЕНИЕ: Возвращает только возраст по дате рождения.
//
//  ПАРАМЕТРЫ:
//    XDate - Дата рождения, возраст от которой нужно расчитать.
//
Function GetAgeOf(XDate: TDateTime): integer;
var
  Age_L: Integer;
  Days_L: Integer;
  Jubi: Byte;
begin
  GetDateInfo(XDate,Age_L,Days_L,Jubi);
  GetAgeOf := Age_L;
end;

////////////////////////////////////////////////////////////////////////////////
//
//  ФУНКЦИЯ: GetDaysCountOf
//
//  НАЗНАЧЕНИЕ: Возвращает только количество дней до даты рождения.
//
//  ПАРАМЕТРЫ:
//    XDate - Дата рождения, до которой считаем колличество оставшихся дней.
//
Function GetDaysCountOf(XDate: TDateTime): integer;
var
  Age_L: Integer;
  Days_L: Integer;
  Jubi: Byte;
begin
  GetDateInfo(XDate,Age_L,Days_L,Jubi);
  GetDaysCountOf := Days_L;
end;

////////////////////////////////////////////////////////////////////////////////
//
//  ФУНКЦИЯ: GetJubiOf
//
//  НАЗНАЧЕНИЕ: Определяет, будет юбилей в этом году или нет.
//
//  ПАРАМЕТРЫ:
//    XDate - Дата рождения которую проверяем на юбилейность.
//
Function GetJubiOf(XDate: TDateTime): Byte;
var
  Age_L: Integer;
  Days_L: Integer;
  Jubi: Byte;
begin
  GetDateInfo(XDate,Age_L,Days_L,Jubi);
  GetJubiOf := Round(Jubi);
end;

////////////////////////////////////////////////////////////////////////////////
//
//  ФУНКЦИЯ: GetZadiak
//
//  НАЗНАЧЕНИЕ: По дате рождения, определяет знак задиака.
//
//  ПАРАМЕТРЫ:
//    HB_Date_L - Дата рождения, по которой будет определён знак задиака.
//
Function GetZadiak(HB_Date_L:TDateTime):integer;
Var
  Month: Integer;
  Day: Integer;
begin
  Try
    Month := MonthOf(HB_Date_L);
    Day := DayOf(HB_Date_L);
    If (Month=3) and (Day>=21) or (Month=4) and (Day<=20) then
      GetZadiak := 1; //Овен
    If (Month=4) and (Day>=21) or (Month=5) and (Day<=21) then
      GetZadiak := 2; //Телец
    If (Month=5) and (Day>=22) or (Month=6) and (Day<=21) then
      GetZadiak := 3; //Близнецы
    If (Month=6) and (Day>=22) or (Month=7) and (Day<=22) then
      GetZadiak := 4; //Рак
    If (Month=7) and (Day>=23) or (Month=8) and (Day<=23) then
      GetZadiak := 5; //Лев
    If (Month=8) and (Day>=24) or (Month=9) and (Day<=23) then
      GetZadiak := 6; //Дева
    If (Month=9) and (Day>=24) or (Month=10) and (Day<=23) then
      GetZadiak := 7; //Весы
    If (Month=10) and (Day>=24) or (Month=11) and (Day<=22) then
      GetZadiak := 8; //Скорпион
    If (Month=11) and (Day>=23) or (Month=12) and (Day<=21) then
      GetZadiak := 9; //Стрелец
    If (Month=12) and (Day>=22) or (Month=1) and (Day<=20) then
      GetZadiak := 10; //Козерог
    If (Month=1) and (Day>=21) or (Month=2) and (Day<=18) then
      GetZadiak := 11; //Водолей
    If (Month=2) and (Day>=19) or (Month=3) and (Day<=20) then
      GetZadiak := 12; //Рыбы
  Except
    GetZadiak := 0;
  end;
end;

////////////////////////////////////////////////////////////////////////////////
//
//  ФУНКЦИЯ: TimeBeforeDate
//
//  НАЗНАЧЕНИЕ: Как результат выдает количество оставшихся дней, часов, минут,
//              секунд до указанной даты.
//
//  ПАРАМЕТРЫ:
//    DateX   - Дата количество дней до которой необходимо расчитать
//    ResType - Тип возвращаемого результата (Дней, Часов, Минут, Секунд)
//
Function TimeBeforeDate(DateX: TDateTime; ResType: Byte): Integer;
Var
  DaysX:   Integer;
  HourX:   Integer;
  MinutX:  Integer;
  SecondX: Integer;
begin
  DaysX   := DaysBetween(Now,VarToDateTime(DateX));
  HourX   := HoursBetween(Now,VarToDateTime(DateX));
  HourX   := HourX - (DaysX * 24);
  MinutX  := MinutesBetween(Now,VarToDateTime(DateX));
  MinutX  := MinutX - (HoursBetween(Now,VarToDateTime(DateX)) * 60) + 1;
  SecondX := SecondsBetween(Now,VarToDateTime(DateX));
  SecondX := SecondX - (MinutesBetween(Now,VarToDateTime(DateX)) * 60) + 1;
  case ResType of
    tbdTypeDay:  Result := DaysX;
    tbdTypeHour: Result := HourX;
    tbdTypeMinute: Result := MinutX;
    tbdTypeSecond: Result := SecondX;
  end;
end;

end.

Первая процедура определяющая информацию о дате была именно GetDateInfo. С неё все начиналось. Именно она много раз переписывалась и долго отлаживалась на заре моих первых опытов программинга. В данный момент она совершенно рабочая, но тем не менее если кто-то заменит не рациональности или "баги" очень надеюсь что вы сообщите мне об этом. Так же буду рад увидеть более оптимальное решение задач которые решаются данной процедурой.
Функции: GetAgeOf, GetDaysCountOf, GetJubiOf были добавлены уже позднее в данном модуле, специально для уменьшения количества лишнего и повторяющегося кода в приложениях.

Ну и как понятно из комментариев в коде и названий функций,
GetAgeOf - возвращает возраст человека, чей день рождения в формате TDateTime, будет передан в функцию в качестве параметра.
GetDaysCountOf - в качестве результата выдает количество дней оставшихся до дня рождения. Дата рождения так же передается в качестве параметра.
GetJubiOf - может сказать, будет в этом году просто День Рождения либо будет Юбилей. Если Юбилей значит возвращаемое значение равно 1, в противном случае 0.

Далее в модуле можно увидеть функцию возвращающую знак зодиака. Ничего хитрого в ней нет. А написал я её и воспользовался ею так как являюсь старым "вентилятором" интернет-пейджера ICQ. И глядя на Аську я решил в своей той программке реализовать похожую фичу, определять по дате и выводить на экран знак зодиака человека, который записан в базе.

Ну и наконец последняя функция, идея не нова. Множество сайтов видел на которых шёл отсчет времени то до запуска БАКа (Большого Адронного Коллайдера), то до конца света... Ну, а мне как-то раз захотелось подсчитать сколько времени у меня осталось до поездки в город Костанай. Так и написал функцию TimeBeforeDate, которая возвращает, сколько дней, часов, минут и секунд осталось до указанной даты. Работает тоже довольно просто. У кого есть не растраченный энтузиазм, может немного дописать функцию что бы она подсчитывала так же и недели, месяцы, годы, веки =)

Повторюсь, если кто-то найдет в этих функциях "косяк"/"баг", либо захочет оптимизировать работу, либо более подробно распросить как это все работает, пишите, буду рад диалогу.

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

////////////////////////////////////////////////////////////////////////////////
//
//  ФУНКЦИЯ: NumericalWords
//
//  НАЗНАЧЕНИЕ: В зависимости от числа возвращает слово в правильном падеже.
//
//  ПАРАМЕТРЫ:
//    Word1 - Слово в Именительном падеже.
//    Word2 - Слово в Родительном падеже.
//    Word3 - Слово во множественом числе и Именительном падеже.
//    Num - Число по которому будет определен правильный падеж и число.
//
Function NumericalWords(Word1,Word2,Word3:String;Num:integer): String;
Var
  NumStr: String[32];
  LenStr,TestNum: Integer;
begin
  case Num of
          1: NumericalWords := Word1;
       2..4: NumericalWords := Word2;
    5..20,0: NumericalWords := Word3;
  else
    begin
      NumStr := IntToStr(Num);
      LenStr := Length(NumStr);
      if LenStr > 1 then
        Try
          TestNum := StrToInt(NumStr[LenStr-1]);
        Except
        End;
      if TestNum > 1 then
        Try
          Delete(NumStr,1,LenStr-1);
        Except
        End
      else
        Try
          Delete(NumStr,1,LenStr-2);
        Except
        End;
      Num := StrToInt(NumStr);
      case Num of
              1: NumericalWords :=  Word1;
           2..4: NumericalWords :=  Word2;
        5..20,0: NumericalWords :=  Word3;
      end;
    end;
  end;
end;

Всем известно что некрасиво будет написать "4 день" или "1 дней". То есть чисто с технической точки зрения это понятная форма представления информации. Но всегда и во всем должна присутствовать красота, рациональность. И вот как раз для того что бы выводимые пользователю строки не выводились как в выше описанных примерах, можно воспользоваться функцией NumericalWords. Думаю если погуглить в интернете найдется множество вариантов написания такой функции, но я предлагаю свой, возможно и не самый рациональный метод решения задачи.

А теперь на засыпку приведу пример, как это все можно использовать. Допустим у Вас есть таблица с данными. В таблице забиты фамилии, даты рождения. А помимо этого нужно расчитать сколько лет, юбилей ни юбилей и сколько дней до Дня Рождения осталось. В таком случае у нужного TDataSet создадим 3 вычисляемых поля. А в событии OnCalcFields напишем примерно следующий код:

procedure TdmMainData.dstSubjectCalcFields(DataSet: TDataSet);
Var
  Age: Integer;
  DaysCount: Integer;
  SignI: Integer;
  Juby: Integer;
  SingnStrM: array [0..12] of String;
begin
  SingnStrM[0] := '';
  SingnStrM[1] := 'Овен';
  SingnStrM[2] := 'Телец';
  SingnStrM[3] := 'Близнецы';
  SingnStrM[4] := 'Рак';
  SingnStrM[5] := 'Лев';
  SingnStrM[6] := 'Дева';
  SingnStrM[7] := 'Весы';
  SingnStrM[8] := 'Скорпион';
  SingnStrM[9] := 'Стрелец';
  SingnStrM[10] := 'Козерог';
  SingnStrM[11] := 'Водолей';
  SingnStrM[12] := 'Рыбы';

  if dstSubjectDate1.Value <> 0 then
    begin
      Age := GetAgeOf(dstSubjectDate1.Value);
      DaysCount := GetDaysCountOf(dstSubjectDate1.Value);
      SignI := GetZadiak(dstSubjectDate1.Value);
      dstSubjectclAge.Value := IntToStr(Age) + NumericalWords(' год',' года',' лет',Age);
      dstSubjectclBeforeHB.Value := IntToStr(DaysCount) + NumericalWords(' день',' дня',' дней',DaysCount);
      dstSubjectclSign.Value := SingnStrM[SignI];
    end
  else
    begin
      dstSubjectclAge.Value := '';
      dstSubjectclBeforeHB.Value := '';
      dstSubjectclSign.Value := '';
    end;

  Juby := GetJubiOf(dstSubjectDate1.Value);

  // Отобразим иконки в гриде. Соответсвенно юбилею, просто ДР или ничего..
  If (DaysCount <= 3) and (Juby = 0) then
    dstSubjectclIcon.Value := 1
  else if (DaysCount <= 3) and (Juby = 1) then
    dstSubjectclIcon.Value := 2
  else
    dstSubjectclIcon.Value := 0;
end;

В данном примере так же показано что помимо прочего в гриде можно добавить колонку в которой в зависимости от близости празднества будет отображаться соответствующая иконка. Например красный надувной шарик, как в той же Аське.

По хорошему, конечно, то что описано выше - делать НЕЛЬЗЯ! Почему спросите Вы? Да потому что, вам может быть и не понадобиться все выведенные данные. А если в базе записей более тысячи? Компьютеру придется попыхтеть. Пользователь конечно можно быть и не заметит колоссальной работы машины. Особенно учитывая современные мощности. Тем не менее подход является не оптимальным, и в идеале такого рода задачу нужно переносить на СУБД. Что в принципе я думаю реально. И намериваюсь заняться этой задачей в свободное время. Ну а пока, рекомендую выше изложенный материал использовать более гуманно по отношению к вашему ЦП. Например, под Гридом с данными можно "нарисовать" поля, и при переходе на новую запись в базе, проводить подсчеты и выводить данные в эти поля (лэйблы). В результате у Вас должно получиться что-то вроде этого:

Но это лишь один вариант, а их очень много, так что включаем фантазию и творим.

Думаю это пока все. В завершение с позволения сказать статьи, скажу так: пишите код, оптимизируйте, найдя баги печатайте его и скомкав лист бумаги бросайте его в камин.
Не все то оптимально, что складно написано, не все то рационально что легко получается. Все гениальное - просто...

В общем если у вас есть интересные мысли, замечания или идеи на данную тему, пишите, буду рад.