Помогите! уже 10 раз с книги алгоритм перебил не пашет(
Прога должна прятать текст в картинку, но после шифровки картинка умирает
Кто может помогите! зарание СПАСИБО

type
ab=array [0..3] of byte;
wordp=^word;
longp=^dword;
bytep=^byte;
abp=^ab;

var
 Form1: TForm1;
 fnamep,fnamet,st,sttext:string;
 fipic,fopic,ftext:file;
 i,j,picsize,textsize,picoffs:integer;
 xb,tb,ib:byte;
 xw,yw:word;
 plong:longp;
 pword:wordp;
 pab:abp;
 pp:pointer;
 pb:bytep;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  OpenDialog1.InitialDir:=ExtractFileDir(Application.ExeName);
  picsize:=0;
  textsize:=0;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin  {открыть картинку}
  OpenDialog1.FileName:=''; {очистим}
  if OpenDialog1.Execute then
  fnamep:=OpenDialog1.FileName else exit;
  try
    Image1.Picture.LoadFromFile(fnamep);
  except
    exit; {если не открывается - на выход}
  end;
  assignfile(fipic,fnamep); {задали исходный файл с картинкой}
  reset(fipic,1);
  {проверка:}
  New(pab);
  seek(fipic,18); {начиная с 18-го байта - размеры}
  for i:=0 to 3 do blockread(fipic,pab^[i],1);
  plong:=longp(integer(pab));
  picsize:=plong^; {ширина}
  for i:=0 to 3 do blockread(fipic,pab^[i],1);
  plong:=longp(integer(pab));
  picsize:=picsize*plong^; {ширина*длину в пикселах}
  seek(fipic,28); {начиная с 28-го байта - бит на пиксел, потом компрессия по два байта}
  for i:=0 to 3 do blockread(fipic,pab^[i],1);
  pword:=wordp(integer(pab));
  xw:=pword^; {бит на пиксел}
  pword:=wordp(integer(pab)+2);
  yw:=pword^; {компрессия}
  if (xw<8) or (yw<>0) then
  begin
    st:='В файле '+ExtractFileName(fnamep)+' используется сжатие'+
    #10+'изображения или в нем слишком мало цветов.'+#10+
    'Подберите другой BMP-файл.';
    Application.MessageBox(Pchar(st),'Ошибка',mb_OK);
    picsize:=0;
    closefile(fipic);
    exit;
  end;
  {проверяем размер, если текст уже открыт:}
  if textsize<>0 then
  begin
   if (picsize*xw)<(textsize*8) then
   begin
    st:='Файл '+ExtractFileName(fnamep)+' имеет недостаточный размер'+
    #10+'Подберите другой BMP-файл.';
    Application.MessageBox(Pchar(st),'Ошибка',mb_OK);
    picsize:=0;
    Button3.Enabled:=False; {кнопка шифрации недоступна}
    closefile(fipic);
    exit;
   end else Button3.Enabled:=True; {кнопка шифрации доступна}
  end;
  Button4.Enabled:=True; {кнопка дешифрации доступна, когда открыта картинка}
  seek(fipic,10); {начиная с 10-го байта - смещение}
  for i:=0 to 3 do blockread(fipic,pab^[i],1);
  plong:=longp(integer(pab));
  picoffs:=plong^; {в picoffs - смещение массива пикселов от начала файла}
  Dispose(pab);
  closefile(fipic);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin   {открыть текст}
  OpenDialog1.FileName:=''; {очистим}
  if OpenDialog1.Execute then
  fnamet:=OpenDialog1.FileName else exit;
  assignfile(ftext,fnamet); {задали исходный файл с текстом}
  reset(ftext,1);
  textsize:=filesize(ftext);
  {проверяем размер, если картинка уже открыта:}
  if picsize<>0 then
  begin
   if (picsize*xw)<(textsize*8) then
   begin
    st:='Файл '+ExtractFileName(fnamet)+' слишком велик для выбранного изображения.'+
    #10+'Подберите другой BMP-файл.';
    Application.MessageBox(Pchar(st),'Ошибка',mb_OK);
    textsize:=0;
    Button3.Enabled:=False; {кнопка шифрации недоступна}
    closefile(ftext);
    exit;
   end else Button3.Enabled:=True; {кнопка шифрации доступна}
  end;
  getmem(pp,textsize);
  blockread(ftext,pp^,textsize,j);{прочтем текст за один прием}
  for i:=0 to textsize-1 do  {и переведем в строку}
  begin
    pb:=bytep(integer(pp)+i);
    sttext:=sttext+chr(pb^);
  end;
  freemem(pp,textsize);
  Memo1.Text:=sttext; {выведем в Memo}
  closefile(ftext);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin   {зашифровать текст}
  assignfile(fipic,fnamep); {исходный файл с картинкой}
  reset(fipic,1);
  ChDir(ExtractFileDir(fnamep));{на вский случай устанавливаем папку}
  assignfile(fopic,'0'+ExtractFileName(fnamep)); {имя выходного файла}
  rewrite(fopic,1);
  seek(fipic,picoffs); {все до picoffs игнорируем}
  st:=IntToStr(length(sttext));
  while length(st)<10 do st:='0'+st; {числовое поле 10 знаков}
  sttext:='steganographia'+st+sttext; {добавляем сигнатуру и размер записи,
  всего 24 байт заголовок}
  for i:=1 to length(sttext) do {основная процедура}
  begin
    tb:=ord(sttext[i]); {очередной байт текста}
    for j:=0 to 7 do
    begin
      blockread(fipic,ib,1); {очередной байт изображения}
      ib:=ib and $FE; {обнуляем младщий бит изображения}
      xb:=tb shr j; {сдвигаем до нужного ьита}
      xb:=xb and $01; {обнуляем все, кроме младшего бита}
      ib:=ib or xb; {записываем младший бит}
      blockwrite(fopic,ib,1);
    end;
  end;
  {записываем остаток сразу куском:}
  j:=filesize(fipic)-filepos(fipic);
  getmem(pp,j+1);
    blockread(fipic,pp^,j,i);
    blockwrite(fopic,pp^,i,i);
  freemem(pp,j+1);
  closefile(fipic);
  closefile(fopic);
  st:='Текст зашифрован в файле '+'0'+ExtractFileName(fnamep);
  Application.MessageBox(Pchar(st),'Все отлично',mb_OK);
end;

procedure TForm1.Button4Click(Sender: TObject);
begin {расшифровать картинку}
  Memo1.Lines.Clear;  {очищаем Memo}
  textsize:=0; {как будто текстового файла не было}
  Button3.Enabled:=False; {кнопка шифрации недоступна}
  assignfile(fipic,fnamep); {исходный файл с картинкой}
  reset(fipic,1);
  seek(fipic,picoffs); {все до picoffs игнорируем}
  st:='';
  for i:=1 to 24 do {чтение заголовка}
  begin
    tb:=0;
    for j:=0 to 7 do
    begin
      blockread(fipic,ib,1); {очередной байт изображения}
      ib:=ib and $01;{обнуляем все, кроме младшего бита}
      ib:=ib shl j; {сдвигаем до нужного бита}
      tb:=tb or ib; {записываем младший бит}
    end;
    st:=st+chr(tb); {очередной байт заголовка}
  end;
  if pos('steganographia',st)=0 then {если там нет информации}
  begin
    st:='В файле '+ExtractFileName(fnamep)+' отсутствует текст.';
    Application.MessageBox(Pchar(st),'Ошибка',mb_OK);
    exit;
  end;
  delete(st,1,14);
  j:=StrToIntDef(st,0); {извлекаем длину}
  if j=0 then
  begin
    st:='В файле '+ExtractFileName(fnamep)+' длина сообщения равна 0.';
    Application.MessageBox(Pchar(st),'Ошибка',mb_OK);
    exit;
  end;
  sttext:='';
  for i:=1 to j do {чтение сообщения}
  begin
    tb:=0;
    for j:=0 to 7 do
    begin
      blockread(fipic,ib,1); {очередной байт изображения}
      ib:=ib and $01;{обнуляем все, кроме младшего бита}
      ib:=ib shl j; {сдвигаем до нужного бита}
      tb:=tb or ib; {записываем младший бит}
    end;
    sttext:=sttext+chr(tb); {очередной байт сообщения}
  end;
  Memo1.Text:=sttext; {выведем в Memo}
  closefile(fipic);
end;

procedure TForm1.Button5Click(Sender: TObject);
begin  {очистить текст}
 Memo1.Lines.Clear;
 textsize:=0;
 Button3.Enabled:=False; {кнопка шифрации недоступна}
end;

end.

> Кто может помогите!


Чем же помочь тебе, убогий ?

спам