JPG&GIF I PASCAL

Du skal bruge D5 eller have fat i et freeware komponent (prøv evt. http://sunsite.icm.edu.pl/delphi/).

Herefter dropper du et TImage på din form og bruger image1.picture.loadfromfile(billedenavn);
Så bliver billedet indlæst og vist i din form. Hvis du vil gemme det i en db kan du f.eks. bruge paradox og her angive et felt som "Graphic" og koble dette sammen med et DBImage komponent på formen. SÅ kan du igen bruge ..LoadFormFile(xxx) og ..SaveToFile(yyy) når du vil have det tilbage som en alm. diskfil.

Det er desværre kun D5 der supporterer JPEg og Gif billeder uden specielle komponenter.

Anders Melander har lavet et et gif komponent.
Du kan finde det her : http://www.melander.dk/delphi/gifimage/

Og jeg mener at der er et jpeg  eksempel i din VCL Reference hjælpe fil.

:)

JustinCase

Om igen folkens. Delphi 3 understøtter JPG billeder i et almindeligt TImage komponent (Skriv Uses Jpeg;) og du kan få et lignende unit til gif.

Men læs lige mit spørgsmål igen PASCAL.
Det skal være et unit til
TURBO PASCAL 7.0 (Delphi programmer kører ikke så fandens godt på 20Mhz med 2 mb ram - min bærbare)

Det er helt rigtigt, jeg har personligt lavet noget i delphi3, hvor jeg arbejde med jpeg!

Jeg har også arbejdet med gif, det var også i D3, og jeg downloadede denne source fra ET ELLER ANDET STED, men jeg sender det gerne til dig....

Ups jeg læste lige din kommentar! Jeg har også arbejdet i TP 7, men det er sgu længe siden - men hvis du gerne vil ha' et eller andet, så bare skriv det!

Skriv bare din Email-adr, hvis du altså vil have noget fra mig  = )

stoons: Er det ikke en lidt dum kommentar: "men hvis du gerne vil ha' et eller andet, så bare skriv det!" ????

Selvfølgelig vil han da ha' et eller andet så han kan få løst hans problem ! Ellers havde han sikkert ikke stillet spørgsmålet !!!

Snowball

Okay, her er min email:
cybermikedk@yahoo.com

Og lad nu være med at sende mig 10GB data.

OK!
Jeg sender jeg sender straks GIF-tingen til dig....

snowball: Det kunne du da godt ha' ret i, men jeg kan sgu ikk' huske om det kan bruges i TP 7!

Hmmm... jeg prøved at sende det til dig på cybermikedk@yahoo.com, men jeg fik det tilbage med en besked om at det IKKE kunne sendes til den givne adresse!
Så her har i konsekvensen af denne fejl:
Jeg sætter det ganske simpelt ind her...

unit GIFIT;

interface

uses
  SysUtils,Classes,Windows,Graphics;

const
  BlockTerminator:byte = 0;
  FileTrailer:byte = $3B;
  gifBGColor:byte = 0;
  gifPixAsp:byte = 0;
  gifcolordepth:byte = 8;  // 8 bit = 256 colors
  gifncolors:integer = 256;
  gifLIDid:byte = $2C;
  HASHSIZE:integer = 5101;
  HASHBITS:integer = 4;
  TABLSIZE:integer = 4096;
  EMPTY:integer = -1;

var

F : integer;
Dbg : TextFile;
MapBM : TBitmap;
ImageWidth,ImageHeight:Integer;
buffer :array[0..255] of byte;
codes : array[0..5101] of Integer;
prefix: array[0..5101] of Integer;
suffix: array[0..5101] of Integer;
nBytes,nbits, size, cursize, curcode, maxcode : Integer;
BitmapSizeImage : Integer;
Started : Boolean;
minsize,maxsize,nroots,Capacity : Integer;
endc, clrc : Integer;
MinLZWCodeSize : Byte;
bytecode,bytemask :Integer;
counter : Integer;
strc,chrc :Integer;
ErrorMsg : string;

function SaveAsGif(InputBM : TBitmap; FName : string) : boolean;

implementation

function Putbyte(B,fh:Integer):Boolean;
begin
  Counter := counter + 1;
  buffer[nbytes] := B;
  Inc(nbytes);
  If nbytes = 255 then
  begin
    //ShowMessage('255');
    FileWrite(fh,nbytes,1);
    FileWrite(fh,buffer,nbytes);
    nbytes := 0;
  end;
  result := True;
end;

function PutCode(code, fh :Integer) : Boolean;
var
  temp,n,mask :Integer;
begin
  mask := 1;
  n := nbits;
  //If nbits > 11 then ShowMessage('nbits = 12');
  while n > 0 do
  begin
    dec(n);
    if ((code and mask)<>0) then bytecode := (bytecode or bytemask);
    bytemask := bytemask shl 1;
    if (bytemask > $80) then
    begin
      If PutByte(bytecode,fh) then
      begin
        bytecode := 0;
        bytemask := 1;
      end;
    end;
    mask := mask shl 1;
  end;
  result := True;
end;

procedure Flush(fh:Integer);
begin
  if bytemask <> 1 then
  begin
    PutByte(byteCode,fh);
    bytecode :=0;
    bytemask :=1;
  end;
  if nbytes > 0 then
  begin
    FileWrite(fh,nbytes,1);
    FileWrite(fh,buffer,nbytes);
    nbytes :=0;
  end;
end;
procedure ClearX;


var
  J : Integer;

begin
  cursize := minsize;
  nbits := cursize;
  curcode := endc + 1;
  maxcode := 1 shl cursize;
  for J := 0 to HASHSIZE do codes[J] := EMPTY;
end;
function findstr(pfx,sfx :Integer):integer;


var
  i,di : Integer;

begin
  i := (sfx shl HASHBITS) xor pfx;
  if i = 0 then di := 1 else di := Capacity -i;
  while True do
  begin
    if codes[i] = EMPTY then break;
    if ((prefix[i] = pfx) and (suffix[i] = sfx)) then break;
    i := i - di;
    if i < 0 then i := i + Capacity;
  end;
  Result := i;
end;

procedure EncodeScanLine(fh : Integer; var buf : Pbyte; npxls : Integer);
var
  np,I : Integer;

begin
  np := 0;
  if not Started then
  begin
    strc := buf^;
    Inc(np); Inc(buf);
    Started := True;
  end;
  while np < npxls do
  begin
    // If np = 3 then break;
    chrc := buf^;
    Inc(np); Inc(buf);
    I := findstr(strc,chrc);
    if codes[I] <> EMPTY then
      strc := codes[I]
    else
    begin
      codes[I] := curcode;
      prefix[I] := strc;
      suffix[I] := chrc;
      putcode(strc,fh);
      strc := chrc;
      Inc(curcode);
      if curcode > maxcode then
      begin
        Inc(cursize);
        if cursize > maxsize then
        begin
          putcode(clrc,fh);
          ClearX;
        end
        else
        begin
          nbits := cursize;
          maxcode := maxcode shl 1;
          if cursize = maxsize  then dec(maxcode);
        end;
      end;
    end;
  end;
end;
procedure Initialize(fh:integer);


var
  flags : Byte;

begin
  counter := 0;
  Started := False;
  size := 8;
  nbytes := 0;
  nbits := 8;
  bytecode := 0;
  bytemask := 1;
  Capacity := HASHSIZE;
  minsize := 9;
  maxsize := 12;
  nroots := 1 shl 8;
  clrc := nroots;
  endc := clrc + 1;
  MinLZWCodeSize := 8;
  ClearX;
  // Write the type
  FileWrite(fh,'GIF87a',6);
  // Write the GIF screen descriptor
  // Note: width > 255 is a two byte word!!
  FileWrite(fh,ImageWidth,2);
  FileWrite(fh,ImageHeight,2);
  flags := $80 or ((gifcolordepth-1)shl 4) or (gifcolordepth-1);
  FileWrite(fh,flags,1);
  FileWrite(fh,gifBGColor,1);
  FileWrite(fh,gifPixAsp,1);
end;
procedure WriteGif(fh : integer);


var
  F:TextFile;
  gifxLeft,gifyTop : word; //Must be 16 bit!!
  flags :Byte;
  K : Pointer;
  Test,J,M : Integer;
  scanLine, TempscanLine, Bits, PBits : PByte;

begin
  //Get the info from the Bitmap
  GetMem(K,(sizeof(TBitMapInfoHeader) + 4 * gifncolors));
  TBitmapInfo(K^).bmiHeader.biSize := sizeof(TBitMapInfoHeader);
  TBitmapInfo(K^).bmiHeader.biWidth := ImageWidth;
  TBitmapInfo(K^).bmiHeader.biHeight := ImageHeight;
  TBitmapInfo(K^).bmiHeader.biPlanes := 1;
  TBitmapInfo(K^).bmiHeader.biBitCount := 8;
  TBitmapInfo(K^).bmiHeader.biCompression := BI_RGB;
  TBitmapInfo(K^).bmiHeader.biSizeImage :=
  ((((TBitmapInfo(K^).bmiHeader.biWidth * TBitmapInfo(K^).bmiHeader.biBitCount)+31)
      and Not(31)) shr 3)*TBitmapInfo(K^).bmiHeader.biHeight;
  TBitmapInfo(K^).bmiHeader.biXPelsPerMeter := 0;
  TBitmapInfo(K^).bmiHeader.biYPelsPerMeter := 0;
  TBitmapInfo(K^).bmiHeader.biClrUsed := 0;
  TBitmapInfo(K^).bmiHeader.biClrImportant := 0;
  try
    GetMem(Bits,TBitmapInfo(K^).bmiHeader.biSizeImage);
    Test := GetDIBits(MapBM.Canvas.Handle,MapBM.Handle,0,ImageHeight,Bits,TBitmapInfo(K^),DIB_RGB_COLORS);
    If Test > 0 then
    begin
      for J := 0 to 255 do
      begin
        FileWrite(fh,TBitMapInfo(K^).bmiColors[J].rgbRed,1);
        FileWrite(fh,TBitMapInfo(K^).bmiColors[J].rgbGreen,1);
        FileWrite(fh,TBitMapInfo(K^).bmiColors[J].rgbBlue,1);
      end;
      //Write the Logical Image Descriptor
      FileWrite(fh,gifLIDid,1);
      gifxLeft := 0;  FileWrite(fh,gifxLeft,2); // Write X position of image
      gifyTop  := 0;  FileWrite(fh,gifyTop,2);  // Write Y position of image
      FileWrite(fh,ImageWidth,2);
      FileWrite(fh,ImageHeight,2);
      flags := 0; FileWrite(fh,flags,1); //Write Local flags 0=None
      //Write Min LZW code size = 8 (for 8 bit)
      MinLZWCodeSize := 8;
      FileWrite(fh,MinLZWCodesize,1);
      PutCode(clrc,fh);
      PBits := Bits;
      Inc(Pbits,(ImageWidth *(ImageHeight -1)));
      GetMem(scanLine,ImageWidth);
      TempscanLine := scanLine;
      For M := 0 to ImageHeight-1 do
      begin
        FillChar(scanLine^,ImageWidth,0);
        move(PBits^,scanLine^,ImageWidth);
        EncodeScanLine(fh,scanLine,ImageWidth);
        dec(scanLine,ImageWidth);
        Dec(PBits,ImageWidth);
      end;
    end;
  finally
    scanLine := TempscanLine;
    FreeMem(scanLine,ImageWidth);
    FreeMem(Bits,TBitMapInfo(K^).bmiHeader.biSizeImage);
    FreeMem(K,(sizeof(TBitMapInfoHeader) + 4 * gifncolors));
  end;
end;
function SaveAsGif(InputBM : TBitmap; FName : string) : boolean;


begin
  ErrorMsg := '';
  Result := FALSE;
  MapBM := InputBM;
  ImageWidth := MapBM.Width;
  ImageHeight := MapBM.Height;
  F := FileCreate(FName);
  if F >= 0 then
  begin
    Initialize(F);
    WriteGif(F);
    PutCode(strc,F);
    PutCode(endc,F);
    Flush(F);
    FileWrite(F,BlockTerminator,1);
    FileWrite(F,FileTrailer,1);
    FileClose(F);
    if length(ErrorMsg) = 0 then Result := TRUE;
  end;
end;
end.

Håber du kan bruge det til noget....

sorry, det er dk og ikke com
cybermikedk@yahoo.dk

Undskyld!

Men tak alligevel, jeg prøver og se om det dur.

Er det tp7?

Nej, det er egentlig ikke tp7, men Delphi... Meeeen det kan da være at det virker i tp7

Jeg er næsten 100% sikker på at det ikke virke i delphi.
Da et delphi unit ville aflevere billede i et TImage eller TPicture, og TP7 skulle skrive det til skærmen.

But anyway, jeg gir det et forsøg!

Jeg gir op!