freebitmap.pas

对gif

  Data := GlobalLock(HMem);

  // get a pointer to the bitmap header
  bmih := PBitmapInfoHeader(Data);

  // get a pointer to the palette
  if bmih.biBitCount < 16 then
  begin
    Palette := PRGBQUAD(bmih);
    Inc(PByte(Palette), SizeOf(BITMAPINFOHEADER));
  end;

  // get a pointer to the pixels
  Bits := PByte(bmih);
  Inc(Bits, SizeOf(BITMAPINFOHEADER) + SizeOF(RGBQUAD) * bmih.biClrUsed);

  if bmih.biCompression = BI_BITFIELDS then
  begin
    // take into account the color masks that specify the red, green and blue
    // components (16- and 32-bit)
    MaskSize := 3 * SizeOf(DWORD);
    CopyMemory(@BitFields[0], Bits, MaskSize);
    Inc(Bits, MaskSize);
  end;

  if Data <> nil then
  begin
    image_type := FIT_BITMAP;

    case GetFreeImageMarker(bmih) of
      FIT_UINT16..FIT_RGBAF: image_type := GetFreeImageMarker(bmih);
    end;

    // allocate a new FIBITMAP
    if not SetSize(image_type, bmih.biWidth, bmih.biHeight, bmih.biBitCount,
                   BitFields[2], BitFields[1], BitFields[0]) then
    begin
      GlobalUnlock(HMem);
      Exit;
    end;

    // copy the bitmap header
    CopyMemory(FreeImage_GetInfoHeader(Dib), bmih, SizeOf(BITMAPINFOHEADER));

    // copy the palette
    CopyMemory(FreeImage_GetPalette(Dib), Palette, bmih.biClrUsed * SizeOf(RGBQUAD));

    // copy the bitmap
    CopyMemory(FreeImage_GetBits(Dib), Bits, FreeImage_GetPitch(Dib) * FreeImage_GetHeight(Dib));

    GlobalUnlock(HMem);
  end;
end;

function TFreeWinBitmap.CopyToBitmapH: HBITMAP;
var DC : HDC;
begin
  Result:=0;
  if IsValid then
  begin
    DC:=GetDC(0);
    Result:=CreateDIBitmap(DC,
                           FreeImage_GetInfoHeader(Dib)^,
                           CBM_INIT,
                           PAnsiChar(FreeImage_GetBits(Dib)),
                           FreeImage_GetInfo(Dib^)^,
                           DIB_RGB_COLORS);
    ReleaseDC(0,DC);
  end;
end;

function TFreeWinBitmap.CopyToClipBoard(NewOwner: HWND): Boolean;
var
  HDib: THandle;
begin
  Result := False;
  HDib := CopyToHandle;

  if OpenClipboard(NewOwner) and EmptyClipboard then
  begin
    if SetClipboardData(CF_DIB, HDib) = 0 then
    begin
      MessageBox(NewOwner, 'Unable to set clipboard data', 'FreeImage', MB_ICONERROR);
      CloseClipboard;
      Exit;
    end;
  end;
  CloseClipboard;
  Result := True;
end;

function TFreeWinBitmap.CopyToHandle: THandle;
var
  DibSize: Longint;
  ADib, pdib: PByte;
  bmih: PBITMAPINFOHEADER;
  Pal: PRGBQuad;
  Bits: PByte;
begin
  Result := 0;
  if IsValid then
  begin
    // get equivalent DIB size
    DibSize := SizeOf(BITMAPINFOHEADER);
    Inc(DibSize, FreeImage_GetColorsUsed(Dib) * SizeOf(RGBQUAD));
    Inc(DibSize, FreeImage_GetPitch(Dib) * FreeImage_GetHeight(Dib));

    // allocate a DIB
    Result := GlobalAlloc(GHND, DibSize);
    ADib := GlobalLock(Result);

    pdib := ADib;

    // copy the BITMAPINFOHEADER
    bmih := FreeImage_GetInfoHeader(Dib);
    CopyMemory(pdib, bmih, SizeOf(BITMAPINFOHEADER));
    Inc(pdib, SizeOf(BITMAPINFOHEADER));
    if FreeImage_GetImageType(Dib) <> FIT_BITMAP then
      SetFreeImageMarker(bmih, FDib);

    // copy the palette
    Pal := FreeImage_GetPalette(Dib);
    CopyMemory(pdib, Pal, FreeImage_GetColorsUsed(Dib) * SizeOf(RGBQUAD));
    Inc(pdib, FreeImage_GetColorsUsed(Dib) * SizeOf(RGBQUAD));

    // copy the bitmap
    Bits := FreeImage_GetBits(Dib);
    CopyMemory(pdib, Bits, FreeImage_GetPitch(Dib) * FreeImage_GetHeight(Dib));

    GlobalUnlock(Result);
  end;
end;

constructor TFreeWinBitmap.Create(ImageType: FREE_IMAGE_TYPE; Width,
  Height, Bpp: Integer);
begin
  inherited Create(ImageType, Width, Height, Bpp);

  FDisplayDib := nil;
  FDeleteMe := False;
end;

destructor TFreeWinBitmap.Destroy;
begin
  if FDeleteMe then
    FreeImage_Unload(FDisplayDib);
  inherited;
end;

procedure TFreeWinBitmap.Draw(DC: HDC; Rect: TRect);
begin
  DrawEx(DC, Rect);
end;

procedure TFreeWinBitmap.DrawEx(DC: HDC; Rect: TRect; UseFileBkg: Boolean;
  AppBkColor: PRGBQuad; Bg: PFIBITMAP);
var
  ImageType: FREE_IMAGE_TYPE;
  HasBackground, Transparent: Boolean;
  DibDouble: PFIBITMAP;
begin
  if not IsValid then Exit;
  
  // convert to standard bitmap if needed
  if FDeleteMe then
  begin
    FreeImage_Unload(FDisplayDib);
    FDisplayDib := nil;
    FDeleteMe := False;
  end;

  ImageType := FreeImage_GetImageType(FDib);
  if ImageType = FIT_BITMAP then
  begin
    HasBackground := FreeImage_HasBackgroundColor(Dib);
    Transparent := FreeImage_IsTransparent(Dib);

    if not Transparent and not HasBackground then
      // copy pointer
      FDisplayDib := Dib
    else
    begin
      // create the transparent / alpha blended image
      FDisplayDib := FreeImage_Composite(Dib, UseFileBkg, AppBkColor, Bg);
      // remember to delete FDisplayDib
      FDeleteMe := True;
    end
  end
  else
  begin
    // convert to standard dib for display
    if ImageType <> FIT_COMPLEX then
      FDisplayDib := FreeImage_ConvertToStandardType(Dib, True)
    else
    begin
      // convert to type FIT_DOUBLE
      DibDouble := FreeImage_GetComplexChannel(Dib, FICC_MAG);
      FDisplayDib := FreeImage_ConvertToStandardType(DibDouble, True);
      // free image of type FIT_DOUBLE
      FreeImage_Unload(DibDouble);
    end;
    // remember to delete FDisplayDib
    FDeleteMe := True;
  end;

  // Draw the DIB
  SetStretchBltMode(DC, COLORONCOLOR);
  StretchDIBits(DC, Rect.Left, Rect.Top,
    Rect.Right - Rect.Left, Rect.Bottom - Rect.Top,
    0, 0, FreeImage_GetWidth(FDisplayDib), FreeImage_GetHeight(FDisplayDib),
    FreeImage_GetBits(FDisplayDib), FreeImage_GetInfo(FDisplayDib^)^, DIB_RGB_COLORS, SRCCOPY);
end;

function TFreeWinBitmap.PasteFromClipBoard: Boolean;
var
  HDib: THandle;
begin
  Result := False;
  if not IsClipboardFormatAvailable(CF_DIB) then Exit;

  if OpenClipboard(0) then
  begin
    HDib := GetClipboardData(CF_DIB);
    CopyFromHandle(HDib);
    Result := True;
  end;
  CloseClipboard;
end;

{ TFreeMultiBitmap }

procedure TFreeMultiBitmap.AppendPage(Bitmap: TFreeBitmap);
begin
  if IsValid then
    FreeImage_AppendPage(FMPage, Bitmap.FDib);
end;

function TFreeMultiBitmap.Close(Flags: Integer): Boolean;
begin
  Result := FreeImage_CloseMultiBitmap(FMPage, Flags);
  FMPage := nil;
end;

constructor TFreeMultiBitmap.Create(KeepCacheInMemory: Boolean);
begin
  inherited Create;
  FMemoryCache := KeepCacheInMemory;
end;

procedure TFreeMultiBitmap.DeletePage(Page: Integer);
begin
  if IsValid then
    FreeImage_DeletePage(FMPage, Page);
end;

destructor TFreeMultiBitmap.Destroy;
begin
  if FMPage <> nil then Close;
  inherited;
end;

function TFreeMultiBitmap.GetLockedPageNumbers(var Pages,
  Count: Integer): Boolean;
begin
  Result := False;
  if not IsValid then Exit;
  Result := FreeImage_GetLockedPageNumbers(FMPage, Pages, Count)
end;

function TFreeMultiBitmap.GetPageCount: Integer;
begin
  Result := 0;
  if IsValid then
    Result := FreeImage_GetPageCount(FMPage)
end;

procedure TFreeMultiBitmap.InsertPage(Page: Integer; Bitmap: TFreeBitmap);
begin
  if IsValid then
    FreeImage_InsertPage(FMPage, Page, Bitmap.FDib);
end;

function TFreeMultiBitmap.IsValid: Boolean;
begin
  Result := FMPage <> nil
end;

procedure TFreeMultiBitmap.LockPage(Page: Integer; DestBitmap: TFreeBitmap);
begin
  if not IsValid then Exit;

  if Assigned(DestBitmap) then
  begin
    DestBitmap.Replace(FreeImage_LockPage(FMPage, Page));
  end;
end;

function TFreeMultiBitmap.MovePage(Target, Source: Integer): Boolean;
begin
  Result := False;
  if not IsValid then Exit;
  Result := FreeImage_MovePage(FMPage, Target, Source);
end;

function TFreeMultiBitmap.Open(const FileName: string; CreateNew,
  ReadOnly: Boolean; Flags: Integer): Boolean;
var
  fif: FREE_IMAGE_FORMAT;
begin
  Result := False;

  // try to guess the file format from the filename
  fif := FreeImage_GetFIFFromFilename(PChar(FileName));

  // check for supported file types
  if (fif <> FIF_UNKNOWN) and (not fif in [FIF_TIFF, FIF_ICO, FIF_GIF]) then
    Exit;

  // open the stream
  FMPage := FreeImage_OpenMultiBitmap(fif, PChar(FileName), CreateNew, ReadOnly, FMemoryCache, Flags);

  Result := FMPage <> nil;  
end;

procedure TFreeMultiBitmap.UnlockPage(Bitmap: TFreeBitmap;
  Changed: Boolean);
begin
  if IsValid then
  begin
    FreeImage_UnlockPage(FMPage, Bitmap.FDib, Changed);
    // clear the image so that it becomes invalid.
    // don't use Bitmap.Clear method because it calls FreeImage_Unload
    // just clear the pointer
    Bitmap.FDib := nil;
    Bitmap.Change;
  end;
end;

{ TFreeMemoryIO }

function TFreeMemoryIO.Acquire(var Data: PByte;
  var SizeInBytes: DWORD): Boolean;
begin
  Result := FreeImage_AcquireMemory(FHMem, Data, SizeInBytes);
end;

constructor TFreeMemoryIO.Create(Data: PByte; SizeInBytes: DWORD);
begin
  inherited Create;
  FHMem := FreeImage_OpenMemory(Data, SizeInBytes);
end;

destructor TFreeMemoryIO.Destroy;
begin
  FreeImage_CloseMemory(FHMem);
  inherited;
end;

function TFreeMemoryIO.GetFileType: FREE_IMAGE_FORMAT;
begin
  Result := FreeImage_GetFileTypeFromMemory(FHMem);
end;

function TFreeMemoryIO.IsValid: Boolean;
begin
  Result := FHMem <> nil
end;

function TFreeMemoryIO.Read(fif: FREE_IMAGE_FORMAT;
  Flag: Integer): PFIBITMAP;
begin
  Result := FreeImage_LoadFromMemory(fif, FHMem, Flag)
end;

function TFreeMemoryIO.Seek(Offset: Longint; Origin: Word): Boolean;
begin
  Result := FreeImage_SeekMemory(FHMem, Offset, Origin)
end;

function TFreeMemoryIO.Tell: Longint;
begin
  Result := FreeImage_TellMemory(FHMem)
end;

function TFreeMemoryIO.Write(fif: FREE_IMAGE_FORMAT; dib: PFIBITMAP;
  Flag: Integer): Boolean;
begin
  Result := FreeImage_SaveToMemory(fif, dib, FHMem, Flag)
end;

{ TFreeTag }

function TFreeTag.Clone: TFreeTag;
var
  CloneTag: PFITAG;
begin
  Result := nil;
  if not IsValid then Exit;

  CloneTag := FreeImage_CloneTag(FTag);
  Result := TFreeTag.Create(CloneTag);
end;

constructor TFreeTag.Create(ATag: PFITAG);
begin
  inherited Create;

  if ATag <> nil then
    FTag := ATag
  else
    FTag := FreeImage_CreateTag;
end;

destructor TFreeTag.Destroy;
begin
  if IsValid then
    FreeImage_DeleteTag(FTag);
    
  inherited;
end;

function TFreeTag.GetCount: Cardinal;
begin
  Result := 0;
  if not IsValid then Exit;

  Result := FreeImage_GetTagCount(FTag);
end;

function TFreeTag.GetDescription: string;
begin
  Result := '';
  if not IsValid then Exit;

  Result := FreeImage_GetTagDescription(FTag);
end;

function TFreeTag.GetID: Word;
begin
  Result := 0;
  if not IsValid then Exit;

  Result := FreeImage_GetTagID(FTag);
end;

function TFreeTag.GetKey: string;
begin
  Result := '';
  if not IsValid then Exit;

  Result := FreeImage_GetTagKey(FTag);
end;

function TFreeTag.GetLength: Cardinal;
begin
  Result := 0;
  if not IsValid then Exit;

  Result := FreeImage_GetTagLength(FTag);
end;

function TFreeTag.GetTagType: FREE_IMAGE_MDTYPE;
begin
  Result := FIDT_NOTYPE;
  if not IsValid then Exit;

  Result := FreeImage_GetTagType(FTag);
end;

function TFreeTag.GetValue: Pointer;
begin
  Result := nil;
  if not IsValid then Exit;

  Result := FreeImage_GetTagValue(FTag);
end;

function TFreeTag.IsValid: Boolean;
begin
  Result := FTag <> nil;
end;

procedure TFreeTag.SetCount(const Value: Cardinal);
begin
  if IsValid then
    FreeImage_SetTagCount(FTag, Value);
end;

procedure TFreeTag.SetDescription(const Value: string);
begin
  if IsValid then
    FreeImage_SetTagDescription(FTag, PChar(Value));
end;

procedure TFreeTag.SetID(const Value: Word);
begin
  if IsValid then
    FreeImage_SetTagID(FTag, Value);
end;

procedure TFreeTag.SetKey(const Value: string);
begin
  if IsValid then
    FreeImage_SetTagKey(FTag, PChar(Value));
end;

procedure TFreeTag.SetLength(const Value: Cardinal);
begin
  if IsValid then
    FreeImage_SetTagLength(FTag, Value);
end;

procedure TFreeTag.SetTagType(const Value: FREE_IMAGE_MDTYPE);
begin
  if IsValid then
    FreeImage_SetTagType(FTag, Value);
end;

procedure TFreeTag.SetValue(const Value: Pointer);
begin
  if IsValid then
    FreeImage_SetTagValue(FTag, Value);
end;

function TFreeTag.ToString(Model: FREE_IMAGE_MDMODEL; Make: PChar): string;
begin
  Result := FreeImage_TagToString(Model, FTag, Make);
end;

end.