procedure Chg24To16(Source, Dest: TBitmap); 
var 
  pbi: pBitmapInfo; 
  pSource: pRGBQuad; 
  hbmp: HBitmap; 
  x, y: Integer; 
  pDest: pWord; 
  p: Pointer; 
begin 
  Source.pixelformat := pf24bit; 
  pbi := AllocMem(sizeof(BITMAPINFO) + sizeof(DWord) * 3); 
  with pbi^.bmiHeader do 
  begin 
    biSize := sizeof(BITMAPINFOHEADER); 
    biPlanes := 1; 
    biBitCount := 16; 
    biWidth := Source.Width; 
    biHeight := Source.Height; 
    biCompression := BI_BITFIELDS; 
  end; 
  pWordArray(@(pbi^.bmiColors[0]))^[0] := 63488; 
  pWordArray(@(pbi^.bmiColors[0]))^[2] := 2016; 
  pWordArray(@(pbi^.bmiColors[0]))^[4] := 31; 
  hbmp := CreateDIBSection(0, pbi^, DIB_RGB_COLORS, p, 0, 0); 
  if hbmp <> HBITMAP(0) then 
    for y := 0 to Source.Height - 1 do 
    begin 
      pSource := pRGBQuad(Source.ScanLine[y]); 
      pDest := pWord(Integer(p) + 
        ((Source.Width * 2 + 3) and -4) 
        * (Source.Height - 1 - y)); 
      for x := 0 to Source.Width - 1 do 
      begin 
        pDest^ := (pSource^.rgbBlue shr 3) or ((pSource^.rgbGreen shr 2) shl 5) 
          or (DWord(pSource^.rgbRed shr 3) shl 11); 
        Inc(Integer(pSource), 3); 
        Inc(pDest); 
      end; 
    end; 
  Dest.handle := hbmp; 
  FreeMem(pbi); 
end; 
 
 
// Beispielaufruf 
 
procedure TForm1.Button5Click(Sender: TObject); 
begin 
  Chg24To16(Image1.picture.bitmap, Image2.picture.bitmap); 
end;