Delphi TGIFImage animation issue with some GIF viewers - delphi

I have discovered that animated GIFs created using Delphi 2009's TGIFImage sometimes doesn't play correctly in some GIF viewers. The problem is that the animation is restarted prematurely.
Consider the following example:
program GIFAnomaly;
{$APPTYPE CONSOLE}
uses
Windows, Types, Classes, SysUtils, Graphics, GIFImg;
var
g: TGIFImage;
bm: TBitmap;
procedure MakeFrame(n: integer);
var
x: Integer;
y: Integer;
begin
for x := 0 to 256 - 1 do
for y := 0 to 256 - 1 do
bm.Canvas.Pixels[x, y] := RGB((x + n) mod 255,
(x + y - 2*n) mod 255, (x*y*n div 500) mod 255);
end;
var
i: integer;
begin
bm := TBitmap.Create;
bm.SetSize(256, 256);
g := TGIFImage.Create;
g.Animate := true;
for i := 0 to 499 do
begin
MakeFrame(i);
TGIFGraphicControlExtension.Create(g.Add(bm)).Delay := 3;
Writeln('Creating frame ', i+1, ' of 500.');
end;
TGIFAppExtNSLoop.Create(g.Images.Frames[0]).Loops := 0;
g.SaveToFile('C:\Users\Andreas Rejbrand\Desktop\test.gif');
end.
(This is the simplest example I could find that exhibits the problem.)
The output is a rather large animated GIF. In Internet Explorer 11, the entire 15-second 'movie' is played properly, but in Google Chrome the 'movie' is prematurely restarted after only about four seconds.
Why is this?
Is there something wrong with the output GIF file?
If so, is there something wrong with my code above, or is there a problem with GIFImg?
If not, what is the nature of the problem in the viewer? What fraction of the available viewers have this problem? Is there a way to 'avoid' this problem during GIF creation?
For the benefit of the SO user, the above code is a minimal working example. Of course, I wasn't creating these psychedelic patterns when I discovered the issue. Instead, I was working on a Lorenz system simulator, and produced this GIF animation which does play in IE but not in Chrome:
In Internet Explorer 11, the model is rotated 360 degrees before the animation is restarted. In Google Chrome, the animation is restarted prematurely after only some 20 degrees.
The Lorenz image works in Internet Explorer 11.0.9600.17239, The GIMP 2.8.0, Opera 12.16
The Lorenz image does not work in Google Chrome 36.0.1985.143 m, Firefox 26.0, 27.0.1, 31.0.
If I open a 'problematic' GIF in The GIMP and let GIMP (re)save it as an animated GIF, the result works in every viewer. The following is the GIMPed version of the Lorenz animation:
Comparing the two files using a hex editor, and using the Wikipedia article as a reference, it seems, for instance, like the 'NETSCAPE' string is at the wrong place in the original (unGIMPed) version. It is somewhat strange, that even if I set the width and height of the GIF image, the corresponding values in the Logical Screen Descriptor are not there.

It's a bug in TGIFImage's LZW encoder.
In some very rare circumstances the LZW encoder will output an extra zero byte at the end of the LZW steam. Since the LZW end block marker is also a zero byte, a strict GIF reader might choke on this or interpret it as the end of the GIF (although the end of file marker is $3B).
The reason some GIF readers can handle this is probably that GIFs with this problem was common many years ago. Apparently TGIFImage wasn't the only library to make that particular mistake.
To fix the problem make the following modification to gifimg.pas (change marked with *):
procedure TGIFWriter.FlushBuffer;
begin
if (FNeedsFlush) then
begin
FBuffer[0] := Byte(FBufferCount-1); // Block size excluding the count
Stream.WriteBuffer(FBuffer, FBufferCount);
FBufferCount := 1; // Reserve first byte of buffer for length
FNeedsFlush := False; // *** Add this ***
end;
end;

Edit: This turned out not to be the answer but I'm keeping it as the rule about the loop extension still applies.
The NETSCAPE loop extension must be the first extension:
var
Frame: TGIFFrame;
...
for i := 0 to 499 do
begin
MakeFrame(i);
Frame := g.Add(bm);
if (i = 0) then
TGIFAppExtNSLoop.Create(Frame).Loops := 0;
TGIFGraphicControlExtension.Create(Frame).Delay := 3;
Writeln('Creating frame ', i+1, ' of 500.');
end;
See: The TGIFImage FAQ.
Apart from that I see nothing wrong with your GIF, but you could reduce the size a bit with a global color table.

Related

How to draw FMX.Surface.TBitmapSurface on FMX.Graphics.TBitmap

Follwing on:
How to load large bitmap in FMX (fire monkey)
I have come to a need to draw whats on TBitmapSurface on the FMX.Graphics.TBitmap, i have found a lot of answer regarding this on the web, but they are either in VLC instead of FMX or their goal is saving and loading instead of drawing on a TBitmap, which is why i asked a new question here.
Now here is my current code for loading my image on the TBitmapSurface :
var
bitmapSurf: TBitmapSurface;
path: string;
begin
path := 'image.jpg';
bitmapSurf := TBitmapSurface.Create;
TBitmapCodecManager.LoadFromFile(path, bitmapSurf);
end;
Now after searching for a bit i found that i can use Scanline on the TBitmapSurface, but i didn't know how to use it to draw on the TBitmap, on the web some people had used TBitmap.canvas.draw, but such a thing doesn't exist on the FMX!.
In the end my goal is to draw a very large image (1000*16000) which is loaded in the TBitmapSurface on more then 1 TBitmap (because TBitmap doesn't support more then 8192px and my height is 16000px, i need to draw this on two TBitmap).
I am using Delphi 10.2.3.
Thanks.
You can split the large image (from a file) to two TImage components as follows
Load the image from file to a TBitmapSurface as you already do in your code.
Then create another TBitmapSurface and set its size to the half of the large one. Copy the first half of the large image to this surface and assign it to Image1.Bitmap. Then copy the latter half to this surface and assign that to Image2.Bitmap.
var
srce, dest: TBitmapSurface;
path: string;
scan: integer;
w, h1, h2: integer;
begin
path := 'C:\tmp\Imgs\res.bmp';
srce := TBitmapSurface.Create;
try
TBitmapCodecManager.LoadFromFile(path, srce);
dest := TBitmapSurface.Create;
try
// first half
w := srce.Width;
h1 := srce.Height div 2;
dest.SetSize(w, h1, TPixelFormat.RGBA);
for scan := 0 to h1-1 do
Move(srce.Scanline[scan]^, TBitmapSurface(dest).Scanline[scan]^, srce.Width * 4);
Image1.Bitmap.Assign(dest);
// second half
h2 := srce.Height - h1;
dest.SetSize(w, h2, TPixelFormat.RGBA);
for scan := h1 to srce.Height-1 do
Move(srce.Scanline[scan]^, TBitmapSurface(dest).Scanline[scan-h1]^, srce.Width * 4);
Image2.Bitmap.Assign(dest);
finally
dest.Free;
end;
finally
srce.Free;
end;

Comparing Bmp, JPEG, PNG, TIF files

I need a e method which compares content of two files together, files can be BMP, JPEG, PNG, TIF
I tried this
procedure TForm1.Button1Click(Sender: TObject);
var
f1, f2 : TFileStream;
Bytes1: TBytes;
Bytes2: TBytes;
i: integer;
s: booleAN;
begin
f1 := TFileStream.Create('C:\Output\Layout 1.JPG' , fmOpenRead);
f2 := TFileStream.Create('C:\Data\Layout 1.JPG' , fmOpenRead );
if f1.Size <> f2.Size then
begin
ShowMessage('size');
exit;
end;
SetLength(Bytes1, f1.Size);
f1.Read(Bytes1[0], f1.Size);
SetLength(Bytes2, f2.Size);
f2.Read(Bytes2[0], f2.Size);
s:= true;
for I := 1 to length(Bytes1) do
begin
if Bytes1[i] <> Bytes2[i] then
begin
s := false;
Exit;
end;
end;
if s then
ShowMessage('same');
end;
but this is not working fine for me my files are both the same in content but their size are different in 2 byte.
one of the files is the on that I have to give to user the other one is the files that user is opening the same file and make a copy of it, so why they are 2 byte different i have no idea but they should be away to compare content of these files
The code has one error. Dynamic arrays are zero based so the loop should be:
for I := 0 to high(Bytes1) do
The code is very inefficient. It should not read all the content at once. And you should use CompareMem to compare blocks of memory.
You say that the files have different size, but you expect them to compare equal. Well, that makes no sense. Your code explicitly checks that the sizes match, as it should.
Opening and reading a JPEG file will modify the content because JPEG is a lossy compression algorithm.
Your subject suggests that you wish to compare PowerPoint files but the files are in fact JPEG images.
If you are going to compare JPEGs you probably need to include a range, something like
Const
DELTA = 2 ;
if (Bytes1[i] - Bytes2[i] > DELTA) OR (Bytes1[i] - Bytes2[i] < -DELTA) then

Is there a limitation on dimensions of Windows Metafiles?

I'm creating some .wmf files, but some of them seem corrupted and can't be shown in any metafile viewer. After some trial and error, I found that the problem is caused by their dimensions. If I scale the same drawing by a factor to reduce the dimensions, it will be shown.
Now, I want to know if there's a limitation on the size of drawing or if the problem is something else. I know that these files have a 16-bit data structure, so I guess that the limitation would be 2^16 units in each dimension, (or 2^15 if it's signed). But in my tests it is around 25,000. So I can't rely on this value since the limitation can be on anything (Width*Height maybe, or maybe the resolution of the drawing may affect it). I can't find a reliable resource about .wmf files that describes this.
Here is sample code that shows the problem:
procedure DrawWMF(const Rect: TRect; const Scale: Double; FileName: string);
var
Metafile: TMetafile;
Canvas: TMetafileCanvas;
W, H: Integer;
begin
W := Round(Rect.Width * Scale);
H := Round(Rect.Height * Scale);
Metafile := TMetafile.Create;
Metafile.SetSize(W, H);
Canvas := TMetafileCanvas.Create(Metafile, 0);
Canvas.LineTo(W, H);
Canvas.Free;
Metafile.SaveToFile(FileName);
Metafile.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
const
Dim = 40000;
begin
DrawWMF(Rect(0, 0, Dim, Dim), 1.0, 'Original.wmf');
DrawWMF(Rect(0, 0, Dim, Dim), 0.5, 'Scaled.wmf');
try
Image1.Picture.LoadFromFile('Original.wmf');
except
Image1.Picture.Assign(nil);
end;
try
Image2.Picture.LoadFromFile('Scaled.wmf');
except
Image2.Picture.Assign(nil);
end;
end;
PS: I know that setting Metafile.Enhanced to True and saving it as an .emf file will solve the problem, but the destination application that I'm generating files for doesn't support Enhanced Metafiles.
Edit:
As mentioned in answers below, there are two different problems here:
The main problem is about the file itself, it has a 2^15 limitation on each dimension. If either width or height of the drawing overpasses this value, delphi will write a corrupted file. You can find more details in Sertac's answer.
The second problem is about loading the file in a TImage. There's another limitation when you want to show the image in a delphi VCL application. This one is system dependent and is related to dpi of DC that the drawing is going to be painted on. Tom's answer describes this in details. Passing 0.7 as Scale to DrawWMF (code sample above) reproduces this situation on my PC. The generated file is OK and can be viewed with other Metafile viewers (I use MS Office Picture Manager) but VCL fails to show it, however, no exception is raised while loading the file.
Your limit is 32767.
Tracing VCL code, the output file gets corrupt in TMetafile.WriteWMFStream. VCL writes a WmfPlaceableFileHeader (TMetafileHeader in VCL) record and then calls GetWinMetaFileBits to have 'emf' records converted to 'wmf' records. This function fails if any of the dimensions of the bounding rectangle (used when calling CreateEnhMetaFile) is greater than 32767. Not checking the return value, VCL does not raise any exception and closes the file with only 22 bytes - having only the "placeable header".
Even for dimensions less than 32767, the "placeable header" may have possible wrong values (read details about the reason and implications from Tom's answer and comments to the answer), but more on this later...
I used the below code to find the limit. Note that GetWinMetaFileBits does not get called with an enhanced metafile in VCL code.
function IsDimOverLimit(W, H: Integer): Boolean;
var
Metafile: TMetafile;
RefDC: HDC;
begin
Metafile := TMetafile.Create;
Metafile.SetSize(W, H);
RefDC := GetDC(0);
TMetafileCanvas.Create(Metafile, RefDC).Free;
Result := GetWinMetaFileBits(MetaFile.Handle, 0, nil, MM_ANISOTROPIC, RefDC) > 0;
ReleaseDC(0, RefDC);
Metafile.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
begin
for i := 20000 to 40000 do
if not IsDimOverLimit(100, i) then begin
ShowMessage(SysErrorMessage(GetLastError)); // ReleaseDc and freeing meta file does not set any last error
Break;
end;
end;
The error is a 534 ("Arithmetic result exceeded 32 bits"). Obviously there's some signed integer overflow. Some 'mf3216.dll' ("32-bit to 16-bit Metafile Conversion DLL") sets the error during a call by GetWinMetaFileBits to its exported ConvertEmfToWmf function, but that doesn't lead to any documentation regarding the overflow. The only official documentation regarding wmf limitations I can find is this (its main point is "use wmf only in 16 bit executables" :)).
As mentioned earlier, the bogus "placeable header" structure may have "bogus" values and this may prevent the VCL from correctly playing the metafile. Specifically, dimensions of the metafile, as the VCL know them, may overflow. You may perform a simple sanity check after you have loaded the images for them to be displayed properly:
var
Header: TEnhMetaHeader;
begin
DrawWMF(Rect(0, 0, Dim, Dim), 1.0, 'Original.wmf');
DrawWMF(Rect(0, 0, Dim, Dim), 0.5, 'Scaled.wmf');
try
Image1.Picture.LoadFromFile('Original.wmf');
if (TMetafile(Image1.Picture.Graphic).Width < 0) or
(TMetafile(Image1.Picture.Graphic).Height < 0) then begin
GetEnhMetaFileHeader(TMetafile(Image1.Picture.Graphic).Handle,
SizeOf(Header), #Header);
TMetafile(Image1.Picture.Graphic).Width := MulDiv(Header.rclFrame.Right,
Header.szlDevice.cx, Header.szlMillimeters.cx * 100);
TMetafile(Image1.Picture.Graphic).Height := MulDiv(Header.rclFrame.Bottom,
Header.szlDevice.cy, Header.szlMillimeters.cy * 100);
end;
...
When docs don't help, look at the source :). The file creation fails if the either width or height is too big, and the file becomes invalid. In the following I look at the horizontal dimension only, but the vertical dimension is treated the same.
In Vcl.Graphics:
constructor TMetafileCanvas.CreateWithComment(AMetafile : TMetafile;
ReferenceDevice: HDC; const CreatedBy, Description: String);
FMetafile.MMWidth := MulDiv(FMetafile.Width,
GetDeviceCaps(RefDC, HORZSIZE) * 100, GetDeviceCaps(RefDC, HORZRES));
If ReferenceDevice is not defined, then the screen (GetDC(0)) is used. On my machine horizontal size is reported as 677 and horizontal resolution as 1920. Thus FMetafile.MMWidth := 40000 * 67700 div 1920 ( = 1410416). Since FMetaFile.MMWidth is an integer, no problems at this point.
Next, let's look at the file writing, which is done with WriteWMFStream because we write to a .wmf file:
procedure TMetafile.WriteWMFStream(Stream: TStream);
var
WMF: TMetafileHeader;
...
begin
...
Inch := 96 { WMF defaults to 96 units per inch }
...
Right := MulDiv(FWidth, WMF.Inch, HundredthMMPerInch);
...
The WMF header structure indicates where things are going south
TMetafileHeader = record
Key: Longint;
Handle: SmallInt;
Box: TSmallRect; // smallint members
Inch: Word;
Reserved: Longint;
CheckSum: Word;
end;
The Box: TSmallRect field can not hold bigger coordinates than smallint-sized values.
Right is calculated as Right := 1410417 * 96 div 2540 ( = 53307 as smallint= -12229). The dimensions of the image overflows and the wmf data can not be 'played' to the file.
The question rizes: What dimensions can I use on my machine?
Both FMetaFile.MMWidth and FMetaFile.MMHeight needs to be less or equal to
MaxSmallInt * HundredthMMPerInch div UnitsPerInch or
32767 * 2540 div 96 = 866960
On my testmachine horizontal display size and resolution are 677 and 1920. Vertical display size and resolution are 381 and 1080. Thus maximum dimensions of a metafile becomes:
Horizontal: 866960 * 1920 div 67700 = 24587
Vertical: 866960 * 1080 div 38100 = 24575
Verified by testing.
Update after further investigation inspired by comments:
With horizontal and vertical dimension up to 32767, the metafile is readable with some applications, f.ex. GIMP, it shows the image. Possibly this is due to those programs considering the extents of the drawing as word instead of SmallInt. GIMP reported pixels per inch to be 90 and when changed to 96 (which is the value used by Delphi, GIMP chrashed with a 'GIMP Message: Plug-in crashed: "file-wmf.exe".
The procedure in the OP does not show an error message with dimensions of 32767 or less. However, if either dimension is higher than previously presented calculated max value, the drawing is not shown. When reading the metafile, the same TMetafileHeader structure type is used as when saving and the FWidth and FHeight get negative values:
procedure TMetafile.ReadWMFStream(Stream: TStream; Length: Longint);
...
FWidth := MulDiv(WMF.Box.Right - WMF.Box.Left, HundredthMMPerInch, WMF.Inch);
FHeight := MulDiv(WMF.Box.Bottom - WMF.Box.Top, HundredthMMPerInch, WMF.Inch);
procedure TImage.PictureChanged(Sender: TObject);
if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then
SetBounds(Left, Top, Picture.Width, Picture.Height);
The negative values ripple through to the Paint procedure in the DestRect function and the image is therefore not seen.
procedure TImage.Paint;
...
with inherited Canvas do
StretchDraw(DestRect, Picture.Graphic);
DestRect has negative values for Right and Bottom
I maintain that the only way to find actual limit is to call GetDeviceCaps() for both horizontal and vertical size and resolution, and perform the calculations above. Note however, the file may still not be displayable with a Delphi program on another machine. Keeping the drawing size within 20000 x 20000 is probably a safe limit.

Delphi, QR, WMF

I got a "new job" to "archive" some data with QR Filter.
When the data structure modified and saved to database then we start a "silent printing" with WMF filter, I catch the files, and I store them all in log record, in a DataBase BLOB.
Everything was ok, but later they are needed to avoid repeating the same reports.
We disabled the "timestamp QR fields", but the record repeated.
I put some CRC in the database, and I calculated it from page data (WMF).
What was interesting was that when I exited the program, the newly generated WMF changed - so the CRC changed too.
I thought this was caused by QR, then I checked this with a simple Delphi program:
procedure TForm1.BitBtn1Click(Sender: TObject);
var
WMF : TMetaFile;
mfc : TMetaFileCanvas;
begin
WMF := TMetaFile.Create;
mfc := TMetaFileCanvas.Create(WMF, 0);
try
WMF.Width := 1000;
WMF.Height := 1000;
mfc.Brush.Color := clRed;
mfc.FillRect(Rect(0, 0, 100, 100));
finally
mfc.Free;
WMF.SaveToFile('test1.wmf');
WMF.Free;
end;
end;
When I restart the app, the new wmf file is different from the previous.
I thought that I solve the problem with stretch the wmf into the bmp.Canvas, but this has slowed down the logging, because every bmp was 4 MB, and with 10 pages I must CRC on 4 * 10 MB...
(The WMF is only 85-100 KByte per page vs 4 MB bitmap)
So I am searching for some easy way I CAN calculate CRC on WMF, maybe if I can split the WMF header fully, then I get solve this problem... I don't know in this moment.
Do you have some idea? Please let me know!
Thanks.
Export the report as text, then compare its crc.
This is the easiest solution.
You can also enumerate the metafile elements, but it will be more difficult.

Delphi Pascal - Using SetFilePointerEx and GetFileSizeEx, Getting Physical Media exact size when reading as a file

I do not know how to use any API that is not in the RTL. I have been using SetFilePointer and GetFileSize to read a Physical Disk into a buffer and dump it to a file, something like this in a loop does the job for flash memory cards under 2GB:
SetFilePointer(PD,0,nil,FILE_BEGIN);
SetLength(Buffer,512);
ReadFile(PD,Buffer[0],512,BytesReturned,nil);
However GetFileSize has a limit at 2GB and so does SetFilePointer. I have absolutley no idea how to delcare an external API, I have looked at the RTL and googled for many examples and have found no correct answer.
I tried this
function GetFileSizeEx(hFile: THandle; lpFileSizeHigh: Pointer): DWORD;
external 'kernel32';
and as suggested this
function GetFileSizeEx(hFile: THandle; var FileSize: Int64): DWORD;
stdcall; external 'kernel32';
But the function returns a 0 even though I am using a valid disk handle which I have confirmed and dumped data from using the older API's.
I am using SetFilePointer to jump every 512 bytes and ReadFile to write into a buffer, in reverse I can use it to set when I am using WriteFile to write Initial Program Loader Code or something else to the disk. I need to be able to set the file pointer beyond 2gb well beyond.
Can someone help me make the external declarations and a call to both GetFileSizeEx and SetFilePointerEx that work so I can modify my older code to work with say 4 to 32gb flash cards.
I suggest that you take a look at this Primoz Gabrijelcic blog article and his GpHugeFile unit which should give you enough pointers to get the file size.
Edit 1 This looks rather a daft answer now in light of the edit to the question.
Edit 2 Now that this answer has been accepted, following a long threads of comments to jachguate's answer, I feel it incumbent to summarise what has been learnt.
GetFileSize and
SetFilePointer have no 2GB
limitation, they can be used on files
of essentially arbitrary size.
GetFileSizeEx and
SetFilePointerEx are much
easier to use because they work
directly with 64 bit quantities and
have far simpler error condition
signals.
The OP did not in fact need to
calculate the size of his disk. Since
the OP was reading the entire
contents of the disk the size was not
needed. All that was required was to
read the contents sequentially until
there was nothing left.
In fact
GetFileSize/GetFileSizeEx
do not support handles to devices
(e.g. a physical disk or volume) as
was requested by the OP. What's more,
SetFilePointer/SetFilePointerEx
cannot seek to the end of such device
handles.
In order to obtain the size of a
disk, volume or partition, one should
pass the the
IOCTL_DISK_GET_LENGTH_INFO
control code to
DeviceIoControl.
Finally, should you need to use GetFileSizeEx and SetFilePointerEx then they can be declared as follows:
function GetFileSizeEx(hFile: THandle; var lpFileSize: Int64): BOOL;
stdcall; external 'kernel32.dll';
function SetFilePointerEx(hFile: THandle; liDistanceToMove: Int64;
lpNewFilePointer: PInt64; dwMoveMethod: DWORD): BOOL;
stdcall; external 'kernel32.dll';
One easy way to obtain these API imports them is through the excellent JEDI API Library.
The GetFileSizeEx routine expects a pointer to a LARGE_INTEGER data type, and documentation says:
If your compiler has built-in support for 64-bit integers, use the QuadPart member to store the 64-bit integer
Lucky you, Delphi has built-in support for 64 bit integers, so use it:
var
DriveSize: LongWord;
begin
GetFilePointerSizeEx(PD, #DriveSize);
end;
SetFilePointerEx, on the other hand, expects parameters for liDistanceToMove, lpNewFilePointer, both 64 bit integers. My understanding is it wants signed integers, but you have the UInt64 data type for Unsingned 64 bit integers if I'm missunderstanding the documentation.
Alternative coding
Suicide, first of all your approach is wrong, and because of your wrong approach you ran into some hairy problems with the way Windows handles Disk drives opened as files. In pseudo code your approach seems to be:
Size = GetFileSize;
for i=0 to (Size / 512) do
begin
Seek(i * 512);
ReadBlock;
WriteBlockToFile;
end;
That's functionally correct, but there's a simpler way to do the same without actually getting the SizeOfDisk and without seeking. When reading something from a file (or a stream), the "pointer" is automatically moved with the ammount of data you just read, so you can skip the "seek". All the functions used to read data from a file return the amount of data that was actually read: you can use that to know when you reached the end of the file without knowing the size of the file to start with!
Here's an idea of how you can read an physical disk to a file, without knowing much about the disk device, using Delphi's TFileStream:
var DiskStream, DestinationStream:TFileStream;
Buff:array[0..512-1] of Byte;
BuffRead:Integer;
begin
// Open the disk for reading
DiskStream := TFileStream.Create('\\.\PhysicalDrive0', fmOpenRead);
try
// Create the file
DestinationStream := TFileStream.Create('D:\Something.IMG', fmCreate);
try
// Read & write in a loop; This is where all the work's done:
BuffRead := DiskStream.Read(Buff, SizeOf(Buff));
while BuffRead > 0 do
begin
DestinationStream.Write(Buff, BuffRead);
BuffRead := DiskStream.Read(Buff, SizeOf(Buff));
end;
finally DestinationStream.Free;
end;
finally DiskStream.Free;
end;
end;
You can obviously do something similar the other way around, reading from a file and writing to disk. Before writing that code I actually attempted doing it your way (getting the file size, etc), and immediately ran into problems! Apparently Windows doesn't know the exact size of the "file", not unless you read from it.
Problems with disks opened as files
For all my testing I used this simple code as the base:
var F: TFileStream;
begin
F := TFileStream.Create('\\.\PhysicalDrive0', fmOpenRead);
try
// Test code goes here...
finally F.Free;
end;
end;
The first (obvious) thing to try was:
ShowMessage(IntToStr(DiskStream.Size));
That fails. In the TFileStream implementation that depends on calling FileSeek, and FileSeek can't handle files larger then 2Gb. So I gave GetFileSize a try, using this code:
var RetSize, UpperWord:DWORD;
RetSize := GetFileSize(F.Handle, #UpperWord);
ShowMessage(IntToStr(UpperWord) + ' / ' + IntToStr(RetSize));
That also fails, even those it should be perfectly capable of returning file size as an 64 bit number! Next I tried using the SetFilePointer API, because that's also supposed to handle 64bit numbers. I thought I'd simply seek to the end of the file and look at the result, using this code:
var RetPos, UpperWord:DWORD;
UpperWord := 0;
RetPos := SetFilePos(F.Handle, 0, #UpperWord, FILE_END);
ShowMessage(IntToStr(UpperWord) + ' / ' + IntToStr(RetPos));
This code also fails! And now I'm thinking, why did the first code work? Apparently reading block-by-block works just fine and Windows knows exactly when to stop reading!! So I thought maybe there's a problem with the implementation of the 64 bit file handling routines, let's try seeking to end of the file in small increments; When we get an error seeking we know we reached the end we'll stop:
var PrevUpWord, PrevPos: DWORD;
UpWord, Pos: DWORD;
UpWord := 0;
Pos := SetFilePointer(F.Handle, 1024, #UpWord, FILE_CURRENT); // Advance the pointer 512 bytes from it's current position
while (UpWord <> PrevUpWord) or (Pos <> PrevPos) do
begin
PrevUpWord := UpWord;
PrevPos := Pos;
UpWord := 0;
Pos := SetFilePointer(F.Handle, 1024, #UpWord, FILE_CURRENT);
end;
When trying this code I had a surprise: It doesn't stop at the of the file, it just goes on and on, for ever. It never fails. To be perfectly honest I'm not sure it's supposed to ever fail... It's probably not supposed to fail. Anyway, doing a READ in that loop fails when we're past the end of file so we can use a VERY hacky mixed approach to handle this situation.
Ready-made routines that work around the problem
Here's the ready-made routine that gets the size of the physical disk opened as a file, even when GetFileSize fails, and SetFilePointer with FILE_END fails. Pass it an opened TFileStream and it will return the size as an Int64:
function Hacky_GetStreamSize(F: TFileStream): Int64;
var Step:DWORD;
StartPos: Int64;
StartPos_DWORD: packed array [0..1] of DWORD absolute StartPos;
KnownGoodPosition: Int64;
KGP_DWORD: packed array [0..1] of DWORD absolute KnownGoodPosition;
Dummy:DWORD;
Block:array[0..512-1] of Byte;
begin
// Get starting pointer position
StartPos := 0;
StartPos_DWORD[0] := SetFilePointer(F.Handle, 0, #StartPos_DWORD[1], FILE_CURRENT);
try
// Move file pointer to the first byte
SetFilePointer(F.Handle, 0, nil, FILE_BEGIN);
// Init
KnownGoodPosition := 0;
Step := 1024 * 1024 * 1024; // Initial step will be 1Gb
while Step > 512 do
begin
// Try to move
Dummy := 0;
SetFilePointer(F.Handle, Step, #Dummy, FILE_CURRENT);
// Test: Try to read!
if F.Read(Block, 512) = 512 then
begin
// Ok! Save the last known good position
KGP_DWORD[1] := 0;
KGP_DWORD[0] := SetFilePointer(F.Handle, 0, #KGP_DWORD[1], FILE_CURRENT);
end
else
begin
// Read failed! Move back to the last known good position and make Step smaller
SetFilePointer(F.Handle, KGP_DWORD[0], #KGP_DWORD[1], FILE_BEGIN);
Step := Step div 4; // it's optimal to devide by 4
end;
end;
// From here on we'll use 512 byte steps until we can't read any more
SetFilePointer(F.Handle, KGP_DWORD[0], #KGP_DWORD[1], FILE_BEGIN);
while F.Read(Block, 512) = 512 do
KnownGoodPosition := KnownGoodPosition + 512;
// Done!
Result := KnownGoodPosition;
finally
// Move file pointer back to starting position
SetFilePointer(F.Handle, StartPos_DWORD[0], #StartPos_DWORD[1], FILE_BEGIN);
end;
end;
To be complete, here are two routines that may be used to set and get the file pointer using Int64 for positioning:
function Hacky_SetStreamPos(F: TFileStream; Pos: Int64):Int64;
var aPos:Int64;
DWA:packed array[0..1] of DWORD absolute aPos;
const INVALID_SET_FILE_POINTER = $FFFFFFFF;
begin
aPos := Pos;
DWA[0] := SetFilePointer(F.Handle, DWA[0], #DWA[1], FILE_BEGIN);
if (DWA[0] = INVALID_SET_FILE_POINTER) and (GetLastError <> NO_ERROR) then
RaiseLastOSError;
Result := aPos;
end;
function Hacky_GetStreamPos(F: TFileStream): Int64;
var Pos:Int64;
DWA:packed array[0..1] of DWORD absolute Pos;
begin
Pos := 0;
DWA[0] := SetFilePointer(F.Handle, 0, #DWA[1], FILE_CURRENT);
Result := Pos;
end;
Last notes
The 3 routines I'm providing take as a parameter an TFileStream, because that's what I use for file reading and writing. They obviously only use TFileStream.Handle, so the parameter can simply be replaced with an file handle: the functionality would stay the same.
I know this thread is old, but...
One small suggestion - if you use the Windows DeviceIoControl(...) function you can get Drive Geometry and/or Partition Information, and use them to get the total size/length of the opened drive or partition. No more messing around with incrementally seeking to the end of the device.
Those IOCTLs can also be used to give you the correct volume sector size, and you could use that instead of defaulting to 512 everywhere.
Very very useful. But I got a problem for disks greater then 4 GB.
I solved replacing:
// Ok! Save the last known good position
KGP_DWORD[1] := 0;
KGP_DWORD[0] := SetFilePointer(F.Handle, 0, #KGP_DWORD[1], FILE_CURRENT);
with the following:
// Ok! Save the last known good position
KnownGoodPosition := KnownGoodPosition + Step;
Many thanks again...
And many thanks also to James R. Twine. I followed the advice of using IOCTL_DISK_GET_DRIVE_GEOMETRY_EX and got disk dimension with no problem and no strange workaround.
Here is the code:
TDISK_GEOMETRY = record
Cylinders : Int64; //LargeInteger
MediaType : DWORD; //MEDIA_TYPE
TracksPerCylinder: DWORD ;
SectorsPerTrack: DWORD ;
BytesPerSector : DWORD ;
end;
TDISK_GEOMETRY_EX = record
Geometry: TDISK_GEOMETRY ;
DiskSize: Int64; //LARGE_INTEGER ;
Data : array[1..1000] of byte; // unknown length
end;
function get_disk_size(handle: thandle): int64;
var
BytesReturned: DWORD;
DISK_GEOMETRY_EX : TDISK_GEOMETRY_EX;
begin
result := 0;
if DeviceIOControl(handle,IOCTL_DISK_GET_DRIVE_GEOMETRY_EX,
nil,0,#DISK_GEOMETRY_EX, sizeof(TDISK_GEOMETRY_EX),BytesReturned,nil)
then result := DISK_GEOMETRY_EX.DiskSize;
end;

Resources