Why does a call to GetDIBits fail on Win64? - delphi

I have a call to GetDIBits that works perfectly in 32-bit, but fails on 64-bit. Despite the different values for the handles the content of the bitmapinfo structure are the same.
Here is the smallest (at least slightly structured) code example I could come up with to reproduce the error. I tested with Delphi 10 Seattle Update 1, but the error seems to occur even with other Delphi versions.
program Project1;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Winapi.Windows,
System.SysUtils,
Vcl.Graphics;
type
TRGBALine = array[Word] of TRGBQuad;
PRGBALine = ^TRGBALine;
type
{ same structure as TBitmapInfo, but adds space for two more entries in bmiColors }
TMyBitmapInfo = record
bmiHeader: TBitmapInfoHeader;
bmiColors: array[0..2] of TRGBQuad;
public
constructor Create(AWidth, AHeight: Integer);
end;
constructor TMyBitmapInfo.Create(AWidth, AHeight: Integer);
begin
FillChar(bmiHeader, Sizeof(bmiHeader), 0);
bmiHeader.biSize := SizeOf(bmiHeader);
bmiHeader.biWidth := AWidth;
bmiHeader.biHeight := -AHeight; //Otherwise the image is upside down.
bmiHeader.biPlanes := 1;
bmiHeader.biBitCount := 32;
bmiHeader.biCompression := BI_BITFIELDS;
bmiHeader.biSizeImage := 4*AWidth*AHeight; // 4 = 32 Bits/Pixel div 8 Bits/Byte
bmiColors[0].rgbRed := 255;
bmiColors[1].rgbGreen := 255;
bmiColors[2].rgbBlue := 255;
end;
procedure Main;
var
bitmap: TBitmap;
res: Cardinal;
Bits: PRGBALine;
buffer: TMyBitmapInfo;
BitmapInfo: TBitmapInfo absolute buffer;
BitsSize: Cardinal;
icon: TIcon;
IconInfo: TIconInfo;
begin
bitmap := TBitmap.Create;
try
icon := TIcon.Create;
try
icon.LoadFromResourceID(0, Integer(IDI_WINLOGO));
if not GetIconInfo(icon.Handle, IconInfo) then begin
Writeln('Error GetIconInfo: ', GetLastError);
Exit;
end;
bitmap.PixelFormat := pf32bit;
bitmap.Handle := IconInfo.hbmColor;
BitsSize := BytesPerScanline(bitmap.Width, 32, 32) * bitmap.Height;
Bits := AllocMem(BitsSize);
try
ZeroMemory(Bits, BitsSize);
buffer := TMyBitmapInfo.Create(bitmap.Width, bitmap.Height);
res := GetDIBits(bitmap.Canvas.Handle, bitmap.Handle, 0, bitmap.Height, Bits, BitmapInfo, DIB_RGB_COLORS);
if res = 0 then begin
Writeln('Error GetDIBits: ', GetLastError);
Exit;
end;
Writeln('Succeed');
finally
FreeMem(Bits);
end;
finally
icon.Free;
end;
finally
bitmap.Free;
end;
end;
begin
try
Main;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
Readln;
end.

Update A comment to this answer points the way as to why your code is failing. The order of evaluation of bitmap.Handle and bitmap.Canvas.Handle matters. Since parameter evaluation order is undefined, your program has undefined behaviour. And that explains why the x86 and x64 programs differ in behaviour.
So you could resolve the issue by assigning the bitmap handle and device context to local variables in the appropriate order, and then passing these as the arguments to GetDIBits. But I still think that the code is far better to avoid the VCL TBitmap class and use GDI calls directly, as in the code below.
I believe that your mistake is to pass the bitmap handle, and its canvas handle. Instead you should pass, for example, a device context obtained by calling CreateCompatibleDC(0). Or pass IconInfo.hbmColor to GetDIBits. But don't pass the handle of the TBitmap and the handle of its canvas.
I also cannot see any purpose to the TBitmap that you create. All you do with it is obtain the width and height of IconInfo.hbmColor. You don't need to create TBitmap to do that.
So if I were you I would remove the TBitmap, and use CreateCompatibleDC(0) to obtain the device context. This should greatly simplify the code.
You will also need to delete the bitmaps returned by the call to GetIconInfo, but I guess that you know this already and removed that code from the question for simplicity.
Frankly, the VCL objects are just getting in the way here. It's actually much simpler to call the GDI functions directly. Perhaps something like this:
procedure Main;
var
res: Cardinal;
Bits: PRGBALine;
bitmap: Winapi.Windows.TBitmap;
DC: HDC;
buffer: TMyBitmapInfo;
BitmapInfo: TBitmapInfo absolute buffer;
BitsSize: Cardinal;
IconInfo: TIconInfo;
begin
if not GetIconInfo(LoadIcon(0, IDI_WINLOGO), IconInfo) then begin
Writeln('Error GetIconInfo: ', GetLastError);
Exit;
end;
try
if GetObject(IconInfo.hbmColor, SizeOf(bitmap), #bitmap) = 0 then begin
Writeln('Error GetObject');
Exit;
end;
BitsSize := BytesPerScanline(bitmap.bmWidth, 32, 32) * abs(bitmap.bmHeight);
Bits := AllocMem(BitsSize);
try
buffer := TMyBitmapInfo.Create(bitmap.bmWidth, abs(bitmap.bmHeight));
DC := CreateCompatibleDC(0);
res := GetDIBits(DC, IconInfo.hbmColor, 0, abs(bitmap.bmHeight), Bits, BitmapInfo,
DIB_RGB_COLORS);
DeleteDC(DC);
if res = 0 then begin
Writeln('Error GetDIBits: ', GetLastError);
Exit;
end;
Writeln('Succeed');
finally
FreeMem(Bits);
end;
finally
DeleteObject(IconInfo.hbmMask);
DeleteObject(IconInfo.hbmColor);
end;
end;

Related

Delphi XE2 - DFM stream is randomly empty or corrupted while read function callback is called

I'm creating a package in which a custom image list reads and writes its content inside a DFM file.
The code I wrote works globally well in all compilers between XE7 and 10.3 Rio. However I have a strange issue in XE2. With this particular compiler, I sometimes receives an empty stream content while the DFM is read, and sometimes a corrupted content.
My custom image list is built above a standard TImageList. I register my read callback this way:
procedure TMyImageList.DefineProperties(pFiler: TFiler);
function DoWritePictures: Boolean;
begin
if (Assigned(pFiler.Ancestor)) then
Result := not (pFiler.Ancestor is TMyImageList)
else
Result := Count > 0;
end;
begin
inherited DefineProperties(pFiler);
// register the properties that will load and save the pictures binary data in DFM files
pFiler.DefineBinaryProperty('Pictures', ReadPictures, WritePictures, DoWritePictures);
end;
Here is the ReadPictures function:
procedure TMyImageList.ReadPictures(pStream: TStream);
begin
LoadPictureListFromStream(m_pPictures, pStream);
end;
Here is the LoadPictureListFromStream function:
procedure TMyImageList.LoadPictureListFromStream(pList: IWPictureList; pStream: TStream);
var
{$if CompilerVersion <= 23}
pImgNameBytes: Pointer;
pData: Pointer;
{$else}
imgNameBytes: TBytes;
{$ifend}
count, i: Integer;
color: Cardinal;
imgClassName: string;
pMemStr: TMemoryStream;
size: Int64;
pItem: IWPictureItem;
pGraphicClass: TGraphicClass;
pGraphic: TGraphic;
begin
// read the list count
pStream.ReadBuffer(count, SizeOf(count));
// is list empty?
if (count <= 0) then
Exit;
pMemStr := TMemoryStream.Create;
// enable the code below to log the received stream content
{$ifdef _DEBUG}
size := pStream.Position;
pStream.Position := 0;
pMemStr.CopyFrom(pStream, pStream.Size);
pMemStr.Position := 0;
pMemStr.SaveToFile('__DfmStreamContent.bin');
pMemStr.Clear;
pStream.Position := size;
{$endif}
try
for i := 0 to count - 1 do
begin
pItem := IWPictureItem.Create;
try
// read the next size
pStream.ReadBuffer(size, SizeOf(size));
// read the image type from stream
if (size > 0) then
begin
{$if CompilerVersion <= 23}
pImgNameBytes := nil;
try
GetMem(pImgNameBytes, size + 1);
pStream.ReadBuffer(pImgNameBytes^, size);
pData := Pointer(NativeUInt(pImgNameBytes) + NativeUInt(size));
(PByte(pData))^ := 0;
imgClassName := UTF8ToString(pImgNameBytes);
finally
if (Assigned(pImgNameBytes)) then
FreeMem(pImgNameBytes);
end;
{$else}
SetLength(imgNameBytes, size);
pStream.Read(imgNameBytes, size);
imgClassName := TEncoding.UTF8.GetString(imgNameBytes);
{$ifend}
end;
// read the next size
pStream.ReadBuffer(size, SizeOf(size));
// read the image from stream
if (size > 0) then
begin
// read the image in a temporary memory stream
pMemStr.CopyFrom(pStream, size);
pMemStr.Position := 0;
// get the graphic class to create
if (imgClassName = 'TWSVGGraphic') then
pGraphicClass := TWSVGGraphic
else
begin
TWLogHelper.LogToCompiler('Internal error - unknown graphic class - '
+ imgClassName + ' - name - ' + Name);
pGraphicClass := nil;
end;
// found it?
if (Assigned(pGraphicClass)) then
begin
pGraphic := nil;
try
// create a matching graphic to receive the image data
pGraphic := pGraphicClass.Create;
pGraphic.LoadFromStream(pMemStr);
pItem.m_pPicture.Assign(pGraphic);
finally
pGraphic.Free;
end;
end;
pMemStr.Clear;
end;
// read the next size
pStream.ReadBuffer(size, SizeOf(size));
// read the color key from stream
if (size > 0) then
begin
Assert(size = SizeOf(color));
pStream.ReadBuffer(color, size);
// get the color key
pItem.m_ColorKey := TWColor.Create((color shr 16) and $FF,
(color shr 8) and $FF,
color and $FF,
(color shr 24) and $FF);
end;
// add item to list
pList.Add(pItem);
except
pItem.Free;
raise;
end;
end;
finally
pMemStr.Free;
end;
end;
Here is the WritePictures function:
procedure TMyImageList.WritePictures(pStream: TStream);
begin
SavePictureListToStream(m_pPictures, pStream);
end;
And finally, here is the SavePictureListToStream function:
procedure TMyImageList.SavePictureListToStream(pList: IWPictureList; pStream: TStream);
var
count, i: Integer;
color: Cardinal;
imgClassName: string;
imgNameBytes: TBytes;
pMemStr: TMemoryStream;
size: Int64;
begin
// write the list count
count := pList.Count;
pStream.WriteBuffer(count, SizeOf(count));
if (count = 0) then
Exit;
pMemStr := TMemoryStream.Create;
try
for i := 0 to count - 1 do
begin
// a picture should always be assigned in the list so this should never happen
if (not Assigned(pList[i].m_pPicture.Graphic)) then
begin
TWLogHelper.LogToCompiler('Internal error - picture list is corrupted - ' + Name);
// write empty size to prevent to corrupt the stream
size := 0;
pStream.WriteBuffer(size, SizeOf(size));
pStream.WriteBuffer(size, SizeOf(size));
end
else
begin
// save the image type in the stream
imgClassName := pList[i].m_pPicture.Graphic.ClassName;
imgNameBytes := TEncoding.UTF8.GetBytes(imgClassName);
size := Length(imgNameBytes);
pStream.WriteBuffer(size, SizeOf(size));
pStream.Write(imgNameBytes, size);
// save the image in the stream
pList[i].m_pPicture.Graphic.SaveToStream(pMemStr);
size := pMemStr.Size;
pStream.WriteBuffer(size, SizeOf(size));
pStream.CopyFrom(pMemStr, 0);
pMemStr.Clear;
end;
// build the key color to save
color := (pList[i].m_ColorKey.GetBlue +
(pList[i].m_ColorKey.GetGreen shl 8) +
(pList[i].m_ColorKey.GetRed shl 16) +
(pList[i].m_ColorKey.GetAlpha shl 24));
// save the key color in the stream
size := SizeOf(color);
pStream.WriteBuffer(size, SizeOf(size));
pStream.WriteBuffer(color, size);
end;
finally
pMemStr.Free;
end;
end;
When the issue occurs, the content get in imgClassName become incoherent, or sometimes the image count read on the LoadPictureListFromStream() function first line is equals to 0.
Writing the DFM stream content in a file, I also noticed that only the class name value is corrupted, other data seems OK.
This issue happens randomly, sometimes all works fine, especially if I start the app in runtime time without previously opening the form in design time, but it may also happen whereas I just open the form in design time, without changing nor saving nothing. On the other hand, this issue happen only with XE2. I never noticed it on any other compiler.
As I'm a c++ developer writing a Delphi code, and as I needed to adapt a part of the code to be able to compile it under XE2 (see the {$if CompilerVersion <= 23} statements), I probably doing something very bad with the memory, but I cannot figure out what exactly.
Can someone analyse this code and point me what is(are) my mistake(s)?
In your SavePictureListToStream() method, the statement
pStream.Write(imgNameBytes, size);
does not work the way you expect in XE2 and earlier. TStream did not gain support for reading/writing TBytes arrays until XE3. As such, the above statement ends up writing to the memory address where the imgNameBytes variable itself is declared on the stack, not to the address where the variable is pointing to, where the array is allocated on the heap.
For XE2 and earlier, you need to use this statement instead:
pStream.WriteBuffer(PByte(imgNameBytes)^, size);
What you have in your LoadPictureListFromStream() method is technically OK, but your UTF-8 handling is more complicated then it needs to be. TEncoding exists in XE2, as it was first introduced in D2009. But even in older versions, you can and should use a dynamic array instead of GetMem() to simplify your memory management and keep it consistent across multiple versions, eg:
{$if CompilerVersion < 18.5}
type
TBytes = array of byte;
{$ifend}
var
imgNameBytes: TBytes;
...
begin
...
// read the next size
pStream.ReadBuffer(size, SizeOf(size));
// read the image type from stream
if (size > 0) then
begin
SetLength(imgNameBytes, size{$if CompilerVersion < 20}+1{$ifend});
pStream.ReadBuffer(PByte(imgNameBytes)^, size);
{$if CompilerVersion < 20}
imgNameBytes[High(imgNameBytes)] := $0;
imgClassName := UTF8ToString(PAnsiChar(pImgNameBytes));
{$else}
imgClassName := TEncoding.UTF8.GetString(imgNameBytes);
{$ifend}
end;
...
end;

How do I make SetThreadDesktop API work from a console application?

I saw Stack Overflow question How to switch a process between default desktop and Winlogon desktop?.
And I have produced a minimal test-case creating a console project application, but SetThreadDesktop() does not switch my program to the target desktop.
Why does this happen?
program Project1;
{$APPTYPE CONSOLE}
{$R *.res}
uses
Winapi.Windows,
System.SysUtils,
Vcl.Graphics,
function RandomPassword(PLen: Integer): string;
var
str: string;
begin
Randomize;
str := 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ';
Result := '';
repeat
Result := Result + str[Random(Length(str)) + 1];
until (Length(Result) = PLen)
end;
procedure Print;
var
DCDesk: HDC;
bmp: TBitmap;
hmod, hmod2 : HMODULE;
BitBltAPI: function(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; Rop: DWORD): BOOL; stdcall;
GetWindowDCAPI: function(hWnd: HWND): HDC; stdcall;
begin
hmod := GetModuleHandle('Gdi32.dll');
hmod2:= GetModuleHandle('User32.dll');
if (hmod <> 0) and (hmod2 <> 0) then begin
bmp := TBitmap.Create;
bmp.Height := Screen.Height;
bmp.Width := Screen.Width;
GetWindowDCAPI := GetProcAddress(hmod2, 'GetWindowDC');
if (#GetWindowDCAPI <> nil) then begin
DCDesk := GetWindowDCAPI(GetDesktopWindow);
end;
BitBltAPI := GetProcAddress(hmod, 'BitBlt');
if (#BitBltAPI <> nil) then begin
BitBltAPI(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height, DCDesk, 0, 0, SRCCOPY);
bmp.SaveToFile('ScreenShot_------_' + RandomPassword(8) + '.bmp');
end;
ReleaseDC(GetDesktopWindow, DCDesk);
bmp.Free;
FreeLibrary(hmod);
FreeLibrary(hmod2);
end;
end;
//===============================================================================================================================
var
hWinsta, hdesktop:thandle;
begin
try
while True do
begin
hWinsta := OpenWindowStation('WinSta0', TRUE, GENERIC_ALL);
If hwinsta <> INVALID_HANDLE_VALUE then
begin
SetProcessWindowStation (hWinsta);
hdesktop := OpenDesktop ('default_set', 0, TRUE, GENERIC_ALL);
if (hdesktop <> INVALID_HANDLE_VALUE) then
if SetThreadDesktop (hdesktop) then
begin
Print; // Captures screen of target desktop.
CloseWindowStation (hwinsta);
CloseDesktop (hdesktop);
end;
end;
Sleep(5000);
end;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
Checking errors, the SetThreadDesktop() call fails with error code 170 (ERROR_BUSY, The requested resource is in use) when the target desktop is open.
var
threahdesk: boolean;
...
threahdesk := SetThreadDesktop (hdesktop);
ShowMessage(IntToStr(GetLastError));
if threahdesk Then
begin
Print;
CloseWindowStation (hwinsta);
CloseDesktop (hdesktop);
end;
After that I saw several suggestion in some forums, my actual code is as follows:
var
hWinsta, hdesktop:thandle;
threahdesk, setprocwst: Boolean;
////////////////////////////////////////////////////////////////////////////////
begin
try
while True do
begin
Application.Free;
hWinsta:= OpenWindowStation('WinSta0', TRUE, GENERIC_ALL);
If hwinsta <> 0 Then
Begin
setprocwst := SetProcessWindowStation(hWinsta);
if setprocwst then
hdesktop:= OpenDesktop('default_set', 0, TRUE, GENERIC_ALL);
If (hdesktop <> 0) Then
threahdesk := SetThreadDesktop(hdesktop);
Application := TApplication.Create(nil);
Application.Initialize;
Application.Run;
If threahdesk Then
Begin
Print;
CloseWindowStation (hwinsta);
CloseDesktop (hdesktop);
End;
End;
Sleep(5000);
end;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
The answer by Dmitriy is accurate in that the function fails because the calling thread has windows or hooks, although it doesn't explain how so.
The reason SetThreadDesktop is failing with ERROR_BUSY is, you have "forms.pas" in your uses list. Although it's missing in the code you posted (semicolon in "uses" clause is also missing hinting more units), the use of the Screen global variable makes it evident that you have "forms" in uses. "Forms" pulls in "controls.pas" which initializes the Application object. In its constructor, the Application creates a utility window for its PopupControlWnd. There may be other windows created but this one is enough reason for the function to fail.
You use Screen for its width/height. Un-use "forms", you can use API to retrieve that information.
There are other issues in the code like missing/wrong error checking which have been mentioned in the comments to the question, but they are not relevant to why SetThreadDesktop fails.
Below sample program demonstrates there's no problem calling SetThreadDesktop in the main thread of a console application, provided there's a desktop with name 'default_set' in the window station in which the program is running and has access rights to.
program Project1;
{$APPTYPE CONSOLE}
{$R *.res}
uses
System.SysUtils,
// Vcl.Forms, // uncomment to get an ERROR_BUSY
Winapi.Windows;
var
hSaveDesktop, hDesktop: HDESK;
begin
hSaveDesktop := GetThreadDesktop(GetCurrentThreadId);
Win32Check(hSaveDesktop <> 0);
hDesktop := OpenDesktop('default_set', 0, True, GENERIC_ALL);
Win32Check(hDesktop <> 0);
try
Win32Check(SetThreadDesktop(hDesktop));
try
// --
finally
Win32Check(SetThreadDesktop(hSaveDesktop));
end;
finally
Win32Check(CloseDesktop(hDesktop));
end;
end.
From the SetThreadDesktop() documentation:
The SetThreadDesktop function will fail if the calling thread has any windows or hooks on its current desktop (unless the hDesktop parameter is a handle to the current desktop).

png to bmp conversion (maintaining transparency)

I am using delphi XE-5 and I am loading button information from a JSON file, in order to create buttons on a TMS ADVToolBar control. Each button is 50X35 and in png format with transparency.
I am getting each url, using the idHTTP component to retrieve it to a stream and then load it into a png. I then draw it onto a transparent BMP. However, I dont think this is the correct way. Anyway, the bmp is then added to a TImageList where it is assigned to a button using the index. The Image shows up on the button, but with no transparency.
see my code below:
imgUrl:= //code to get img url from JSON file;
MS := TMemoryStream.Create;
png := TPngImage.Create;
png.Transparent:= True;
try
idHTTP1.get(imgUrl,MS);
Ms.Seek(0,soFromBeginning);
png.LoadFromStream(MS);
bmp:= TBitmap.Create;
bmp.Transparent:= True;
bmp.Width:= 50;
bmp.Height:= 50;
png.Draw(bmp.Canvas, Rect(7, 7, png.Width, png.Height));
ImageList1.Add(bmp, nil);
AdvGlowBtn.Images:= ImageList1;
AdvGlowBtn.Layout:= blGlyphTop;
AdvGlowBtn.WordWrap:= False;
AdvGlowBtn.AutoSize:= True;
AdvGlowBtn.ImageIndex:= ImageList1.Count-1;
bmp.Free;
finally
FreeAndNil(png);
FreeAndNil(MS);
end;
At first you have to enable the runtime themes (Project Manager) otherwise you will have no transparency of your images.
And this is the code to load the PNG image into your ImageList1
bmp := TBitmap.Create;
try
// everything done before to bmp has no effect
bmp.Assign( png );
// if for some reason the loaded image is smaller
// set the size to avoid the invalid image size error
bmp.Width := ImageList1.Width;
bmp.Height := ImageList1.Height;
AdvGlowBtn.Images:= ImageList1;
...
// now add the Bitmap to the ImageList
AdvGlowBtn.ImageIndex := ImageList1.Add( bmp, nil );
finally
bmp.Free;
end;
I have an old project in Delphi 5 and I still using it sometimes.
This is my solution using the png object.
procedure ImageList2Alpha(const ImageList: TImageList);
const
Mask: array[Boolean] of Longint = (0, ILC_MASK);
var
TempList: TImageList;
begin
if Assigned(ImageList) then
begin
TempList := TImageList.Create(nil);
try
TempList.Assign(ImageList);
with ImageList do
begin
Handle := ImageList_Create(Width, Height, ILC_COLOR32 or Mask[Masked], 0, AllocBy);
if not HandleAllocated then
raise EInvalidOperation.Create(SInvalidImageList);
end;
Imagelist.AddImages(TempList);
finally
FreeAndNil(TempList);
end;
end;
end;
procedure LoadPngToBmp(var Dest: TBitmap; AFilename: TFilename);
type
TRGB32 = packed record
B, G, R, A : Byte;
end;
PRGBArray32 = ^TRGBArray32;
TRGBArray32 = array[0..0] of TRGB32;
type
TRG24 = packed record
rgbtBlue, rgbtGreen, rgbtRed : Byte;
end;
PRGBArray24 = ^TPRGBArray24;
TPRGBArray24 = array[0..0] of TRG24;
type
TByteArray = Array[Word] of Byte;
PByteArray = ^TByteArray;
TPByteArray = array[0..0] of TByteArray;
var
BMP : TBitmap;
PNG: TPNGObject;
x, y: Integer;
BmpRow: PRGBArray32;
PngRow : PRGBArray24;
AlphaRow: PByteArray;
begin
Bmp := TBitmap.Create;
PNG := TPNGObject.Create;
try
if AFilename <> '' then
begin
PNG.LoadFromFile(AFilename);
BMP.PixelFormat := pf32bit;
BMP.Height := PNG.Height;
BMP.Width := PNG.Width;
if ( PNG.TransparencyMode = ptmPartial ) then
begin
for Y := 0 to BMP.Height-1 do
begin
BmpRow := PRGBArray32(BMP.ScanLine[Y]);
PngRow := PRGBArray24(PNG.ScanLine[Y]);
AlphaRow := PByteArray(PNG.AlphaScanline[Y]);
for X := 0 to BMP.Width - 1 do
begin
with BmpRow[X] do
begin
with PngRow[X] do
begin
R := rgbtRed; G := rgbtGreen; B := rgbtBlue;
end;
A := Byte(AlphaRow[X]);
end;
end;
end;
end else
begin
for Y := 0 to BMP.Height-1 do
begin
BmpRow := PRGBArray32(BMP.ScanLine[Y]);
PngRow := PRGBArray24(PNG.ScanLine[Y]);
for X := 0 to BMP.Width - 1 do
begin
with BmpRow[X] do
begin
with PngRow[X] do
begin
R := rgbtRed; G := rgbtGreen; B := rgbtBlue;
end;
A := 255;
end;
end;
end;
end;
Dest.Assign(BMP);
end;
finally
Bmp.Free;
PNG.Free;
end;
end;
Call ImageList2Alpha(YourImageList) on the OnCreate of the Form (FormCreate), and the ImageList will be ready to store your Bitmaps32 keeping the transparency.
Call the LoadPngToBmp procedure to convert a PNG to Bitmap32 and then, store it on your ImageList.
The TBitmap class uses Windows own libraries to manipulate Bitmaps. Depending on you Windows version, the underlying Operating System libraries does not support 32 bits BMPs, despite the libraries header files declares a BITMAPQUAD struct.
For newer versions of Windows (Vista and above afaik), the field BITMAPQUAD.reserved is used to store the alpha channel. For older versions, this field must remain zero (0x00).
If you are using a "recent" version of Windows, the only possible explanation I see is that the TBitmap class were not updated to support the alpha channel.
Using the class TPNGImage should not be an issue instead of converting it to BMP before using, unless you have some more specific needs.
Use it like that:
ABitmap.SetSize(png.Width, png.Height);
png.AssignTo(ABitmap);

How can I generate continuous tones of varying frequencies?

I want to generate and play a continuous sound with specific frequencies and amplitudes that change over time. I don't want to have a delay between sounds. How can I do this with Delphi or C++ Builder?
This very simple example should get you started.
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils, Windows, MMSystem;
type
TWaveformSample = integer; // signed 32-bit; -2147483648..2147483647
TWaveformSamples = packed array of TWaveformSample; // one channel
var
Samples: TWaveformSamples;
fmt: TWaveFormatEx;
procedure InitAudioSys;
begin
with fmt do
begin
wFormatTag := WAVE_FORMAT_PCM;
nChannels := 1;
nSamplesPerSec := 44100;
wBitsPerSample := 32;
nAvgBytesPerSec := nChannels * nSamplesPerSec * wBitsPerSample div 8;
nBlockAlign := nChannels * wBitsPerSample div 8;
cbSize := 0;
end;
end;
// Hz // msec
procedure CreatePureSineTone(const AFreq: integer; const ADuration: integer;
const AVolume: double { in [0, 1] });
var
i: Integer;
omega,
dt, t: double;
vol: double;
begin
omega := 2*Pi*AFreq;
dt := 1/fmt.nSamplesPerSec;
t := 0;
vol := MaxInt * AVolume;
SetLength(Samples, Round((ADuration / 1000) * fmt.nSamplesPerSec));
for i := 0 to high(Samples) do
begin
Samples[i] := round(vol*sin(omega*t));
t := t + dt;
end;
end;
procedure PlaySound;
var
wo: integer;
hdr: TWaveHdr;
begin
if Length(samples) = 0 then
begin
Writeln('Error: No audio has been created yet.');
Exit;
end;
if waveOutOpen(#wo, WAVE_MAPPER, #fmt, 0, 0, CALLBACK_NULL) = MMSYSERR_NOERROR then
try
ZeroMemory(#hdr, sizeof(hdr));
with hdr do
begin
lpData := #samples[0];
dwBufferLength := fmt.nChannels * Length(Samples) * sizeof(TWaveformSample);
dwFlags := 0;
end;
waveOutPrepareHeader(wo, #hdr, sizeof(hdr));
waveOutWrite(wo, #hdr, sizeof(hdr));
sleep(500);
while waveOutUnprepareHeader(wo, #hdr, sizeof(hdr)) = WAVERR_STILLPLAYING do
sleep(100);
finally
waveOutClose(wo);
end;
end;
begin
try
InitAudioSys;
CreatePureSineTone(400, 1000, 0.7);
PlaySound;
except
on E: Exception do
begin
Writeln(E.Classname, ': ', E.Message);
Readln;
end;
end;
end.
Notice in particular the neat interface you get:
InitAudioSys;
CreatePureSineTone(400, 1000, 0.7);
PlaySound;
By using WaveAudio library it's possible to generate a continous cosinus wave.
I was gonna post some code but I can't figure out how to do it properly so I won't.
But all you need to do is use TLiveAudioPlayer and then override the OnData event.
And also set Async to true if there is no message pump.
Update in dec 2021, I just came across my answer by chance... so I would like to update it, I used this ASIO library in 2009 I think and later, great library below:*
I would recommend ASIO library for Delphi !
https://sourceforge.net/projects/delphiasiovst/
Using this is super easy, not all files have to be included, start with the main one and add the rest from there, also see the examples.
Ultimately it's as easy as OnSomeEvent/OnSomeBuffer
and then simply filling an array with floating point values.
Don't remember the exact name of the OnEvent but you'll find it easily in the examples.
Another thing to do is set some component to active/true and voila.
The nice thing about ASIO is very low latency, it's even possible to get it down to 50 microseconds or even lower.
It does require an ASIO driver for your sound chip.
ASIO = audio stream input output
API designed by audio engineers !
It probably doesn't get any better than this ! ;)

Why do I get access violations using Mike Heydon's TStringBuilder class?

I am using a TStringBuilder class ported from .Net to Delphi 7.
And here is my code snippet:
procedure TForm1.btn1Click(Sender: TObject);
const
FILE_NAME = 'PATH TO A TEXT FILE';
var
sBuilder: TStringBuilder;
I: Integer;
fil: TStringList;
sResult: string;
randInt: Integer;
begin
randomize;
sResult := '';
for I := 1 to 100 do
begin
fil := TStringList.Create;
try
fil.LoadFromFile(FILE_NAME);
randInt := Random(1024);
sBuilder := TStringBuilder.Create(randInt);
try
sBuilder.Append(fil.Text);
sResult := sBuilder.AsString;
finally
sBuilder.free;
end;
mmo1.Text := sResult;
finally
FreeAndNil(fil);
end;
end;
showmessage ('DOne');
end;
I am experiencing AV errors. I can alleviate the problem when I create memory with the size multiple by 1024, however sometimes it still occurs.
Am I doing something wrong?
Your code is fine. The TStringBuilder code you're using is faulty. Consider this method:
procedure TStringBuilder.Append(const AString : string);
var iLen : integer;
begin
iLen := length(AString);
if iLen + FIndex > FBuffMax then _ExpandBuffer;
move(AString[1],FBuffer[FIndex],iLen);
inc(FIndex,iLen);
end;
If the future length is too long for the current buffer size, the buffer is expanded. _ExpandBuffer doubles the size of the buffer, but once that's done, it never checks whether the new buffer size is sufficient. If the original buffer size is 1024, and the file you're loading is 3 KB, then doubling the buffer size to 2048 will still leave the buffer too small in Append, and you'll end up overwriting 1024 bytes beyond the end of the buffer.
Change the if to a while in Append.

Resources