home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / delite / vin / vin.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-04-01  |  13.4 KB  |  423 lines
  1. PROGRAM vin;
  2.  
  3. (*****************************************************************************
  4. Name:              VIN
  5. Version:           1.0
  6. Edit Datum:        1. April 1992
  7. Autor:             Andreas Schumm
  8. Kurzbeschreibung:  Beispielprogramm WEIN
  9. *****************************************************************************)
  10.  
  11. USES  API, Kernel, Dialogs;
  12.  
  13. CONST ProjektName  = 'vin';
  14.       MaxFarben    = 3;
  15.  
  16.       Farben     : array[1..MaxFarben] of string[8] =
  17.       (( 'rot'),('rosé'),('weiß'));
  18.  
  19.       MuellIcon : Array[0..143] of Byte = (
  20.            0,   0,   0,   0,
  21.            0,   0,   0,   0,
  22.            0,   0,   0,   0,
  23.            0,  15, 192,   0,
  24.            0,  16,  32,   0,
  25.            7, 240,  63, 128,
  26.            8,   0,   0,  64,
  27.            15, 255,255, 192,
  28.            4,   0,   0, 128,
  29.            4,   0,   0, 128,
  30.            4, 136, 136, 128,
  31.            4,  68,  68, 128,
  32.            4,  68,  68, 128,
  33.            4,  68,  68, 128,
  34.            4,  68,  68, 128,
  35.            4,  68,  68, 128,
  36.            4,  68,  68, 128,
  37.            4,  68,  68, 128,
  38.            4,  68,  68, 128,
  39.            4,  68,  68, 128,
  40.            4,  68,  68, 128,
  41.            4,  68,  68, 128,
  42.            4,  68,  68, 128,
  43.            4,  68,  68, 128,
  44.            4,  68,  68, 128,
  45.            4,  68,  68, 128,
  46.            4,  68,  68, 128,
  47.            4,  68,  68, 128,
  48.            4,  68,  68, 128,
  49.            4, 136, 136, 128,
  50.            4,   0,   0, 128,
  51.            4,   0,   0, 128,
  52.            7, 255, 255, 128,
  53.            0,   0,   0,   0,
  54.            0,   0,   0,   0,
  55.            0,   0,   0,   0);
  56.  
  57.  
  58. TYPE  WeinString = String[39];
  59.       Weintyp = record
  60.         Titel    : WeinString;
  61.         Jahrgang : integer;
  62.         Farbe    : String[8];
  63.         Geschmack: (trocken, staubig, suess, klebrig);
  64.         Anzahl   : integer;
  65.       end;
  66.  
  67. VAR   LaunchResult    : integer;
  68.       MyEvent         : EventTyp;
  69.       Terminated      : boolean;
  70.       CurrentKat      : String[39];
  71.       CurrentFile     : string;
  72.       f               : file of Weintyp;
  73.       FarbIndex       : integer;
  74.  
  75.  
  76. procedure DeleteWine(name:string);
  77. var f,g: file of WeinTyp;
  78.     w  : WeinTyp;
  79. begin
  80.   assign(f,CurrentFile+'.OLD');
  81.   {$i- }
  82.   erase(f);
  83.   assign(f,CurrentFile+'.VIN');
  84.   rename(f,CurrentFile+'.OLD');
  85.   assign(g,CurrentFile+'.VIN');
  86.   rewrite(g);
  87.   reset(f);
  88.   repeat
  89.     read(f,w);
  90.     if w.Titel <> name then
  91.       write(g,w);
  92.   until eof(f);
  93.   close(f);
  94.   close(g);
  95.   {$i+ }
  96. end;
  97.  
  98. function LoadWine(name: string; var Wine: WeinTyp):boolean;
  99. var f : file of WeinTyp;
  100. begin
  101.   LoadWine := false;
  102.   assign(f,CurrentFile+'.VIN');
  103.   {$i- }
  104.   reset(f);
  105.   if ioresult = 0 then
  106.     begin
  107.       repeat
  108.         read(f,Wine);
  109.       until eof(f) or (Wine.titel = name);
  110.       close(f);
  111.       if Wine.titel = name then LoadWine := true;
  112.     end;
  113. end;
  114.  
  115. procedure SaveWine(var Wine: WeinTyp);
  116. var f       : file of WeinTyp;
  117.     Scratch : WeinTyp;
  118. begin
  119.   if LoadWine(Wine.Titel, Scratch) then DeleteWine(Wine.Titel);
  120.   assign(f,CurrentFile+'.VIN');
  121.   {$i- }
  122.   reset(f);
  123.   if ioresult <> 0 then rewrite(f)
  124.   else seek(f,filesize(f)); { ans Ende }
  125.   write(f,Wine);
  126.   close(f);
  127.   {$i+ }
  128. end;
  129.  
  130.  
  131. { **** Callbackprozeduren zum Lesen der Kategorien aus der Ini-Datei **** }
  132.  
  133. procedure GetFirstKat(var name: ListString; var eol: boolean); far;
  134. var theline: string;
  135. begin
  136.   eol := not GetInitFileListFirst('vin','Kategorie',theline);
  137.   if not eol then GetParaString(theline,name);
  138. end;
  139.  
  140. procedure GetNextKat(var name: ListString; var eol: boolean); far;
  141. var theline: string;
  142. begin
  143.   eol := not GetInitFileListNext('Kategorie',theline);
  144.   if not eol then GetParaString(theline,name);
  145. end;
  146.  
  147. function GetWineFileName(name: ListString):string;
  148. var result  : string;
  149.     theline : string;
  150.     thename : string;
  151.     ready   : boolean;
  152. begin
  153.   GetWineFileName := '';
  154.   ready := false;
  155.   if GetInitFileListFirst('vin','Kategorie',theline) then
  156.     repeat
  157.       GetParaString(theline, thename);
  158.       if name = thename then
  159.         begin
  160.           ready := true;
  161.           GetParaName(theline, result); GetWineFileName := result;
  162.         end;
  163.       if not ready then ready := not GetInitFileListNext('Kategorie',theline);
  164.     until ready;
  165. end;
  166.  
  167. { **** Callback-Prozeduren zum Einlesen der Weine **** }
  168.  
  169. procedure GetNextWine(var name: ListString; var eol: boolean); far;
  170. var MyWine: WeinTyp;
  171. begin
  172.   eol := true;
  173.   {$i- }
  174.   read(f,MyWine);
  175.   {$i+ }
  176.   if ioresult = 0 then
  177.     begin
  178.       eol  := false;
  179.       name := MyWine.Titel;
  180.     end
  181.   else close(f);
  182. end;
  183.  
  184. procedure GetFirstWine(var name: ListString; var eol: boolean); far;
  185. begin
  186.   eol := true;
  187.   if CurrentFile <> '' then
  188.     begin
  189.       assign(f,CurrentFile+'.VIN');
  190.       {$i- *}
  191.       reset(f);
  192.       {$i+ }
  193.       if ioresult = 0 then GetNextWine(name, eol);
  194.     end;
  195. end;
  196.  
  197.  
  198. { **** Callback-Prozeduren zum Einlesen der Farbe *** }
  199.  
  200. procedure GetNextColor(var name: ListString; var eol: boolean); far;
  201. begin
  202.   if FarbIndex > MaxFarben then eol := true
  203.   else
  204.     begin
  205.       eol  := false;
  206.       name := Farben[FarbIndex];
  207.       inc(FarbIndex);
  208.     end;
  209. end;
  210.  
  211. procedure GetFirstColor(var name: ListString; var eol: boolean); far;
  212. begin
  213.   FarbIndex := 1;
  214.   GetNextColor(name,eol);
  215. end;
  216.  
  217.  
  218. procedure DialogProc1(TheEvent: EventTyp); far;
  219. var MYDLG     : PDialog;
  220.     MyEditor  : PEditField;
  221.     MyListBox : PListBox;
  222.     MyCombo   : PComboBox;
  223.     MyRadios  : PRadioButtons;
  224.     error     : integer;
  225.     MyWein    : WeinTyp;
  226. begin
  227.   MYDLG := TheEvent.DlgAdr;   { Adresse des Dialoges }
  228.   if TheEvent.Class = DIALOGEVENT then With TheEvent do
  229.     Case MSG of
  230.       DLG_BUTTON   : if ID = 199 then { löschen }
  231.                        begin
  232.                          MyEditor  := MYDLG^.FindDlgItem(102);
  233.                          if MyEditor^.GetString <> '' then DeleteWine(MyEditor^.GetString);
  234.                          MyListBox := MYDLG^.FindDlgItem(103);
  235.                          MyListBox^.Update;
  236.                        end
  237.                      else if ID = 1 then
  238.  
  239.                      begin { OK gedrückt, jetzt Plausibilität prüfen ! }
  240.                        error    := 0;
  241.                        MyEditor := MYDLG^.FindDlgItem(102);
  242.                        if MyEditor^.GetString = '' then error := 102;
  243.                        MyEditor := MYDLG^.FindDlgItem(104);
  244.                        if not MyEditor^.IsInteger then error := 104;
  245.                        if MyEditor^.IsInteger and ((MyEditor^.GetValue < 1900) or (MyEditor^.GetValue > 2100))
  246.                          then error := 104;
  247.                        MyEditor := MYDLG^.FindDlgItem(107);
  248.                        if not MyEditor^.IsInteger then error := 107;
  249.                        if MyEditor^.IsInteger and (MyEditor^.GetValue < 0) then
  250.                          error := 107;
  251.                        if error <> 0 then MYDLG^.SetTheFocus(error)
  252.                        else
  253.                         begin
  254.                           MyEditor := MyDLG^.FindDlgItem(102);  { Name lesen }
  255.                           MyWein.Titel    := MyEditor^.GetString;
  256.                           MyEditor := MyDLG^.FindDlgItem(104);  { Jahrgang lesen }
  257.                           MyWein.Jahrgang := MyEditor^.GetValue;
  258.                           MyEditor := MyDLG^.FindDlgItem(107);
  259.                           MyWein.Anzahl   := MyEditor^.GetValue;
  260.                           MyRadios := MyDLG^.FindDlgItem(105);  { Geschmack lesen }
  261.                           Case MyRadios^.WhosChecked of
  262.                            111 : MyWein.Geschmack := staubig;
  263.                            112 : MyWein.Geschmack := trocken;
  264.                            113 : MyWein.Geschmack := suess;
  265.                            114 : MyWein.Geschmack := klebrig;
  266.                           end;
  267.                           MyCombo := MyDLG^.FindDlgItem(106);
  268.                           MyWein.Farbe := MyCombo^.GetSelected;
  269.                           SaveWine(MyWein);
  270.                           MyListBox := MYDLG^.FindDlgItem(103);
  271.                           MyListBox^.Update;
  272.                         end;
  273.                      end;
  274.  
  275.       DLG_CANCEL   : begin
  276.                        MYDLG^.flags := MYDLG^.flags or MF_CANCELLED;
  277.                        MYDLG^.DestroyDialog;
  278.                      end;
  279.  
  280.       DLG_COMBOSELECT : if ID = 101 then  { Kategorie geändert }
  281.                        begin
  282.                          MyCombo := MyDLG^.FindDlgItem(101);
  283.                          CurrentKat  := MyCombo^.GetSelected;
  284.                          CurrentFile := GetWineFileName(CurrentKat);
  285.                          MyListBox   := MyDlg^.FindDlgItem(103);
  286.                          MyListBox^.Update;
  287.                          MyEditor    := MYDLG^.FindDlgItem(102);
  288.                          MYEditor^.SetString('');
  289.                          MSG := DLG_LISTMOVED;
  290.                          DialogProc1(TheEvent); { rekursiver Aufruf }
  291.                        end;
  292.  
  293.       DLG_LISTSELECT,
  294.       DLG_LISTMOVED : begin
  295.                         MyListBox := MyDLG^.FindDlgItem(103);
  296.                         if LoadWine(MyListBox^.GetMarked, MyWein) then
  297.                           begin
  298.                             MyEditor  := MyDLG^.FindDlgItem(102);
  299.                             MyEditor^.SetString(MyWein.Titel);
  300.                             MyEditor  := MyDLG^.FindDlgItem(104);  { Jahrgang  }
  301.                             MyEditor^.SetValue(MyWein.Jahrgang);
  302.                             MyEditor  := MyDLG^.FindDlgItem(107);  { Anzahl    }
  303.                             MyEditor^.SetValue(MyWein.Anzahl);
  304.                             MyRadios  := MyDLG^.FindDlgItem(105);  { Geschmack }
  305.                             Case MyWein.Geschmack of
  306.                               staubig : MyRadios^.CheckButton(111);
  307.                               trocken : MyRadios^.CheckButton(112);
  308.                               suess   : MyRadios^.CheckButton(113);
  309.                               klebrig : MyRadios^.CheckButton(114);
  310.                             end;
  311.                             MyCombo := MyDLG^.FindDlgItem(106);
  312.                             MyCombo^.Select(MyWein.Farbe);
  313.                           end;
  314.                       end;
  315.     end;
  316. end;
  317.  
  318.  
  319. procedure Verwaltung;
  320. var MyDialog     : Dialog;
  321.     MyEditor     : PEditField;
  322.     MyLabel      : PLabelText;
  323.     MyCombo      : PComboBox;
  324.     MyListBox    : PListBox;
  325.     MyChecker    : PCheckBox;
  326.     MyRadios     : PRadioButtons;
  327.     MyButton     : PButton;
  328.     MyUserButton : PUserButton;
  329.     MyWine       : Weintyp;
  330. begin
  331.   MyDialog.Init(55*FontX, 16*FontY, MF_CAPTION, DialogProc1);
  332.   MyDialog.SetCaption('in vino veritas');
  333.   MyDialog.SetTopic('Wein');
  334.  
  335.   new(MyCombo, Init(FontX, 2*FontY, 27,8, 101, GetFirstKat, GetNextKat));
  336.   MyDialog.AddItem(MyCombo);
  337.  
  338.   CurrentKat  := MyCombo^.GetSelected;
  339.   CurrentFile := GetWineFileName(CurrentKat);
  340.  
  341.   new(MyLabel, Init(FontX, FontY,0,'Kategorie:'));
  342.   MyDialog.AddItem(MyLabel);
  343.  
  344.   new(MyLabel, Init(FontX, 4*FontY,0,'Bezeichnung:'));
  345.   MyDialog.AddItem(MyLabel);
  346.  
  347.   new(MyEditor, Init(FontX, 5*FontY,29,39,102,''));
  348.   MyDialog.AddItem(MyEditor);
  349.  
  350.   new(MyListBox, Init(FontX, 7*FontY, 19,8, 103, GetFirstWine, GetNextWine));
  351.   MyDialog.AddItem(MyListBox);
  352.  
  353.   new(MyLabel, Init(23*FontX, 7*FontY,0,'Jahr:'));
  354.   MyDialog.AddItem(MyLabel);
  355.   new(MyEditor, Init(23*FontX, 8*FontY,5,4,104,''));
  356.   MyDialog.AddItem(MyEditor);
  357.  
  358.   new(MyLabel, Init(32*FontX, 7*FontY,0,'Anzahl:'));
  359.   MyDialog.AddItem(MyLabel);
  360.   new(MyEditor, Init(32*FontX, 8*FontY,5,4,107,'0'));
  361.   MyDialog.AddItem(MyEditor);
  362.  
  363.   new(MyRadios, Init(23*FontX,11*FontY,22*FontX,4*FontY-8,105,'Geschmack',
  364.    new(PRadioButton, Init(FontX,FontY,111,'staubig',
  365.     new(PRadioButton, Init(FontX,2*FontY,112,'trocken',
  366.      new(PRadioButton, Init(11*FontX,FontY,113,'süß',
  367.       new(PRadioButton, Init(11*FontX,2*FontY,114,'klebrig',nil))))))))));
  368.   MyDialog.AddItem(MyRadios);
  369.   MyRadios^.Checkbutton(111);
  370.  
  371.   new(MyCombo,Init(41*FontX,8*FontY,6,3,106,GetFirstColor,GetNextColor));
  372.   MyDialog.AddItem(MyCombo);
  373.   new(MyLabel,Init(41*FontX,7*FontY,0,'Farbe:'));
  374.   MyDialog.AddItem(MyLabel);
  375.  
  376.   new(MyButton, Init(40*FontX,FontY, 14*FontX, 2*FontY-8, 1,'Speichern'));
  377.   MyDialog.AddItem(MyButton);
  378.  
  379.   new(MyButton, Init(40*FontX,3*FontY,14*FontX, 2*FontY-8, 2,'Abbruch'));
  380.   MyDialog.AddItem(MyButton);
  381.   MyButton^.MakeCancelItem;
  382.  
  383.   new(MyUserButton, Init(33*FontX,FontY,6*FontX,4*FontY-8,29,35,199,'D',@MuellIcon));
  384.   MyDialog.AddItem(MyUserButton);
  385.  
  386.   MyDialog.Show;
  387.   MyDialog.DoDialog;
  388.   MyDialog.Done;
  389. end;
  390.  
  391.  
  392. PROCEDURE HandleMsg(MyMessage: EventTyp); far;
  393. Begin
  394.   With MyMessage Do
  395.     Case Class Of
  396.       Menu    : begin
  397.                   Case MenuItemID of
  398.                      0       : Terminated := true;  { Programm beenden }
  399.                      101     : Verwaltung;
  400.                   end;
  401.                 end;
  402.     end; { Case Class }
  403. End;
  404.  
  405.  
  406. Begin
  407.   Terminated := false;
  408.   DebugOn;
  409.   LaunchResult := OpenMainApplication(HandleMsg,
  410.                                           APP_NOFONT+APP_NOHELP,
  411.                                           ProjektName);
  412.  
  413.   If LaunchResult = 0 then
  414.     begin
  415.       repeat
  416.         GetEvent(MyEvent);
  417.         DispatchMessage(MyEvent);
  418.       until Terminated;
  419.       CloseMainApplication;
  420.     end
  421.   Else
  422.     Writeln('Programm kann nicht gestartet werden. Fehler: ',LaunchResult);
  423. End.