IPB
ЛогинПароль:

> Прочтите прежде чем задавать вопрос!

1. Заголовок темы должен быть информативным. В противном случае тема удаляется ...
2. Все тексты программ должны помещаться в теги [code=pas] ... [/code], либо быть опубликованы на нашем PasteBin в режиме вечного хранения.
3. Прежде чем задавать вопрос, см. "FAQ", если там не нашли ответа, воспользуйтесь ПОИСКОМ, возможно такую задачу уже решали!
4. Не предлагайте свои решения на других языках, кроме Паскаля (исключение - только с согласия модератора).
5. НЕ используйте форум для личного общения, все что не относится к обсуждению темы - на PM!
6. Одна тема - один вопрос (задача)
7. Проверяйте программы перед тем, как разместить их на форуме!!!
8. Спрашивайте и отвечайте четко и по существу!!!

 
 Ответить  Открыть новую тему 
> Программа Склад, База данных учёта товаров.
сообщение
Сообщение #1





Группа: Пользователи
Сообщений: 3
Пол: Мужской

Репутация: -  0  +


Добрый вечер!
Программа компилируется,работает,но не удаляет,не ищет и не редактирует товар.Пишет что товар не найден.


program sklad;
 
uses
   crt;
 
const
   n_items = 7;
   l_name = 30;
 
type
   str_name = string[l_name];
   pTovar = ^Tovar;
   Tovar = record
      name: str_name;
      kolvo: integer;
      cena: real;
      next: pTovar;
      prev: pTovar;
   end;
 
var
   DefaultMode,
   ActiveColor, InactiveColor: word;
   key: char;
   item: word;
   prev: word;
   beg: pTovar;
   fin: pTovar;
   p: pTovar;
   name: str_name;
   tovr: Tovar;
 
procedure Add(var beg, fin: pTovar; const tovr: Tovar); forward;
 
procedure Clear; forward;
 
procedure Del(var beg, fin, p: pTovar); forward;
 
procedure DlgWindow; forward;
 
procedure DrawItem(item, color: word); forward;
 
procedure Edit(beg: pTovar; const tovr: Tovar); forward;
 
procedure Error(message: string); forward;
 
function Find(p: pTovar; const tovr:str_name): pTovar; forward;
 
procedure Info(const tovr: Tovar); forward;
 
procedure InitMenu(ActvieColor, InactiveColor: word); forward;
 
procedure Message(message: string); forward;
 
procedure Query(var tovr: Tovar); forward;
 
procedure QueryName(var name: str_name); forward;
 
procedure ReadFile(var beg, fin: pTovar); forward;
 
procedure Select(beg: pTovar); forward;
 
procedure ShowBase(beg: pTovar); forward;
 
procedure Add(var beg, fin: pTovar; const tovr: Tovar);
var
   p: pTovar;
begin
   new(p);
   p^ := tovr;
   p^.next := nil;
   p^.prev := fin;
   if beg = nil then beg := p
   else fin^.next := p;
   fin := p;
end;
 
procedure Clear;
begin
   window(1, 3, 80, 25);
   TextColor(White);
   Clrscr;
end;
 
procedure Del(var beg, fin, p: pTovar);
begin
   if (p = beg) and (p = fin) then
   begin
      beg := nil;
      fin := nil;
   end
   else
   if p = beg then begin
      beg := beg^.next;
      beg^.prev := nil
   end
   else
   if p = fin then begin
      fin := fin^.prev;
      fin^.next := nil;
   end
   else
   begin
      p^.prev^.next := p^.next;
      p^.next^.prev := p^.prev;
   end;
   dispose(p);
end;
 
procedure DlgWindow;
begin
   window(10, 6, 70, 12);
   TextColor(Green);
   TextBackground(LightGray);
   clrscr;
end;
 
procedure DrawItem(item, color: word);
const
   d = 12;
   items: array[1..n_items] of string[d] = ('Vivod bazi dannix', 'Dobavlenie',
   'Izmenenie', 'Udalenie', 'Poisk', 'Vibor', 'Vixod');
   pos: array[1..n_items] of integer = (1 , d + 2, 2 * d + 3, 3 * d + 3, 4 * d + 3, 5 * d + 0, 6 * d - 6);
begin
   window(1, 1, 80, 2);
   TextBackGround(LightGray);
   TextColor(Color);
   gotoXY(pos[item], 1);
   write(items[item]);
end;
 
procedure edit(beg: pTovar; const tovr: Tovar);
var
   p: pTovar;
begin
   p := Find(beg, tovr.name);
   if p <> nil then begin
      p^.kolvo := tovr.kolvo;
      p^.cena := tovr.cena;
   end;
end;
 
procedure error(message: string);
begin
   window(1, 1, 80, 25);
   TextColor(Red);
   clrscr;
   gotoXY(35, 12);
   write(message);
   repeat 
   until keypressed;
   TextMode(DefaultMode);
   halt;
end;
 
function Find(p: pTovar; const tovr:str_name): pTovar;
begin
   while p <> nil do
   begin
      if tovr=p^.name then
      begin
         Find := p;
         exit;
      end;
      p := p^.next;
   end;
   Message('Tovar ne naiden');
   Find := nil;
end;
 
procedure Info(const tovr: Tovar);
begin
   DlgWindow;
   with tovr do
   begin
      gotoXY(2, 2);
      writeln('Nazvanie tovara:', name);
      gotoXY(2, 4);
      writeln('Kolichestvo tovara:', kolvo);;
      gotoXY(2, 6);
      writeln('Cena tovara:', cena);
   end;
   readln;
end;
 
procedure InitMenu(ActvieColor, InactiveColor: word);
var
   item: word;
begin
   window(1, 1, 80, 2);
   TextBackGround(lightGray);
   clrscr;
   DrawItem(1, ActiveColor);
   for item := 2 to n_items do DrawItem(item, InactiveColor);
   gotoXY(1, 2);
   TextColor(InactiveColor);
   write('----------------------------------------------------------------------');
   gotoXY(1, 1);
end;
 
procedure Message(message: string);
begin
   DlgWindow;
   gotoXY(2, 4);
   write(message);
   readln;
end;
 
procedure Query(var tovr: Tovar);
var
   s: string;
   err: integer;
   i, len: integer;
begin
   DlgWindow;
   with tovr do 
   begin
      repeat
         gotoXY(2, 2);
         write('Nazvanie Tovara:     ');
         clreol;
         readln(name);
         len := length(name);
         for i := len + 1 to l_name do name := name + ' ';
      until len <> 0;
      repeat
         gotoXY(2, 4);
         write('Kolichestvo tovara:    ');
         clreol;
         readln(s);
         val(s, kolvo, err);
      until(err = 0) and (kolvo > 0);
      repeat
         gotoXY(2, 6);
         write('Cena tovara:         ');
         clreol;
         readln(s);
         val(s, cena, err);
      until(err = 0) and (cena > 0);
   end;
end;
 
procedure QueryName(var name: str_name);
var
   i, len: integer;
begin
   DlgWindow;
   gotoXY(2, 2);
   write('Nazvanie tovara:                 ');
   clreol;
   readln(name);
   len := length(name);
   for i := len + 1 to l_name do name := name + '';
end;
 
procedure ReadFile(var beg, fin: pTovar);
var
   f: text;
   tovr: Tovar;
begin
   {$I-}
   assign(f, 'bazatovarov.txt');
   rewrite(f);
   reset(f);
   if (IOResult <> 0) then Error('Fail bazatovarov.txt ne naiden');
   {$I+}
   while not eof(f) do
   begin
      with tovr do 
         readln(f, name, kolvo, cena);
      Add(beg, fin, tovr);
   end;
   close(f);
end;
 
procedure Select(beg: pTovar);
    
   procedure QueryCena(var cena: real);
   var
      s: string;
      err: integer;
   begin
      DlgWindow;
      repeat
         gotoXY(2, 4);
         write('Cena tovara: ');
         clreol;
         readln(s);
         val(s, cena, err);
      until (err = 0) and (cena > 0);
   end;
 
var
   begs, fins: pTovar;
   p: pTovar;
   cena: real;
begin
   QueryCena(cena);
   begs := nil;
   fins := nil;
   p := beg;
   while p <> nil do 
   begin
      if p^.cena > cena then Add(begs, fins, p^);
      p := p^.next;
   end;
   ShowBase(begs);
end;
 
procedure ShowBase(beg: pTovar);
const
   step = 18;
   
   procedure ShowPage(var p: pTovar);
   var
      i: integer;
   begin
      clrscr;
      gotoXY(1, 1);
      writeln('Nazvanie tovara           Kolichestvo Tovara             Cena Tovara');
      i := 0;
      while p <> nil do 
      begin
         with p^ do 
            writeln(' ', name, kolvo:5, cena:15:2);
         p := p^.next;
         inc(i);
         if i > step then exit;
      end;
   end;
 
var
   i: integer;
   key: char;
   p, pn: pTovar;
begin
   if beg = nil then
   begin
      Message('Spisok pyst');
      exit
   end;
   window(3, 4, 78, 24);
   TextBackGround(LightGray);
   TextColor(white);
   p := beg;
   while true do
   begin
      pn := p;
      ShowPage(p);
      key := readkey;
      if key = #0 then key := readkey;
      case ord(key) of
         27: exit;
         13, 80{down}, 81: if p = nil then p := pn;
         72, 73{up}:
            begin
               p := pn;
               for i := 1 to step do
               begin
                  p := p^.prev;
                  if p = nil then
                  begin
                     p := beg;
                     break
                  end;
               end;
            end;
      end;
   end;
end;
 
begin
   DefaultMode := LastMode;
   TextMode(C80);
   beg := nil;
   fin := nil;
   ReadFile(beg, fin);
   clrscr;
   ActiveColor := LightGreen;
   InactiveColor := Green;
   InitMenu(ActiveColor, InactiveColor);
   item := 1;
   prev := 1;
   while true do 
   begin
      key := readkey;
      if key = #0 then key := readkey;
      case ord(key) of
         13:
            case item of
               1: ShowBase(beg);
               2:
                  begin
                     Query(tovr);
                     Add(beg, fin, tovr);
                  end;
               3:
                  begin
                     Query(tovr);
                     Edit(beg, tovr);
                  end;
               4:
                  begin
                     QueryName(name);
                     p := Find(beg, name);
                     if p <> nil then Del(beg, fin, p);
                  end;
               5:
                  begin
                     QueryName(name);
                     p := Find(beg, name);
                     if p <> nil then Info(p^);
                  end;
               6: Select(beg);
               7: exit;
            end;
         15{Shift+Tab}, 75{Left}:
            begin
               prev := item;
               dec(item);
               if item = 0 then item := n_items;
            end;
         9{Tab}, 77{Right}:
            begin
               prev := item;
               inc(item);
               if item = n_items + 1 then item := 1; end;
      end;
      Clear;
      DrawItem(prev, InactiveColor);
      DrawItem(item, ActiveColor);
   end;
   TextMode(DefaultMode);
end. 
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 
сообщение
Сообщение #2





Группа: Пользователи
Сообщений: 3
Пол: Мужской

Репутация: -  0  +


Тему можно закрыть))
 Оффлайн  Профиль  PM 
 К началу страницы 
+ Ответить 

 Ответить  Открыть новую тему 
1 чел. читают эту тему (гостей: 1, скрытых пользователей: 0)
Пользователей: 0

 



- Текстовая версия 29.07.2025 9:22
500Gb HDD, 6Gb RAM, 2 Cores, 7 EUR в месяц — такие хостинги правда бывают
Связь с администрацией: bu_gen в домене octagram.name