How to get and set the DPI in a TBitmap

Problem/Question/Abstract:

How to get and set the DPI in a TBitmap

Answer:

I got tired of GetDIBits returning zero's in the BitmapInfoHeader XPelsPerMeter and YPelsPerMeter. The following unit allow you to get/set the dpi to a bitmap file or bitmap image.

As has been discussed previously, a bitmap doesn't really have a dpi as far as the screen is concerned, just a height and width. But the original dpi is indispensable for determining the original size or the scale of the original scan, as is necessary in a program I am working on right now.

The XPelsPerMeter and YPelsPerMeter are stored in 2 bytes each at an offset of 38(26h) and 42(2Ah), I don't know or care which one is at which address. These 2 values are virtually always the same. So in both of my 'Get' functions I just get the one at offset 38. When I set the dpi though, I write both. You can change this accordingly if you like.

There are 39.370079 In/Meter, so, dpi * 39.370079 = dots/meter (PelsPerMeter).


unit MyGraphic;

interface

uses
  SysUtils, Classes, Graphics, Dialogs;

function GetBMPFileDPI(FileName: string): LongInt;
procedure SetBMPFileDPI(FileName: string; DPI: Integer);
function GetBmpDPI(Bitmap: TBitmap): LongInt;
procedure SetBmpDPI(Bitmap: TBitmap; DPI: Integer);

implementation

function GetBMPFileDPI(FileName: string): LongInt;
var
  Stream: TFileStream;
  Data: Word;
  A: Double;
begin
  try
    Result := 0;
    Stream := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
    Stream.Position := 38;
    if Stream.Read(Data, 2) = 2 then
    begin
      A := Data;
      Result := Round(A / 39.370079);
    end;
  finally
    Stream.Free;
  end;
end;

procedure SetBMPFileDPI(FileName: string; DPI: Integer);
var
  Stream: TFileStream;
  Data: Word;
begin
  try
    Stream := TFileStream.Create(FileName, fmOpenWrite or fmShareExclusive);
    Data := Round(DPI * 39.370079);
    Stream.Position := 38;
    if Stream.Write(Data, 2) = 2 then
    begin
      Stream.Position := 42;
    end
    else
      {Error writing to Stream...}
      ShowMessage('Error writing to Stream. Data not written.');
  finally
    Stream.Free;
  end;
end;

function GetBmpDPI(Bitmap: TBitmap): LongInt;
var
  Stream: TMemoryStream;
  Data: Word;
  A: Double;
begin
  try
    Result := 0;
    Stream := TMemoryStream.Create;
    Bitmap.SaveToStream(Stream);
    Stream.Position := 38;
    if Stream.Read(Data, 2) = 2 then
    begin
      A := Data;
      Result := Round(A / 39.370079);
    end;
  finally
    Stream.Free;
  end;
end;

procedure SetBmpDPI(Bitmap: TBitmap; DPI: Integer);
var
  Stream: TMemoryStream;
  Data: Word;
begin
  try
    Stream := TMemoryStream.Create;
    Bitmap.SaveToStream(Stream);
    Data := Round(DPI * 39.370079);
    Stream.Position := 38;
    if Stream.Write(Data, 2) = 2 then
    begin
      Stream.Position := 42;
      if Stream.Write(Data, 2) = 2 then
      begin
        Stream.Position := 0;
        Bitmap.LoadFromStream(Stream);
      end
      else
        {Error writing to Stream...}
        ShowMessage('Error writing to Stream. Data not written.');
    end
    else
      {Error writing to Stream...}
      ShowMessage('Error writing to Stream. Data not written.');
  finally
    Stream.Free;
  end;
end;

end.