From: Biff Kadidlehopper <nospam1hunglo@earthling.net>
Subject: Here's some code to Get/Set BMP DPI
Date: 12 Jan 2000 00:00:00 GMT
Message-ID: <387CE2CA.76737CBE@earthling.net>
Content-Transfer-Encoding: 7bit
X-Accept-Language: en
Content-Type: text/plain; charset=us-ascii
Organization: Another Netscape Collabra Server User
Mime-Version: 1.0
Reply-To: nospam1hunglo@earthling.net
Newsgroups: borland.public.delphi.graphics

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;
          if Stream.Write(Data,2) = 2 then
          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;

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.

***************************************************
*Jim White    mailto:spamfree1hunglo@earthling.net
*Remove SPAMFREE from address to reply
***************************************************