unit u_main;
Interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, ExtCtrls;
type
TBioType = (btPhys, btPsy, btInt);
type
TfrmMain = class(TForm)
Bevel1: TBevel;
Bevel2: TBevel;
DBirth: TDateTimePicker;
lblBDay: TLabel;
lblCDay: TLabel;
Bevel3: TBevel;
btnQuit: TButton;
Bevel4: TBevel;
clbPhy: TColorBox;
clbPsy: TColorBox;
clbInt: TColorBox;
lbColorSelect: TLabel;
lblColorPhy: TLabel;
lblColorPsy: TLabel;
lblColorInt: TLabel;
pbImage: TImage;
btnSave: TButton;
svDialog: TSaveDialog;
Bevel5: TBevel;
lblName: TLabel;
edName: TEdit;
Bevel6: TBevel;
DCalc: TDateTimePicker;
procedure FormCreate(Sender: TObject);
procedure btnQuitClick(Sender: TObject);
procedure btnSaveClick(Sender: TObject);
procedure ChangeEvent(Sender: TObject);
private
{ Private declarations }
procedure pbImagePaint;
{Функция расчета значения биоритма}
function CalculatePoints(ForDate : TDateTime; BirthDay : TDateTime;
Bio : TBioType) : integer;
{Процедура рисования осей на графике с формированием подписей}
procedure DrawAxis(aBitmap : TBitmap; PixelStep : integer);
{Процедура рисования "Легенды" - что какой цвет на графике обозначает}
procedure DrawLegend(aBitmap : TBitmap);
{Процедура рисования синусоид биоритмов}
procedure DrawBioritm(aBitmap : TBitmap; PixelStep : integer);
{Процедура сохранения графика биоритмов во внешний файл}
procedure ExportPictureToFile;
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
implementation
uses DateUtils, Jpeg, Math;
{$R *.dfm}
procedure TfrmMain.FormCreate(Sender: TObject);
begin
{Для отображения графика при старте программы - получаем текущую дату и...}
DCalc.DateTime := Now;
{... рисуем сам график}
pbImagePaint;
end;
procedure TfrmMain.btnQuitClick(Sender: TObject);
begin
Application.Terminate;
end;
{*******************************************************************************
Процедура ExportPictureToFile
Назначение: Процедура "экспорта" графика во внешний файл
*******************************************************************************}
procedure TfrmMain.ExportPictureToFile;
begin
{Если пользователь ввел имя файла и нажал кнопку "Save"|"Сохранить"...}
If svDialog.Execute then
{... создаем объект типа JpegImage}
with TJpegImage.Create do begin
try
{... передаем ему картинку}
Assign(pbImage.Picture.Bitmap);
{... устанавливаем качество картинки в 100%}
CompressionQuality := 100;
{... сохраняем в файл}
SaveToFile(svDialog.FileName);
finally
{... объект типа TJpegImage нам больше не нужен - уничтожаем его}
Free;
end; {try}
end;{with}
end;
{*******************************************************************************
Функция CalculatePoints
Назначение: Расчет значения биоритма для определенной даты
Параметры:
1. ForDate - дата, для которой требуется расчитать значение биоритма
2. BirthDate - дата дня рождения
3. Bio - тип биоритма, который требуется расчитать
Результат:
Значение биоритма. Возможные значения в диапазоне от -100 до +100
Замечание: Если дата расчета меньше или равна дате рождения, функция возвра-
щает нулевое значение.
*******************************************************************************}
function TfrmMain.CalculatePoints(ForDate: TDateTime; BirthDay : TDateTime;
Bio: TBioType): integer;
var lDays :integer; {Количество полных прожитых дней}
a,b,c : real; {просто для упрощения восприятия основной формулы}
const PhysPeriod = 23.6884; {Период физического цикла}
PsyPeriod = 28.4261; {Период психологического цикла}
IntPeriod = 33.1638; {Период интеллектуального цикла}
begin
a := 2*Pi/PhysPeriod; {просто для упрощения восприятия основной формулы}
b := 2*Pi/PsyPeriod; {просто для упрощения восприятия основной формулы}
c := 2*Pi/IntPeriod; {просто для упрощения восприятия основной формулы}
result := 0;
{...считаем количество прожитых дней}
lDays := DaysBetween(forDate, BirthDay);
{...если дата расчета больше даты рождения, то...}
if (lDays > 0) and (ForDate - BirthDay > 0) then
{считаем }
case Bio of
btPhys : result := Round(100*sin(LDays*a));
btPsy : result := Round(100*sin(LDays*b));
btInt : result := Round(100*sin(LDays*c));
end; {case}
{...если нет, то результат у нас уже установлен в 0}
end;
{*******************************************************************************
Процедура DrawLegend
Назначение: Процедура отображения на графике биоритмов "легенды" - описание
значений цветов, используемых для построения синусоид.
Так же выводится дополнительная информация:
1. Имя
2. Дата рождения
3. Дата генерирования
Параметры:
aBitmap - "холст", на котором строим графики
*******************************************************************************}
procedure TfrmMain.DrawLegend(aBitmap : TBitmap);
var svBrushColor : TColor;
svFont : TFont;
NewPosX : integer;
grDay : string;
strText : string;
const
strPhy = 'Физический';
strPsy = 'Психологический';
strInt = 'Интеллектуальный';
begin
with aBitmap do begin
{Сохраняем значения для шрифта и цвета}
svBrushColor := Canvas.Brush.Color;
svFont := Canvas.Font;
{Рисуем легенду}
Canvas.Pen.Color := clBlack;
Canvas.Font.Size := 7;
{Пишем имя и дату расчета}
strText := format('Имя: %s', [edName.Text]);
Canvas.TextOut(2,1,format('Имя: %s', [edName.Text]));
grDay := format('Дата рождения: %s',[DateToStr(DBirth.DateTime)]);
Canvas.TextOut(2,1+Canvas.TextHeight(strText),grDay);
{... если дата рождения больше чем дата расчета,
то не считаем сколько прожито и не выводим на графике}
if DCalc.DateTime > DBirth.DateTime then
Canvas.TextOut(2 + Canvas.TextWidth(grDay)+10,
1+Canvas.TextHeight(strText),
format('Прожито %d дней на дату расчета.',
[DaysBetween(DCalc.DateTime, DBirth.DateTime)]));
strText := DateTimeToStr(Now);
Canvas.Font.Color := clSilver;
Canvas.TextOut(Width - 2 - Canvas.TextWidth(strText),1, strText);
Canvas.Font := svFont;
{...физическая}
{... устанавливаем выбранный цвет заполнения}
Canvas.Brush.Color := clbPhy.Selected;
{... устанавливаем цвет рамки - черным}
Canvas.Font.Color := clBlack;
{... рисуем пряморугольник с заполнением}
Canvas.Rectangle(5, Height - 10, 25, Height - 5);
{... восстанавливаем сохраненные значения заполнения}
Canvas.Brush.Color := svBrushColor;
{... печатаем над прямоугольником значение биоритма на день расчета (в%)}
strText := format('%d%%',
[CalculatePoints(DCalc.DateTime, DBirth.DateTime, btPhys)]);
Canvas.TextOut(5,Height - 10 - Canvas.TextHeight(strText), strText);
Canvas.TextOut(30, Height - 13, strPhy);
NewPosX := 30+Canvas.TextWidth(StrPhy)+10;
{...психологическая}
{... устанавливаем выбранный цвет заполнения}
Canvas.Brush.Color := clbPsy.Selected;
{... рисуем пряморугольник с заполнением}
Canvas.Rectangle(NewPosX, Height - 10, NewPosX + 20, Height - 5);
{... восстанавливаем сохраненные значения заполнения}
Canvas.Brush.Color := svBrushColor;
{... печатаем над прямоугольником значение биоритма на день расчета (в%)}
strText := format('%d%%',
[CalculatePoints(DCalc.DateTime, DBirth.DateTime, btPsy)]);
Canvas.TextOut(NewPosX,Height - 10 - Canvas.TextHeight(strText), strText);
Canvas.TextOut(NewPosX + 25, Height - 13, strPsy);
NewPosX := NewPosX + 25 + Canvas.TextWidth(strPsy) + 10;
{...интеллектуальная}
{... устанавливаем выбранный цвет заполнения}
Canvas.Brush.Color := clbInt.Selected;
{... рисуем пряморугольник с заполнением}
Canvas.Rectangle(NewPosX , Height - 10, NewPosX + 20, Height - 5);
{... восстанавливаем сохраненные значения заполнения}
Canvas.Brush.Color := svBrushColor;
{... печатаем над прямоугольником значение биоритма на день расчета (в%)}
strText := format('%d%%',
[CalculatePoints(DCalc.DateTime, DBirth.DateTime, btInt)]);
Canvas.TextOut(NewPosX,Height - 10 - Canvas.TextHeight(strText), strText);
Canvas.TextOut(NewPosX + 25, Height - 13, strInt);
{Восстанавливаем сохраненные значения шрифта и цвета}
Canvas.Font := svFont;
Canvas.Brush.Color := svBrushColor;
end; {with aBitmap}
end;
{*******************************************************************************
Процедура DrawBioritm
Назначение: Процедура рисования синусоид биоритмов
Параметры:
1. aBitmap - "холст", на котором строятся графики
2. PixelStep - расстояние между соседними днями по оси календаря.
Это значение так же используется для ообозначения процентного уровня.
*******************************************************************************}
procedure TfrmMain.DrawBioritm(aBitmap : TBitmap; PixelStep : integer);
var days_count : integer; {для обозначения интервала -/+ от даты расчета}
begin
with aBitmap do begin
{А теперь рисуем графики...}
{Физическая синусоида}
{...устанавливаем цвет в соответствии с выбранным}
Canvas.Pen.Color := clbPhy.Selected;
{...сколько дней брать до даты расчета}
days_count := -7;
{...устанавливаем начальную точку графика на значение биоритма в этот день}
Canvas.MoveTo(0,
(Height div 2) - CalculatePoints(DCalc.DateTime + days_count,
DBirth.DateTime,btPhys));
{...пока не нарисовали последнюю точку на графике}
while (Canvas.PenPos.X < Width) do begin
{...берем следующий день}