aceimg.pas

suite component ace report

    FBitmapInfo := nil;
  end;
  if FBitmapCoreInfo <> nil then
  begin
    FreeMem(FBitmapCoreInfo, FColorSize + SizeOf(TBitmapInfoHeader));
    FBitmapInfo := nil;
  end;
  if FPalette <> 0 then
  begin
    DeleteObject(FPalette);
    FPalette := 0;
  end;
  FDC := 0;
end;

procedure TAceBitmap.LoadFromStream(Stream: TStream);
begin
  Clear;
  if Stream <> nil then
  begin
    if Stream.Size > Stream.Position then
    begin
      { See if value bitmap header }
      Stream.Read(FBitmapFileHeader, Sizeof(FBitmapFileHeader));
      if FBitmapFileHeader.bfType = $4D42 then
      begin
        { copy entire bitmap }
        FBitmapStream.CopyFrom(Stream, Stream.Size - Sizeof(FBitmapFileHeader));
        FBitmapStream.Position := 0;
        InitBitmap;
      end;
    end;
  end;
end;

function GetDInColors(BitCount: Word): Integer;
begin
  case BitCount of
    1, 4, 8: Result := 1 shl BitCount;
  else
    Result := 0;
  end;
end;

procedure TAceBitmap.InitBitmap;
var
  Size: LongInt;
begin
  FBitmapStream.Read(Size, SizeOf(Size));
  FBitmapStream.Position := 0;
  if Size = SizeOf(FCoreHeader) then
  begin
    FBitmapStream.Read(FCoreHeader, SizeOf(FCoreHeader));
    FCoreHeader.bcSize := SizeOf(FCoreHeader);
    FMonochrome := (FCoreHeader.bcPlanes = 1) and (FCoreHeader.bcBitCount = 1);
    FBitmapType := abtPresMan;
    FColorSize := GetDInColors(FCoreHeader.bcBitCount) * SizeOf(TRGBTriple);
    FDIBBits := Pointer(Longint(FBitmapStream.Memory) +
                Sizeof(FCoreHeader) + FColorSize);

    FWidth := FCoreHeader.bcWidth;
    FHeight := FCoreHeader.bcHeight;

    CreateBitmapInfo;
  end
  else if Size = SizeOf(TBitmapInfoHeader) then
  begin
    FBitmapStream.Read(FInfoHeader, SizeOf(FInfoHeader));
    FInfoHeader.biSize := SizeOf(FInfoHeader);
    FMonochrome := (FInfoHeader.biPlanes = 1) and (FInfoHeader.biBitCount = 1);
    FBitmapType := abtWindows;
    if FInfoHeader.biClrUsed = 0 then
      FInfoHeader.biClrUsed := GetDInColors(FInfoHeader.biBitCount);
    FColorSize := FInfoHeader.biClrUsed * SizeOf(TRgbQuad);
    if ((FInfoHeader.biBitCount = 16) or (FInfoHeader.biBitCount = 32)) then
    begin
    {$ifdef WIN32}
      if FInfoHeader.biCompression = BI_BITFIELDS then
      begin
        Inc(FColorSize, 3 * SizeOf(DWord));
      end;
    {$else}
      if FInfoHeader.biCompression = 3 then
      begin
        Inc(FColorSize, 3 * 4);
      end;
    {$endif}
    end;

    FDIBBits := Pointer(Longint(FBitmapStream.Memory) +
                sizeof(FInfoHeader) + FColorSize);

    FWidth := FInfoHeader.biWidth;
    FHeight := FInfoHeader.biHeight;

    CreateBitmapInfo;
  end else Clear;
  FBitmapStream.Position := 0;
end;

procedure TAceBitmap.CreateBitmapInfo;
begin
  if FBitmapType = abtWindows then
  begin
    FBitmapInfo := AllocMem(FColorSize + SizeOf(TBitmapInfoHeader));

    with FBitmapInfo^ do
    begin
      bmiHeader := FInfoHeader;
      FBitmapStream.Read(bmiColors, FColorSize);
      with bmiHeader do
      begin
        FBitsSize := FBitmapStream.Size - (Sizeof(TBitmapInfoHeader)+FColorSize);
        if biSizeImage <> 0 then
          if biSizeImage < FBitsSize then FBitsSize := biSizeImage;
      end;
    end;
  end else if FBitmapType = abtPresMan then
  begin
    FBitmapCoreInfo := AllocMem(FColorSize + SizeOf(TBitmapCoreHeader));
    with FBitmapCoreInfo^ do
    begin
      bmciHeader := FCoreHeader;
      FBitmapStream.Read(bmciColors, FColorSize);
      with bmciHeader do
        FBitsSize := ((((bcWidth * bcBitCount) + 31) div 32) * 4) * bcHeight;
    end;
  end;
end;

procedure TAceBitmap.MakePalette;
begin
  case FBitmapType of
    abtWindows: CreateWinPalette;
    abtPresMan: CreatePMPalette;
  end;
end;

procedure TAceBitmap.CreateWinPalette;
var
  SysPalSize: LongInt;
  I: Integer;
  Size, Colors, Spot: Longint;
  DstPal: PLogPalette;
begin
  if (FPalette = 0) And (FDC <> 0) then
  begin
    Colors := FInfoHeader.biClrUsed;
    if Colors > 2 then
    begin
      Size := SizeOf(TLogPalette) + ((Colors - 1) * SizeOf(TPaletteEntry));
      DstPal := AllocMem(Size);
      try
        FillChar(DstPal^, Size, 0);
        with DstPal^ do
        begin
          palNumEntries := Colors;
          palVersion := $300;
          SysPalSize := GetDeviceCaps(FDC, SIZEPALETTE);
          if (Colors = 16) and (SysPalSize >= 16) then
          begin
            GetSystemPaletteEntries(FDC, 0, 8, palPalEntry);
            I := 8;
            GetSystemPaletteEntries(FDC, SysPalSize - I, I, palPalEntry[I]);
          end
          else
            for Spot := 0 to Colors - 1 do
            begin
              palPalEntry[Spot].peRed := FBitmapInfo^.bmiColors[Spot].rgbRed;
              palPalEntry[Spot].peGreen := FBitmapInfo^.bmiColors[Spot].rgbGreen;
              palPalEntry[Spot].peBlue := FBitmapInfo^.bmiColors[Spot].rgbBlue;
              palPalEntry[Spot].peFlags := 0;
            end;
        end;
        FPalette := CreatePalette(DstPal^);
      finally
        FreeMem(DstPal, Size);
      end;
    end;
  end;
end;

procedure TAceBitmap.CreatePMPalette;
var
  DstPal: PLogPalette;
  Size, Colors, Spot: Longint;
begin
  if (FPalette = 0) And (FDC <> 0) then
  begin
    Colors := GetDInColors(FCoreHeader.bcBitCount);
    if Colors <> 0 then
    begin
      Size := SizeOf(TLogPalette) + ((Colors - 1) * SizeOf(TPaletteEntry));
      DstPal := AllocMem(Size);
      FillChar(DstPal^, Size, 0);
      try
        with DstPal^ do
        begin
          palNumEntries := Colors;
          palVersion := $300;
          for Spot := 0 to Colors - 1 do
          begin
            palPalEntry[Spot].peRed := FBitmapCoreInfo^.bmciColors[Spot].rgbtRed;
            palPalEntry[Spot].peGreen := FBitmapCoreInfo^.bmciColors[Spot].rgbtGreen;
            palPalEntry[Spot].peBlue := FBitmapCoreInfo^.bmciColors[Spot].rgbtBlue;
            palPalEntry[Spot].peFlags := 0;
          end;
        end;
        FPalette := CreatePalette(DstPal^);
      finally
        FreeMem(DstPal, Size);
      end;
    end;
  end;
end;



procedure TAceBitmap.StretchDraw(hnd: THandle; Rect: TRect);
var
  SDC: THandle;
  OldPalette: HPalette;
begin
  OldPalette := 0;
  SDC := SaveDC(hnd);

  FDC := hnd;
  MakePalette;
  if not FMonochrome then SetStretchBltMode(hnd, STRETCH_DELETESCANS);

  if FPalette <> 0 then
  begin
    OldPalette := SelectPalette(hnd, FPalette, True);
    RealizePalette(hnd);
  end;

  if FBitmapType = abtWindows then
  begin
    with FBitmapInfo^.bmiHeader do
    begin
      StretchDIBits(hnd, rect.left, rect.top,
        rect.right - rect.left + 1,rect.bottom - rect.top + 1,
        0, 0, FInfoHeader.biWidth, FInfoHeader.biHeight, FDIBBits, FBitmapInfo^,
        DIB_RGB_COLORS, SRCCOPY);
    end;
  end else if FBitmapType = abtPresMan then
  begin
    with FBitmapCoreInfo^.bmciHeader do
    begin
      StretchDIBits(hnd, rect.left, rect.top,
        rect.right - rect.left + 1,rect.bottom - rect.top + 1,
        0, 0, FCoreHeader.bcWidth, FCoreHeader.bcHeight, FDIBBits, PBitmapInfo(FBitmapCoreInfo)^,
        DIB_RGB_COLORS, SRCCOPY);
    end;
  end;

  if FPalette <> 0 then SelectPalette(hnd, OldPalette, True);

  RestoreDC(hnd, SDC);
end;

procedure TAceBitmap.Draw(hnd: THandle; x,y: Integer);
begin
  StretchDraw(hnd, Bounds(x,y,GetWidth(hnd), GetHeight(hnd)));
end;

function TAceBitmap.GetHeight(Handle: THandle): Integer;
var
  yPixels: Integer;
begin
  Result := 0;
  yPixels := GetDeviceCaps(Handle, LOGPIXELSY);

  case FBitmapType of
    abtWindows:
    begin
     { // Convert pixles per meter to pixels per inch}
      Result := MulDiv(FInfoHeader.biYPelsPerMeter, 254, 10000);
      if Result = 0 then Result := FPixelsPerInch;
      Result := MulDiv(FHeight, yPixels, Result);
    end;
    abtPresMan: Result := MulDiv(FHeight, yPixels, FPixelsPerInch);
  end;
end;
function TAceBitmap.GetWidth(Handle: THandle): Integer;
var
  xPixels: Integer;
begin
  Result := 0;
  xPixels := GetDeviceCaps(Handle, LOGPIXELSX);

  case FBitmapType of
    abtWindows:
    begin
     { // Convert pixles per meter to pixels per inch}
      Result := MulDiv(FInfoHeader.biXPelsPerMeter, 254, 10000);
      if Result = 0 then Result := FPixelsPerInch;
      Result := MulDiv(FWidth, xPixels, Result);
    end;
    abtPresMan: Result := MulDiv(FWidth, xPixels, FPixelsPerInch);
  end;
end;



end.