unit1.pas

用delphi 显示不了256的图片,我是从相机中读的图片,搞了好久,终于搞定了.而且不失真.效果好极了.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
      procedure showthepic(picptr:PChar;tn:integer);
  end;

var
  Form1: TForm1;
  bmpptr:PChar;
  fs:File;
  Source: Integer; { handles }
  filename:string;
  FileLen:integer;
  hPalette1:HPALETTE;
implementation

{$R *.dfm}
procedure TForm1.showthepic(picptr:PChar;tn:integer);
var p_mem:PChar;
    tmpptr:PChar;
    p_bmi:PBITMAPINFOHEADER;
    p_bmi1:PBITMAPINFO;
    hBmp,pBmp:HBITMAP;
    dc,memdc:HDC;
    imagedata:PChar;
    p_bmf:PBITMAPFILEHEADER;
    bmMetric:BITMAP;
    pPal           :^LOGPALETTE;
     hPrevPalette   : HPALETTE;
  hPal           :HLOCAL;

     i:integer;
   lpRGB          :^RGBQUAD;
   NumColors      :DWORD;

begin

     p_mem:=picptr;
     Inc(p_mem,tn);
     p_bmf:=PBITMAPFILEHEADER(p_mem);

     tmpptr:=p_mem;
     Inc(tmpptr,14);  //bmp图片格式的起点

     p_bmi:=PBITMAPINFOHEADER(tmpptr);
     p_bmi1:=PBITMAPINFO(tmpptr);
     if(p_bmi^.biBitCount=8)then
     begin
     NumColors:=256;
      hPal:=LocalAlloc(LHND,sizeof(LOGPALETTE)+NumColors*sizeof(PALETTEENTRY));
        pPal:=LocalLock(hPal);
        pPal^.palNumEntries:=NumColors;
        pPal^.palVersion:=$300;
        lpRGB:=Pointer(LPSTR(picptr)+sizeof(BITMAPFILEHEADER)+sizeof(BITMAPINFOHEADER));
        for i:=0 to NumColors-1 do
        begin
             pPal^.palPalEntry[i].peRed:=lpRGB.rgbRed;
             pPal^.palPalEntry[i].peGreen:=lpRGB.rgbGreen;
             pPal^.palPalEntry[i].peBlue:=lpRGB.rgbBlue;
             pPal^.palPalEntry[i].peFlags:=0;
             lpRGB:=Pointer(LPSTR(lpRGB)+sizeof(TRGBQUAD));
        end;
        hPalette1:=CreatePalette(PLogPalette(@pPal)^);
        LocalUnlock(hPal);
        LocalFree(hPal);

     end;

     imagedata:=p_mem;
     Inc(imagedata,p_bmf.bfOffBits);
     dc:=Image1.Canvas.Handle;


     hBmp:=CreateDIBitmap(dc,p_bmi^,CBM_INIT,imagedata,
        p_bmi1^,DIB_RGB_COLORS);

     if(hBmp<>0)then
     begin
          GetObject(hBmp,sizeof(BITMAP),@bmMetric);
     end;

      memDC:=CreateCompatibleDC(dc);

      pBmp:=HBITMAP(SelectObject(memDC,hBmp));
      if hPalette1 <> 0 then
      begin
        SelectPalette(dc,hPalette1,FALSE);
        SelectPalette(memdc,hPalette1,FALSE);

     end;
      SetStretchBltMode(dc,HALFTONE);
      StretchBlt(dc,1,1,bmMetric.bmWidth div 2,bmMetric.bmHeight div 2,memDC,0,0,bmMetric.bmWidth,bmMetric.bmHeight,SRCCOPY);

      ReleaseDC(Form1.WindowHandle,dc);
      SelectObject(memDC,pBmp);

      DeleteDC(memDC);

      DeleteObject(hBmp);



end;

procedure TForm1.FormCreate(Sender: TObject);
var ByteRead:Integer;
    ReadPtr:PChar;
     CopyBuffer: Pointer; { buffer for copying }
const
  ChunkSize: Longint = 8192; { copy in 8K chunks }
begin
        filename:=ExtractFileDir(Application.ExeName)+'\test.bmp';
       GetMem(CopyBuffer, ChunkSize); { allocate the buffer }

        Source:=FileOpen(filename,fmShareDenyWrite);


        ByteRead:=0;
        FileLen:=0;
        repeat
                 ByteRead := FileRead(Source, CopyBuffer^, 8192); { read chunk }
                 FileLen:=ByteRead+FileLen;
        until    ByteRead<8192;

        bmpptr:=AllocMem(FileLen);
        ReadPtr:=bmpptr;
        FileSeek(Source,0,0);

        FileRead(Source,bmpptr^,FileLen);
        FileClose(Source);
        FreeMem(CopyBuffer, ChunkSize); { free the buffer }


end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
        FreeMem(bmpptr);

end;

procedure TForm1.Button1Click(Sender: TObject);
begin
     showthepic(bmpptr,0);
end;

end.