Új hozzászólás Aktív témák

• #189 b14 senior tag B-52 #184

  Új Válasz 2004-08-12 18:24:39 #189

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  b14

  senior tag

  válasz B-52 #184 üzenetére

  (* bmpread.pas *)
  program Bitmap_olvasasa;
  uses crt, graph, bitmap;
  
  var gvezerlo, gmod,
  hibakod, x, y :integer;
  nev : string;
  begin
  clrscr;
  writeln('K‚ren a .BMP f jl nev‚t: ');
  readln(nev);
  if nev='' then nev:='donald.bmp';
  
  { A grafika bekapcsol sa automatikus hardver ‚s m˘d detekt l ssal }
  detectgraph(gvezerlo,gmod);
  initgraph(gvezerlo,gmod,'');
  
  { Ha nem sikerlt bekapcsolni a grafik t kil‚p‚s a programb˘l }
  hibakod := GraphResult;
  if hibakod <> grOK then
  begin
  WriteLn('Grafika hiba:');
  WriteLn(GraphErrorMsg(hibakod));
  Halt(1);
  end;
  
  { A .BMP f jl beolvas sa ‚s megjelenˇt‚se }
  bmpdisplay(nev);
  
  readln;
  { A grafika kikapcsol sa ‚s a sz”veges zemm˘d vissza llˇt sa}
  closegraph;
  restorecrtmode;
  end.
  
  
  
  
  
  
  
  Es a hsznalt unit:
  (* BITMAP.PAS *)
  
  { a grafikus k‚perny“ k”zep‚re
  16 szˇn– bitk‚p felolvas s t v‚gz“ modul }
  
  unit bitmap;
  interface
  
  { 16 szˇn– bitk‚p megjelenˇt‚se }
  procedure BMPDisplay(FileName: string);
  
  implementation
  uses Graph;
  
  type
  TBitMapHeader = Record { a bitk‚p fejl‚ce }
  bfType : word;
  bfSize : longint;
  bfReserved : longint; { 0 }
  bfOffBits : longint;
  biSize : longint;
  biWidth : longint;
  biHeight : longint;
  biPlanes : word; { 1 }
  biBitCount : word; {1,4,8,24}
  biCompression : longint;
  biSizeImage : longint; {b jtban}
  biXPelsPerMeter : longint;
  biYPelsPerMeter : longint;
  biClrUsed : longint;
  biClrImportant : longint;
  end;
  
  TRGBQuad = Record { az RGB-paletta elemei }
  rgbBlue,
  rgbGreen,
  rgbRed,
  rgbReserved : Byte;
  end;
  
  TByteArray = Array[0..50000] of byte;
  
  {----------------------------------------------------}
  { 4-bites szˇneket tartalmaz˘ .BMP f jl tartalm nak }
  { megjelenˇt‚se a k‚perny“ k”zep‚n }
  {----------------------------------------------------}
  procedure Display4 (var f : file; BitMapHeader : TBitMapHeader);
  var
  i, y: Integer;
  RGBQuad : TRGBQuad;
  TwoPixel, Black : Byte;
  Line : ^TByteArray;
  number : word;
  CurrentX, BeginX, BeginY, EndY : Integer;
  begin
  if GetMaxColor < 15 then
  begin
  OutText ('Ez a m˘d nem t mogatja a 4 bites szˇnek haszn lat t!');
  Exit;
  end;
  
  Black := 16;
  
  { a palettaszˇnek felolvas sa }
  for i:= 0 to 15 do
  begin
  BlockRead(f, RGBQuad, SizeOf(RGBQuad));
  if (longint(RGBQuad)=0) then Black := i;
  with RGBQuad do
  SetRGBPalette(i, rgbRed shr 2, rgbGreen shr 2, rgbBlue shr 2);
  SetPalette(i,i);
  end;
  
  { a bitk‚p k”z‚pre igazˇt sa }
  with BitMapHeader do
  begin
  { a k‚psor b jtok sz ma }
  Number := (biWidth div 2 + 3) and not 3;
  { k”z‚pre helyezi a k‚perny“n }
  BeginX := (GetMaxX - biWidth) div 2;
  BeginY := GetMaxY - (GetMaxY - biHeight) div 2;
  EndY := BeginY + 1 - biHeight;
  end;
  
  { a k‚p bitjeinek feldolgoz sa }
  GetMem (Line, number + 1);
  { soronk‚nt }
  for y:=BeginY downto EndY do
  begin
  BlockRead(f, Line^[1], number);
  CurrentX := BeginX;
  { b jtonk‚nt }
  for i:=1 to number do
  begin
  TwoPixel := Line^; { k‚t k‚ppont }
  if TwoPixel shr 4 <> Black then { a fels“ }
  PutPixel(CurrentX, y ,TwoPixel shr 4);
  Inc(CurrentX);
  if TwoPixel and 15 <> Black then { az als˘ }
  PutPixel(CurrentX, y, TwoPixel and 15);
  Inc(CurrentX);
  end;
  end;
  FreeMem (Line, number+1);
  end;
  
  procedure NotDisplay(colors:byte);
  var
  tst : string[4];
  begin
  str(colors, tst);
  OutText (tst+' bites szˇneket tartalmaz˘ bitk‚p megjelenˇt‚s‚re nem alkalmas!');
  end;
  
  
  {--------------------------------------------}
  { A megadott nev– .BMP  llom ny feldolgoz sa }
  {--------------------------------------------}
  procedure BMPDisplay(FileName: string);
  var f: file;
  BitMapHeader : TBitMapHeader;
  begin
  Assign(f,FileName);
  FileMode := 0; {Read Only}
  {$I-}
  Reset(f,1);
  FileMode := 2; {Default}
  {$I+}
  if IOResult<>0 then
  begin
  OutText ('A(z) '+FileName+' nev– f jl nem l‚tezik!');
  Exit;
  end;
  
  { a bitk‚pfejl‚c beolvas sa }
  BlockRead(f, BitMapHeader, SizeOf(BitMapHeader));
  with BitMapHeader do
  begin
  if (bfType<>19778) or (bfReserved<>0) or (biPlanes<>1) then
  begin
  OutText ('Nem Windows bitk‚p  llom ny!');
  Close(f);
  Exit;
  end;
  if biCompression<>0 then
  begin
  OutText ('Nem tud megjelenˇteni t”m”rˇtett  llom nyt!');
  Close(f);
  Exit;
  end;
  ClearDevice;
  case biBitCount of
  1 : NotDisplay(1); { 1-bites szˇn: ? }
  4 : Display4(f, BitMapHeader);{ 4-bites szˇn }
  8 : NotDisplay(8); { 8-bites szˇn: ? }
  24 : NotDisplay(24); { 24-bites szˇn: ? }
  else
  begin
  OutText ('Nem Windows bitk‚p  llom ny!');
  Close(f);
  Exit;
  end;
  end;
  end;
  Close(f);
  end;
  
  end.
  
  
  
  
  
  
  
  
  
  
  
  
  
  Remelem erre volt szukseged.
  Tovabbi jo programozást.
  Ha nem erre lett volnaszukseged akkor csak szolj vannak meg ilyen dolgaim
  

Új hozzászólás Aktív témák