SSL Vorlage.PAS Sprache: Delphi

{-----------------------------------------------------------------}
{- Program Header                                                 -}
{------------------------------------------------------------------}
program Vorlage;

{$R ANSAGE.RES}

Uses
    WinDOS, WinProcs, WinTypes, WObjects, Strings;

{------------------------------------------------------------------}
{-  Number of Days in Advance                                     -}
{------------------------------------------------------------------}

Const
   Alert     = 2;  { Days before and after event }
   Version   = '1.7';
   Dateof    = ' Mai 1994';
   cm_New    = 101;
   cm_Change = 102;
   cm_Delete = 103;
   cm_End    = 104;
   cm_Help   = 201;
   cm_About  = 202;
   id_BN1    = 301;

{------------------------------------------------------------------}
{- Type Declarations                                              -}
{------------------------------------------------------------------}
Type

   Sounds    = (SongofJoy,Bourree,RadioHamburg,Alarm,HappyBirthDay,
               Sailing, Ding, DingDong);
   Char2     = array[1..2] of char;
   Char4     = array[1..4] of char;
   Char32    = array[1 ..32] of char;
   Char36    = array[1..36] of char;
   Date      = Record
     Minute : 0 .. 59;
     Hour   : 0 .. 23;
     Day    : 1 .. 31;
     WeekDay: 0 .. 6;
     Month  : 1 .. 12;
     Year   : 1200 .. 2200
   end;

   Appoint = Record
      Month : Char2;
      Fill1 : char;
      Day   : Char2;
      Fill2 : char;
      Year  : Char4;
      Fill3 : char;
      Typ   : Char32;
      Fill4 : char;
      Who   : Char36
   end;

   PTestDialog = ^TTestDialog;
   TTestDialog = object(TDialog)
    { procedure IDBN1(var Msg: TMessage); virtual id_First + id_BN1; }
   end;

   TMyApplication = object(TApplication)
    procedure InitMainWindow; virtual;
   end;

   PMyWindow = ^TMainForm;
   TMainForm = object(TWindow)

    Just_Started   : boolean;
    EventFound     : boolean;
    WinEvent       : boolean;
    Texts          : Text;
    Events         : Text;
    ThisTime       : Date;
    Greeting       : string[20];
    Months         : array [1 .. 12] of string[10];
    Days           : array [0 .. 6] of string[10];

    Blank2         : Char2;
    Blank4         : Char4;
    Blank32        : Char32;
    Blank36        : Char36;

    constructor Init(AParent: PWindowsObject; ATitle: PChar);
    destructor Done; virtual;
    function CanClose: Boolean; virtual;
    procedure WMLButtonDown(var Msg: TMessage);
      virtual wm_First + wm_LButtonDown;
    procedure WMLButtonUp(var Msg: TMessage);
      virtual wm_First + wm_LButtonUp;
    procedure WMMouseMove(var Msg: TMessage);
      virtual wm_First + wm_MouseMove;
    procedure WMRButtonDown(var Msg: TMessage);
      virtual wm_First + wm_RButtonDown;

    Procedure Current(var Setting : Date);virtual;
    Procedure Sounder(i : Sounds);virtual;
    Function DayofYear(AnyTime:Date) : integer;virtual;
    Procedure Convert(A : Appoint;var b : Date);virtual;
    function ShortWho(Who:Char36) : string;virtual;
    function ShortTyp(Typ:Char32) : string;virtual;
    Function Inspect(s:string) : boolean;virtual;
    Procedure Event(Who :Char36;Typ:Char32;
                Month:Char2;Day:Char2;Year:Char4;
                Diff : integer);virtual;
    Procedure Appointment;virtual;
    procedure Greetings;virtual;
    procedure TextWindow;virtual;

    procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;

    procedure FileNew(var Msg: TMessage);
      virtual cm_First + cm_New;
    procedure FileChange(var Msg: TMessage);
      virtual cm_First + cm_Change;
    procedure FileDelete(var Msg: TMessage);
      virtual cm_First + cm_Delete;
    procedure FileEnd(var Msg: TMessage);
      virtual cm_First + cm_End;
    procedure FileHelp(var Msg: TMessage);
      virtual cm_First + cm_Help;
    procedure About(var Msg: TMessage);
      virtual cm_First + cm_About;
   end;


{------------------------------------------------------------------}
{-   Procedure Current Time                                       -}
{-   for to fetch system time                                     -}
{------------------------------------------------------------------}
Procedure TMainForm.Current(var Setting : Date);
var
   H,M,S,C : word;
   Y,Mo,D,W : word;
begin
   GetTime(H,M,S,C);
   GetDate(Y,Mo,D,W);
   With Setting do
   begin
      Minute   := M;
      Hour     := H;
      Day      := D;
      WeekDay  := W;
      Month    := Mo;
      Year     := Y
   end;
end; {Current}

{------------------------------------------------------------------}
{              Procedure Sounder                                   }
{           for to sound a result or so                            }
{------------------------------------------------------------------}
Procedure TMainForm.Sounder(i : Sounds);
const
   c000 = 32.70;
   c00  = 65.41;
   c0   = 130.81;
   c    = 261.63;
   cis  = 277.18;
   d    = 293.67;
   es   = 311.13;
   e    = 329.63;
   f    = 349.23;
   fis  = 369.99;
   g    = 392.0;
   as   = 415.31;
   gis  = as;
   a    = 440.0;
   b    = 466.16;
   h    = 493.88;
   c1   = 261.63;
   c2   = 523.25;
   c3   = 1046.51;
   c4   = 2093.02;
   c5   = 4186.03;

   full  = 512;
   half  = 256;
   Quart = 128;
   eigth = 64;
var
   Hz       : real;
   j        : integer;
   BaseTone : integer;
   Offset   : integer;
   Tempo    : real;
   Voices   : integer;

procedure Tone(f : real;d : integer);
var
frequency : longint;

begin
frequency := trunc(f* 65536);
SetVoiceSound(1,frequency,trunc(d*Tempo))
end; {Tone}

procedure Pause(d : integer;Tempo : real);
var
frequency : longint;

begin
   if NOT Winevent then
   begin
      frequency := 65536;
      SetVoiceSound(1,frequency,trunc(d*Tempo))
   end
end; {Pause}

begin
  Voices := OpenSound;
  SetVoiceQueueSize(1,1024);
  SetVoiceAccent(1,180,200,s_Staccato,83);
  SetVoiceEnvelope(1,5,2);
  case i of
    HappyBirthDay :
        begin
           Tempo := 1;
           Tone(g,quart+eigth);
           Tone(g,eigth);
           Tone(a,half);
           Tone(g,half);
           Tone(c2,half);
           Tone(h,full);
           Tone(g,quart+eigth);
           Tone(g,eigth);
           Tone(a,half);
           Tone(g,half);
           Tone(2*d,half);
           Tone(c2,full);
           Tone(g,quart+eigth);
           Tone(g,eigth);
           Tone(g*2,half);
           Tone(e*2,half);
           Tone(c2,quart);
           Tone(c2,quart);
           Tone(c2,half);
           Tone(a,half);
           Tone(f*2,quart+eigth);
           Tone(f*2,eigth);
           Tone(e*2,half);
           Tone(c2,half);
           Tone(d*2,half);
           Tone(c2,full);
        end;
    SongofJoy :
        begin
           Tempo := 4.0 / 3.0;
           Tone(e,quart);
           Tone(e,quart);
           Tone(f,quart);
           Tone(g,quart);
           Tone(g,quart);
           Tone(f,quart);
           Tone(e,quart);
           Tone(d,quart);
           Tone(c,quart);
           Tone(c,quart);
           Tone(d,quart);
           Tone(e,quart);
           Tone(e,quart+eigth);
           Tone(d,eigth);
           Tone(d,half+quart);

           Tone(e,quart);
           Tone(e,quart);
           Tone(f,quart);
           Tone(g,quart);
           Tone(g,quart);
           Tone(f,quart);
           Tone(e,quart);
           Tone(d,quart);
           Tone(c,quart);
           Tone(c,quart);
           Tone(d,quart);
           Tone(e,quart);
           Tone(d,quart+eigth);
           Tone(c,eigth);
           Tone(c,half+quart);

           Tone(d,quart);
           Tone(d,quart);
           Tone(e,quart);
           Tone(c,quart);
           Tone(d,quart);
           Tone(e,eigth);
           Tone(f,eigth);
           Tone(e,quart);
           Tone(c,quart);
           Tone(d,quart);
           Tone(e,eigth);
           Tone(f,eigth);
           Tone(e,quart);
           Tone(d,quart);
           Tone(c,quart);
           Tone(d,quart);
           Tone(g/2,half);

           Tone(e,half);
           Tone(f,quart);
           Tone(g,quart);
           Tone(g,quart);
           Tone(f,quart);
           Tone(e,quart);
           Tone(d,quart);
           Tone(c,quart);
           Tone(c,quart);
           Tone(d,quart);
           Tone(e,quart);
           Tone(d,quart+eigth);
           Tone(c,eigth);
           Tone(c,half+quart);
        end;
    Bourree :
        begin
           Tempo := 1.0;
           Tone(a,quart);
           Tone(h,quart);
           Tone(2*c,quart+eigth);
           Tone(h,eigth);
           Tone(a,quart+eigth);
           Tone(gis,quart+eigth);
           Tone(a,eigth);
           Tone(h,quart+eigth);
           Tone(e,quart+eigth);
           Tone(fis,eigth);
           Tone(gis,quart+eigth);
           Tone(a,quart+eigth);
           Pause(quart,Tempo);

           Tone(g,quart);
           Tone(f,quart);
           Tone(e,quart+eigth);
           Tone(d,eigth);
           Tone(c,quart+eigth);
           Tone(h/2,quart+eigth);
           Tone(c,eigth);
           Tone(d,quart+eigth);
           Tone(e,quart+eigth);
           Tone(d,quart);
           Tone(c,quart);
           Tone(h/2,quart);
           Tone(a/2,half);
           Pause(quart,Tempo)
        end;
   RadioHamburg :
       begin
          Tempo := 1.0;
          Tone(f,quart);
          Tone(d,quart);
          Tone(g,quart);
          Tone(e,half);
          Tone(c,quart);
          Pause(half,Tempo);
       end;
   Sailing :
       begin
          Tempo := 4.0 / 3.0;
          Tone(e,quart);
          Tone(g,quart);
          Tone(a,half);
          Tone(a,quart);
          Pause(quart,Tempo);

          Tone(h,quart);
          Tone(d*2,quart);
          Tone(e*2,half);
          Tone(e*2,quart);
          Pause(quart,Tempo);

          Tone(e*2,quart+eigth);
          Tone(d*2,eigth);
          Tone(d*2,half);
          Tone(c*2,quart+eigth);
          Pause(eigth,Tempo);

          Tone(c*2,quart+eigth);
          Tone(h,eigth);
          Tone(h,half);
          Pause(eigth,Tempo);

          Tone(c*2,quart);
          Tone(h,quart);
          Tone(a,half);
          Tone(a,quart+eigth);
          Pause(eigth,Tempo);

          Tone(h,quart);
          Tone(a,quart);
          Tone(g,half);
          Tone(g,quart+eigth);
          Pause(eigth,Tempo);

          Tone(e,quart);
          Tone(e,quart);
          Tone(h,half);
          Tone(a,quart+eigth);
          Pause(eigth,Tempo);

          Tone(a,quart);
          Tone(g,quart);
          Tone(g,half);
          Pause(quart,Tempo)
        end;
   Ding :
        begin
          Tempo := 1.5;
          Tone(e,eigth);
          Tone(e,eigth)
        end;
   DingDong :
        begin
          Tempo := 1.5;
          Tone(e,eigth);
          Tone(e,eigth);
          Tone(c,eigth);
          Tone(c,eigth)
        end;
   Alarm :
        begin
          BaseTone := 880;
          Offset   := 440;
          for j := 1 to 200 do
          begin
             Hz := BaseTone + sin(j*2*3.1415/300)*Offset;
             SetVoiceSound(1,trunc(Hz),10+j div 4)
          end;
        end;
   end;
If Not Winevent then
   StartSound
end; {Sounder}

{------------------------------------------------------------------}
{-  Procedure DayofYear                                           -}
{-  for to find the number of a Day                               -}
{------------------------------------------------------------------}
Function TMainForm.DayofYear(AnyTime:Date) : integer;
Var
   Sum : 0 .. 366;
begin
   Sum := 0;
   if AnyTime.Month > 1 then
      Sum := Sum + 31;
   if AnyTime.Month > 2 then
   begin
      Sum := Sum + 28;
      if AnyTime.Year mod 4 = 0 then
         Sum := Sum + 1;
      if AnyTime.Year mod 100 = 0 then
         Sum := Sum - 1;
   end;
   if AnyTime.Month > 3 then
      Sum := Sum + 31;
   if AnyTime.Month > 4 then
      Sum := Sum + 30;
   if AnyTime.Month > 5 then
      Sum := Sum + 31;
   if AnyTime.Month > 6 then
      Sum := Sum + 30;
   if AnyTime.Month > 7 then
      Sum := Sum + 31;
   if AnyTime.Month > 8 then
      Sum := Sum + 31;
   if AnyTime.Month > 9 then
      Sum := Sum + 30;
   if AnyTime.Month > 10 then
      Sum := Sum + 31;
   if AnyTime.Month > 11 then
      Sum := Sum + 30;
   Sum := Sum + AnyTime.Day;
   DayofYear := Sum
end;{DayofYear}

{------------------------------------------------------------------}
{-   Procedure Convert                                            -}
{-   for to Convert the input record                              -}
{------------------------------------------------------------------}
Procedure TMainForm.Convert(A : Appoint;var b : Date);
var i : integer;
begin
   b := ThisTime;
   if (a.Month[1]  in ['0','1'])
   and (a.Month[2] in ['0' .. '9'])
   and (a.Day[1]   in ['0' .. '3'])
   and (a.Day[2]   in ['0' .. '9'])
   and (a.Year[1]  in [' ','0','1','2'])
   and (a.Year[2]  in [' ','0' .. '9'])
   and (a.Year[3]  in [' ','0' .. '9'])
   and (a.Year[4]  in [' ','0' .. '9']) then
   begin
      i:= (ord(A.Month[1])-ord('0'))*10+ord(a.Month[2])-ord('0');
      b.Month := i;
      i:= (ord(A.Day[1])-ord('0'))*10+ord(a.Day[2])-ord('0');
      b.Day := i;
      i := (ord(a.Year[1]) - ord('0'))*1000
          +(ord(a.Year[2]) - ord('0'))*100
          +(ord(a.Year[3]) - ord('0'))*10
          +(ord(a.Year[4]) - ord('0'));
      b.Year := i
   end
   else
   begin
      b.Month := ThisTime.Month - 1;
      b.Day   := ThisTime.Day
   end;
end;{Convert}

{------------------------------------------------------------------}
{-   Procedure ShortWho                                           -}
{-   for to produce output without blanks                         -}
{------------------------------------------------------------------}
function TMainForm.ShortWho(Who:Char36) : string;
var i,Lasti : integer;
    Last : boolean;
    Result : String[36];
begin
   Last := false;
   Lasti:= 36;
   for i:= 36 downto 1 do
      if (Who[i] <> ' ') and not Last then
      begin
         Last := true;
         Lasti := i;
      end;
   Result := '';
   for i:= 1 to Lasti do
      Result := Result + Who[i];
   ShortWho := Result;
end;{ShortWho}

{------------------------------------------------------------------}
{-   Procedure ShortTyp                                           -}
{-   for to produce output without blanks                         -}
{------------------------------------------------------------------}
function TMainForm.ShortTyp(Typ:Char32) : string;
var i,Lasti : integer;
    Last : boolean;
    Result : String[32];
begin
   Last := false;
   Lasti:= 32;
   for i:= 32 downto 1 do
      if (Typ[i] <> ' ') and not Last then
      begin
         Last := true;
         Lasti := i;
      end;
   Result := '';
   for i:= 1 to Lasti do
      Result := Result + Typ[i];
   ShortTyp := Result;
end;{ShortTyp}

{------------------------------------------------------------------}
{-   Procedure Inspect                                            -}
{-   for to search for 'UND'                                      -}
{------------------------------------------------------------------}
Function TMainForm.Inspect(s:string) : boolean;
var i : integer;
begin
   Inspect := false;
   for i:= 1 to 34 do
   if UpCase(s[i]) = ' ' then
      if UpCase(S[i+1]) = 'U' then
         if UpCase(s[i+2]) = 'N' then
            if UpCase(s[i+3]) = 'D' then
               if UpCase(s[i+4]) = ' ' then
                  Inspect := true;
end;{Inspect}

{------------------------------------------------------------------}
{-   Procedure Event                                              -}
{-   for to announce Events                                       -}
{------------------------------------------------------------------}
Procedure TMainForm.Event(Who :Char36;Typ:Char32;
                Month:Char2;Day:Char2;Year:Char4;
                Diff : integer);
Var
   Plural   : boolean;
   YearNum  : integer;
begin
   EventFound := true;
   write(Texts,ShortWho(Who));
   Plural := false;
   Plural := Inspect(ShortWho(Who));
   if Diff > 0 then
   begin
      if Diff = 1 then
         begin
           if Plural then
             write(Texts,' haben morgen ')
           else
             write(Texts,' hat morgen ');
           Sounder(DingDong)
         end
      else
         begin
           if Plural then
              write(Texts,' haben in ',Diff:2,' Tagen ')
           else
              write(Texts,' hat in ',Diff:2,' Tagen ');
           Sounder(Ding)
         end;
      writeln(Texts,ShortTyp(Typ),'.')
   end;
   if Diff = 0 then
   begin
      if Plural then
         write(Texts,' haben heute ')
      else
         write(Texts,' hat heute ');
      YearNum := (ord(Year[1])-ord('0'))*1000
                +(ord(Year[2])-ord('0'))*100
                +(ord(Year[3])-ord('0'))*10
                +(ord(Year[4])-ord('0'));
      YearNum := ThisTime.Year - YearNum;
      if (Year = '0000') or (Year = ' ') or (YearNum = 0) then
         writeln(Texts,ShortTyp(Typ),'.')
      else if YearNum = 1 then
         writeln(Texts,'ersten ',ShortTyp(Typ),'.')
      else if YearNum = 3 then
         writeln(Texts,'dritten ',ShortTyp(Typ),'.')
      else
         begin
            if (YearNum mod 100) > 20 then
               writeln(Texts,YearNum,'sten ',ShortTyp(Typ),'.')
            else
               writeln(Texts,YearNum,'ten ',ShortTyp(Typ),'.')
         end;
      if ShortTyp(Typ) = 'Geburtstag' then
         Sounder(HappyBirthday)
      else
         Sounder(SongofJoy);
   end;
   if Diff < 0 then
   begin
      if abs(Diff) = 1 then
         if Plural then
            write(Texts,' hatten gestern ')
         else
            write(Texts,' hatte gestern ')
      else
         if Plural then
            write(Texts,' hatten vor ',abs(Diff):2,' Tagen ')
         else
            write(Texts,' hatte vor ',abs(Diff):2,' Tagen ');
      writeln(Texts,ShortTyp(Typ),'.')
   end;
   writeln(Texts);
end;{Event}

{------------------------------------------------------------------}
{-   Procedure Appointment                                        -}
{-   for to look up Appointments                                  -}
{------------------------------------------------------------------}
Procedure TMainForm.Appointment;
Type
   TRecord = record
               case boolean of
                  true : (a : string[80]);
                  false: (c: record
                          c1 : char;
                          b  : Appoint
                          end);
               end;
Var
   Trec   : TRecord;
   i,Diff : integer;
   Goal   : Date;
   YearDays : integer;
begin
   ASSIGN(Events,'EREIGNIS.DAT');
   {$I-}Reset(Events);{$I+}
   if IOResult = 0 then
   begin
      TRec.c.b.Month := Blank2;
      TRec.c.b.Day   := Blank2;
      TRec.c.b.Year  := Blank4;
      TREc.c.b.Typ   := Blank32;
      TRec.c.b.Who   := Blank36;
      while not EOF(Events) do
      begin
         Readln(Events,TRec.a);
         Convert(TRec.c.b,Goal);
         Goal.Year := ThisTime.Year;
  YearDays := 365;
         if (ThisTime.Year mod 4 = 0)
         and not (ThisTime.Year mod 100 = 0) then
            YearDays := 366;
         Diff := DayofYear(Goal)-DayofYear(ThisTime);
         if abs(Diff) > YearDays-Alert-1 then
            Diff := Diff + YearDays;
         if abs(Diff) <= Alert then
            Event(TRec.c.b.Who,TRec.c.b.Typ,
                  TREc.c.b.Month,TREc.c.b.Day,
                  TRec.c.b.Year,Diff);
         TRec.c.b.Month := Blank2;
         TRec.c.b.Day   := Blank2;
         TRec.c.b.Year  := Blank4;
         TREc.c.b.Typ   := Blank32;
         TRec.c.b.Who   := Blank36;
      end;
      Close(Events)
   end;
   Close(Texts);
end;{Appointment}

{------------------------------------------------------------------}
{- procedure Greetings                                            -}
{- for to produce greetings                                       -}
{------------------------------------------------------------------}
procedure TMainForm.Greetings;
begin
With ThisTime do
begin
    if Hour < 12 then
       Greeting := 'Guten Morgen'
    else if Hour < 18 then
       Greeting := 'Guten Tag'
    else
       Greeting := 'Guten Abend';
    Assign(Texts,'Ansage.txt');
    Rewrite(Texts);
    write  (Texts,Greeting,', heute ist ',Days[WeekDay],
                  ', der ');
    if Day = 1 then
       write(texts,'erste ')
    else if Day = 3 then
       write(texts,'dritte ')
    else
       write(Texts,Day,'te ');
    writeln(Texts,Months[Month],' ',Year,'.');
    write(Texts,'Es ist jetzt ');
    if Hour = 1 then
      write(Texts,'ein')
    else
      write(Texts,Hour);
    write(Texts,' Uhr ');
    if Minute <> 0 then
       writeln(Texts,Minute,'.')
    else
       writeln(Texts,'.');
end;
writeln(Texts)
end; {Greetings}

{------------------------------------------------------------------}
{- TextWindow                                                     -}
{------------------------------------------------------------------}
procedure TMainForm.TextWindow;
var
   Lines : array[0..132] of char;
   DC    : HDC;
   i     : integer;

begin
   {$I-} Reset(Texts);{$I+}
   DC := GetDC(HWindow);
   i := 1;
   StrCopy(Lines,' ');
   Textout(DC,1,i,Lines,StrLen(Lines));
   While not Eof(Texts) do
   begin
      readln(Texts,Lines);
      i := i + 24;
      Textout(DC,1,i,Lines,StrLen(Lines));
   end;
   Close(Texts);
   ReleaseDC(HWindow,DC)
end;{TexttoWindow}

{------------}
{ TTestDialog }
{-------------}
{procedure TTestDialog.IDBN1(var Msg: TMessage);
var
  TextItem : PChar;
begin
  TextItem := 'Item 1';
end;}

{--------------------------------------------------}
{ TMainForm's method implementations: }
{--------------------------------------------------}

constructor TMainForm.Init(AParent: PWindowsObject; ATitle: PChar);
var i : integer;
    s : string;
begin
   TWindow.Init(AParent, ATitle);
   Attr.Menu := LoadMenu(HInstance, 'GEBURTSTAG');
   EventFound := False;
   WinEvent := false;
   i := ParamCount;
   if i > 0 then
   begin
      s := ParamStr(1);
      for i := 1 to 20 do
         s[i] := UpCase(S[i]);
      if ParamCount > 0 then
      begin
        MessageBox(HWindow, 'Feature not implemented',
                   'Parameter', mb_Ok);Halt;
      end;
   end;
   Months[1] := 'Januar';
   Months[2] := 'Februar';
   Months[3] := 'März';
   Months[4] := 'April';
   Months[5] := 'Mai';
   Months[6] := 'Juni';
   Months[7] := 'Juli';
   Months[8] := 'August';
   Months[9] := 'September';
   Months[10] := 'Oktober';
   Months[11] := 'November';
   Months[12] := 'Dezember';
   Days[1] := 'Montag';
   Days[2] := 'Dienstag';
   Days[3] := 'Mittwoch';
   Days[4] := 'Donnerstag';
   Days[5] := 'Freitag';
   Days[6] := 'Sonnabend';
   Days[0] := 'Sonntag';
   for i:= 1 to 2 do
      Blank2[i] := ' ';
   for i:= 1 to 4 do
      Blank4[i] := ' ';
   for i:= 1 to 32 do
      Blank32[i] := ' ';
   for i:= 1 to 36 do
      Blank36[i] := ' ';
   Current(ThisTime);
   if (ThisTime.Month = 11) and (ThisTime.Day = 6) Then
      begin
         Sounder(RadioHamburg);
         Sounder(Bourree);
         Sounder(RadioHamburg);
      end
   else if (ThisTime.Month = 2) and (ThisTime.Day = 12) Then
      begin
         Sounder(RadioHamburg);
         Sounder(Sailing);
         Sounder(RadioHamburg);
      end
   else if (ThisTime.Month = 3) and (ThisTime.Day = 21) Then
         Sounder(Bourree)
   else if (ThisTime.Month = 12) and (ThisTime.Day = 16) Then
         Sounder(SongofJoy);
  Greetings;
  Appointment;
  Just_started := TRUE;
end;

destructor TMainForm.Done;
begin
  TWindow.Done;
end;

function TMainForm.CanClose: Boolean;
var
  Reply: Integer;
begin
  CanClose := False;
  If EventFound then
  begin
    Reply := MessageBox(HWindow, 'Wirklich beenden ?',
      'Es ist steht ein Ereignis an', mb_YesNo);
    if Reply = id_No then
      CanClose := False
    else
      CanClose := True;
  end
  else
    CanClose := True
end;

procedure TMainForm.WMLButtonDown(var Msg: TMessage);
begin
  MessageBox(HWindow, 'Wirklich beenden ?',
  'Mausklick', mb_YesNo);
  StopSound
end;

procedure TMainForm.WMMouseMove(var Msg: TMessage);
begin
StopSound
end;

procedure TMainForm.WMLButtonUp(var Msg: TMessage);
begin
  StopSound
end;

procedure TMainForm.WMRButtonDown(var Msg: TMessage);
begin
  StopSound
end;

procedure TMainForm.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
var
  First: Boolean;

begin
If not Just_Started then
begin
   Greetings;
   Appointment;
end
else
   Just_Started := FALSE;
TextWindow;
WaitSoundState(s_QueueEmpty);
StopSound;
CloseSound
end;

procedure Edit;
type
  path = array[0..144] of char;
var
  P,Q : path;
  Buffer : PChar;
  Editor : PChar;
begin
  Buffer := @P;
  Editor := @Q;
  StrCopy(Editor, '');
  GetCurDir(Buffer,0);
  StrCopy(Editor, 'notepad.exe ');
  StrCat(Editor,Buffer);
  StrCat(Editor,'\');
  StrCopy(Buffer, 'ereignis.dat');
  StrCat(Editor,Buffer);
  WinExec(Editor, sw_Normal)
end;

procedure TMainForm.FileNew(var Msg: TMessage);
begin
Edit;
end;

procedure TMainForm.FileChange(var Msg: TMessage);
begin
  Edit;
end;

procedure TMainForm.FileDelete(var Msg: TMessage);
begin
  Edit;
end;

procedure TMainForm.FileEnd(var Msg: TMessage);
begin
  if CanClose then
    Done
end;

procedure TMainForm.FileHelp(var Msg: TMessage);
var
  HelpWnd : PWindow;
begin
  HelpWnd := New(PWindow,Init(@Self,'Help System'));
  With HelpWnd^.Attr do
  begin
    Style := Style or ws_PopupWindow or ws_Caption;
    X := 100;
    Y := 100;
    W := 300;
    H := 300
  end;
  Application^.MakeWindow(HelpWnd);
end;

{------------------------------------------------------------------}
{-  procedure Help                                                -}
{------------------------------------------------------------------}
procedure TMainForm.About(var Msg: TMessage);
begin
  Application^.ExecDialog(New(PTestDialog, Init(@Self, 'ABOUT')));
end;{Help}

{--------------------------------------------------}
{ TMyApplication's method implementations: }
{--------------------------------------------------}

procedure TMyApplication.InitMainWindow;
begin
  MainWindow := New(PMyWindow, Init(nil, 'Geburtstagsprogramm '+Version));
end;

{--------------------------------------------------}
{ Main program:                                    }
{--------------------------------------------------}

var
  MyApp : TMyApplication;

begin
  MyApp.Init('MyProgram');
  MyApp.Run;
  MyApp.Done;
end.
{------------------------------------------------------------------}
{- End of program m                                               -}
{------------------------------------------------------------------}

quality92%

¤ Dauer der Verarbeitung: 0.49 Sekunden (vorverarbeitet) ¤

Wurzel

Suchen

Beweissystem der NASA

Beweissystem Isabelle

NIST Cobol Testsuite

Cephes Mathematical Library

Wiener Entwicklungsmethode

Haftungshinweis

Die Informationen auf dieser Webseite wurden nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit, noch Qualität der bereit gestellten Informationen zugesichert.

Bemerkung:

Die farbliche Syntaxdarstellung ist noch experimentell.