Renate Schaaf

This will scale the image by the desktop-DPI. For example my desktop-display is set at 200%. The bitmap is displayed in original size because of im.Wrapmode = Orignal. But the Image will be twice as large as its bitmap, and the scrollbox it's in will have a scrollbar-range which is too big . I have corrected that by dividing the width by im.scene.scale, which works. I was just wondering, whether there isn't a simpler way.

How does this relate to my question?

Well, if one could get one's hands on the DirectDraw-Canvas, and the DirectDraw-RenderingContext, one could write a descendent of FMX-TBitmap which uses the higher-quality setting possible with DirectDraw. I just can't see how, but I'm a newbie.

Your handcrafted routine isn't *that* slow, just turn on compiler-optimization. As for resampling, I had started to port my parallel bitmap-resampler to fmx, but then I thought, hey, these guys can use DirectDraw, there won't be a demand. Now, seeing how poor the quality is for (supposedly) bilinear rescaling, I have continued working on it. A first version is usable on Windows only for the time being. I just have to add some demos, and I'll probably upload it later today to https://github.com/rmesch/Parallel-Bitmap-Resampler Just in case you might be interested.

It looks like you want to use the component list of a TForm, so you should pass that form as a parameter: function SetDBSessionNames(const AForm: TForm; const sSessionName: string): boolean; begin // for var i := 0 to AForm.ComponentCount - 1 do begin // if AForm.Components[i] is TEDBSession then (AForm.Components[i] as TEDBSession).SessionName := sSessionName; .. Then you can call it in the code of a form as SetDBSessionNames(self, sSessionName);

A new version is available at https://github.com/rmesch/Repository-R.Schaaf. The parallel resampler can now be used in concurrent threads. You can define more than one thread pool for the resampling and tell the parallel procedure which pool to use. A new demo "ThreadsInThreads" has been added. Initially I had the problem that this demo would sometimes hang waiting for an event, but that has hopefully been fixed. I'd much appreciate a feedback if it still occurs. Thanks, Renate

Well, the test clearly shows it, or doesn't it? Because I could step on the toes of some other code, I guess. Thanks, I'll keep it in mind. Anyway, for the time being I feel safer with just creating a TWICImage in initialization.

Is has to do with COM, ActiveX, don't ask me to explain, I know next to nothing about these things. But I browsed QC a bit, in which this or similar bugs have been reported multiple times (almost all closed), but I got the idea that a CoInitialize call could be missing. Look at this simple test: uses System.Threading, WinApi.ActiveX; procedure TForm2.Button1Click(Sender: TObject); var task: iTask; begin task := TTask.Run( procedure var WIC: TWICImage; begin //CoInitializeEx(nil,COINIT_MULTITHREADED); WIC := TWICImage.Create; try finally WIC.Free; end; end); end; As it is, this gives an error in VCL.Graphics in the line marked: constructor TWICImage.Create; var LResult: HResult; begin inherited; FInterpolationMode := wipmNone; EnterCriticalSection(WicImageLock); try if FImagingFactory = nil then begin LResult := CoCreateInstance(CLSID_WICImagingFactory, nil, CLSCTX_INPROC_SERVER or //<--------------------------- CLSCTX_LOCAL_SERVER, IUnknown, FImagingFactory); if Failed(LResult) then raise EInvalidGraphicOperation.CreateFmt(SWinRTInstanceError + ' (%X)', ['CLSID_WICImagingFactory', LResult]); end else FImagingFactory._AddRef; finally LeaveCriticalSection(WicImageLock); end; Uncommenting the line with CoInitializeEx in the test, seems to fix the error in the test procedure. Renate

The TWICImage-factory-bug in threads is still present in 11.3 (I just got the new community-edition 🙂)

It could still work, since the weights only run from -$100 to $100. So a 3-dimensional table would work. Let's try. Edit: No, such a table would just be too big. Edit2: shr 2 doesn't work, because the result of the multiplication could be negative. Thanks for the idea!

I just managed to get the routine for the pre-multiplication much faster. I naively assumed that MulDiv is faster than multiplication and subsequent div. So I used this (PremultPrecision is a constant of value 4): if ps.rgbReserved > 0 then begin alpha := Weight * ps.rgbReserved; inc(Cache.b, MulDiv(ps.rgbBlue, alpha, PreMultPrecision)); inc(Cache.g, MulDiv(ps.rgbGreen, alpha, PreMultPrecision)); inc(Cache.r, MulDiv(ps.rgbRed, alpha, PreMultPrecision)); inc(Cache.a, alpha); end; But this is in fact faster (with compiler-optimization turned on): if ps.rgbReserved > 0 then begin alpha := Weight * ps.rgbReserved; inc(Cache.b, ps.rgbBlue*alpha div PreMultPrecision); inc(Cache.g, ps.rgbGreen*alpha div PreMultPrecision); inc(Cache.r, ps.rgbRed*alpha div PreMultPrecision); inc(Cache.a, alpha); end; And now I remember that Anders even explained that behavior to me before: If the div is by a constant that is a power of 2, the optimizer is smart enough to turn div into a shift. Guess the optimizer isn't smart enough to do this in MulDiv.

Wow, it was indeed very easy, and even the previous link still works! Thanks!

It certainly isn't in 10.4, I tried it. Don't know about 11.x, since I don't have it. I'm claiming to support 10.x and higher. See here: https://www.delphitools.info/2019/07/18/workaround-for-twicimage-imagefactory-bug-in-delphi-10-x/ Edit: I played around with this some more, and it seems like you just have to create any old TWICImage in the main thread before you send off a thread. Then the thread can safely use TWICImage.Create, because the factory has been initialized already. If the factory is initialized in the thread, it bombs.

I've implemented this in the new version, but not via a new unit, too much of a can of worms for me right now. Changes to https://github.com/rmesch/Repository-R.Schaaf are now as follows: Threads will no longer be automatically created in Initialization. You can call InitDefaultResamplingThreads to initialize them before you need them, or they will be initialized in the first call of a parallel procedure, which causes a delay. FinalizeDefaultResamplingThreads will free them. If you forget, uScale frees them in Finalization. Source bitmaps with alphaformat=afDefined are now handled correctly, and the target will have the same alphaformat. The resampler works best though with alphaformat=afIgnored. You should define the alphaformat only before display to avoid imprecisions. The unit uTools has routines to transfer a TPngImage or a TWICImage to TBitmap without setting alphaformat=afDefined, which is what TBitmap. Assign alway does in VCL.Graphics (and which is a waste of time for .jpg). A TWICImage is very convenient for fast decoding of .jpg, .png or .tif. Alas TWICImage.Create is not threadsafe, so it needs to be created in the main thread. There is a new TAlphaCombineMode amTransparentColor which preserves the TransparentColor and the regions of transparency upon resampling. The ThreadsInThreads demo now makes thumbnails in 2 concurrent threads, that should be a good crashtest for thread-safety. Cleaned up the code in uScale, moving everything into implementation that is not needed in interface, and added more comments. Also moved 4 almost identical routines into one, sacrificing a bit of performance. I know I should have picked a better name for the repository, but if I change it now, what happens to my three little stars? Renate

Hi Tommi, Your suggestions make a lot of sense. I had already thought it would be better not to initialize the thread pool in initialization, but moving the thread pool stuff into a different unit is a much better idea. Renate

Hi Anders, Just tried the new version of Graphics32, and found that the downscaling with Box looks as cr***y as before we changed the radius to 0.5, which IS the logically correct value, since the box function has a support [-0.5,0.5]. I can't see right now what goes wrong with the upscaling, it must be something different. Anyway, I don't see any problems with upscaling in my code, just tried it with a factor 20. You did a lot of work on graphics32, will have a closer look. Renate

@johnnydp Sorry for the late reply, I took a break from delphi. I now created a repository on GITHub which contains the latest version of the resampler plus 2 demos. https://github.com/rmesch/Repository-R.Schaaf See you, Renate

You can add the following line e.g. in the OnCreate of the main form: TStyleManager.SystemHooks := TStyleManager.SystemHooks - [shDialogs]; VCL.Themes needs to be in the uses list. The drawback is, that the style is also removed from all message dialogs. But I find it easier to make your own message boxes than your own file dialogs.

No. The functions have just not been used not quite correctly in the example procedure that encodes a file. I should have made that more clear in my post.

I spent some time to have Delphi interface correctly with the Lame-encoder-DLL, so I thought it a good idea to share the result, since I also could not find any good Delphi-code for this on the net. The Lame-source comes with a rudimentary Delphi-header-file, but this has several issues, which I have tried to fix: The file references unnecessary stuff, preventing compilation, easy to fix. The encoding starts at the beginning of the wave-file, thereby encoding the header. This gives a noise at the beginning and can switch the stereo-channels. Fix: Offset the source into the data-section of the wave-file. Since this offset can vary, I have used the utility functions by Kambiz R. Khojasteh (http://www.delphiarea.com) to retrieve the necessary info using WinApi.MMSystem. Lame suggests writing a VBR-Header to the file, even though it's CBR, I have changed the routine accordingly. This way devices can e.g. figure out the duration of the mp3-audio more easily. Instead of file-handles I'm using TFileStream, that seems to speed up encoding considerably. Usage: EncodeWavToMP3(WaveFile, MP3File, Bitrate) WaveFile needs to be 16-bit Stereo, but that could be adjusted. Bitrate is a constant bitrate, for example 128. Support for VBR could be added. If you use it and find something wrong, I'd like to know 🙂 Here is the unit: unit MP3ExportLame; interface Uses System.SysUtils, WinApi.Windows, System.Classes; type // type definitions PHBE_STREAM = ^THBE_STREAM; THBE_STREAM = LongWord; BE_ERR = LongWord; const // encoding formats BE_CONFIG_MP3 = 0; BE_CONFIG_LAME = 256; // error codes BE_ERR_SUCCESSFUL: LongWord = 0; BE_ERR_INVALID_FORMAT: LongWord = 1; BE_ERR_INVALID_FORMAT_PARAMETERS: LongWord = 2; BE_ERR_NO_MORE_HANDLES: LongWord = 3; BE_ERR_INVALID_HANDLE: LongWord = 4; // format specific variables BE_MP3_MODE_STEREO = 0; BE_MP3_MODE_DUALCHANNEL = 2; BE_MP3_MODE_MONO = 3; // other constants BE_MAX_HOMEPAGE = 256; type TMP3 = packed record dwSampleRate: LongWord; byMode: Byte; wBitRate: Word; bPrivate: LongWord; bCRC: LongWord; bCopyright: LongWord; bOriginal: LongWord; end; TLHV1 = packed record // STRUCTURE INFORMATION dwStructVersion: DWORD; dwStructSize: DWORD; // BASIC ENCODER SETTINGS dwSampleRate: DWORD; // ALLOWED SAMPLERATE VALUES DEPENDS ON dwMPEGVersion dwReSampleRate: DWORD; // DOWNSAMPLERATE, 0=ENCODER DECIDES nMode: Integer; // BE_MP3_MODE_STEREO, BE_MP3_MODE_DUALCHANNEL, BE_MP3_MODE_MONO dwBitrate: DWORD; // CBR bitrate, VBR min bitrate dwMaxBitrate: DWORD; // CBR ignored, VBR Max bitrate nQuality: Integer; // Quality setting (NORMAL,HIGH,LOW,VOICE) dwMpegVersion: DWORD; // MPEG-1 OR MPEG-2 dwPsyModel: DWORD; // FUTURE USE, SET TO 0 dwEmphasis: DWORD; // FUTURE USE, SET TO 0 // BIT STREAM SETTINGS bPrivate: LONGBOOL; // Set Private Bit (TRUE/FALSE) bCRC: LONGBOOL; // Insert CRC (TRUE/FALSE) bCopyright: LONGBOOL; // Set Copyright Bit (TRUE/FALSE) bOriginal: LONGBOOL; // Set Original Bit (TRUE/FALSE_ // VBR STUFF bWriteVBRHeader: LONGBOOL; // WRITE XING VBR HEADER (TRUE/FALSE) bEnableVBR: LONGBOOL; // USE VBR ENCODING (TRUE/FALSE) nVBRQuality: Integer; // VBR QUALITY 0..9 btReserved: array [0 .. 255] of Byte; // FUTURE USE, SET TO 0 end; TAAC = packed record dwSampleRate: LongWord; byMode: Byte; wBitRate: Word; byEncodingMethod: Byte; end; TFormat = packed record case Byte of 1: (mp3: TMP3); 2: (lhv1: TLHV1); 3: (aac: TAAC); end; TBE_Config = packed record dwConfig: LongWord; format: TFormat; end; PBE_Config = ^TBE_Config; TBE_Version = record byDLLMajorVersion: Byte; byDLLMinorVersion: Byte; byMajorVersion: Byte; byMinorVersion: Byte; byDay: Byte; byMonth: Byte; wYear: Word; zHomePage: Array [0 .. BE_MAX_HOMEPAGE + 1] of Char; end; PBE_Version = ^TBE_Version; //Headers for Lame_enc.dll (ver. 3.100) Function beInitStream(var pbeConfig: TBE_Config; var dwSample: LongWord; var dwBufferSize: LongWord; var phbeStream: THBE_STREAM): BE_ERR; cdecl; external 'Lame_enc.dll'; Function beEncodeChunk(hbeStream: THBE_STREAM; nSamples: LongWord; var pSample; var pOutput; var pdwOutput: LongWord): BE_ERR; cdecl; external 'Lame_enc.dll'; Function beDeinitStream(hbeStream: THBE_STREAM; var pOutput; var pdwOutput: LongWord): BE_ERR; cdecl; external 'Lame_enc.dll'; Function beCloseStream(hbeStream: THBE_STREAM): BE_ERR; cdecl; external 'Lame_enc.dll'; Procedure beVersion(var pbeVersion: TBE_Version); cdecl; external 'Lame_enc.dll'; // Added header for beWriteVBRHeader Procedure beWriteVBRHeader(MP3FileName: pAnsiChar); cdecl; external 'Lame_enc.dll'; Procedure EncodeWavToMP3(WaveFile, MP3File: string; BitRate: Integer); // BitRate 128 192 256 etc. implementation uses WinApi.MMSystem; { ---------------------------------------- } { The following functions retrieve the necessary info from the input-wave-file. } { Source: } { WaveUtils - Utility functions and data types } { by Kambiz R. Khojasteh } { } { kambiz@delphiarea.com } { http://www.delphiarea.com } function mmioStreamProc(lpmmIOInfo: PMMIOInfo; uMsg, lParam1, lParam2: DWORD) : LRESULT; stdcall; var Stream: TStream; begin if Assigned(lpmmIOInfo) and (lpmmIOInfo^.adwInfo[0] <> 0) then begin Stream := TStream(lpmmIOInfo^.adwInfo[0]); case uMsg of MMIOM_OPEN: begin if TObject(lpmmIOInfo^.adwInfo[0]) is TStream then begin Stream.Seek(0, SEEK_SET); lpmmIOInfo^.lDiskOffset := 0; Result := MMSYSERR_NOERROR; end else Result := -1; end; MMIOM_CLOSE: Result := MMSYSERR_NOERROR; MMIOM_SEEK: try if lParam2 = SEEK_CUR then Stream.Seek(lpmmIOInfo^.lDiskOffset, SEEK_SET); Result := Stream.Seek(lParam1, lParam2); lpmmIOInfo^.lDiskOffset := Result; except Result := -1; end; MMIOM_READ: try Stream.Seek(lpmmIOInfo^.lDiskOffset, SEEK_SET); Result := Stream.Read(Pointer(lParam1)^, lParam2); lpmmIOInfo^.lDiskOffset := Stream.Seek(0, SEEK_CUR); except Result := -1; end; MMIOM_WRITE, MMIOM_WRITEFLUSH: try Stream.Seek(lpmmIOInfo^.lDiskOffset, SEEK_SET); Result := Stream.Write(Pointer(lParam1)^, lParam2); lpmmIOInfo^.lDiskOffset := Stream.Seek(0, SEEK_CUR); except Result := -1; end else Result := MMSYSERR_NOERROR; end; end else Result := -1; end; function OpenStreamWaveAudio(Stream: TStream): HMMIO; var mmIOInfo: TMMIOINFO; begin FillChar(mmIOInfo, SizeOf(mmIOInfo), 0); mmIOInfo.pIOProc := @mmioStreamProc; mmIOInfo.adwInfo[0] := DWORD(Stream); Result := mmioOpen(nil, @mmIOInfo, MMIO_READWRITE); end; function GetWaveAudioInfo(mmIO: HMMIO; var pWaveFormat: PWaveFormatEx; var DataSize, DataOffset: DWORD): Boolean; function GetWaveFormat(const ckRIFF: TMMCKInfo): Boolean; var ckFormat: TMMCKInfo; begin Result := False; ckFormat.ckid := mmioStringToFOURCC('fmt', 0); if (mmioDescend(mmIO, @ckFormat, @ckRIFF, MMIO_FINDCHUNK) = MMSYSERR_NOERROR) and (ckFormat.cksize >= SizeOf(TWaveFormat)) then begin if ckFormat.cksize < SizeOf(TWaveFormatEx) then begin GetMem(pWaveFormat, SizeOf(TWaveFormatEx)); FillChar(pWaveFormat^, SizeOf(TWaveFormatEx), 0); end else GetMem(pWaveFormat, ckFormat.cksize); Result := (mmioRead(mmIO, pAnsiChar(pWaveFormat), ckFormat.cksize) = Integer(ckFormat.cksize)); end; end; function GetWaveData(const ckRIFF: TMMCKInfo): Boolean; var ckData: TMMCKInfo; begin Result := False; ckData.ckid := mmioStringToFOURCC('data', 0); if (mmioDescend(mmIO, @ckData, @ckRIFF, MMIO_FINDCHUNK) = MMSYSERR_NOERROR) then begin DataSize := ckData.cksize; DataOffset := ckData.dwDataOffset; Result := True; end; end; var ckRIFF: TMMCKInfo; OrgPos: Integer; begin Result := False; OrgPos := mmioSeek(mmIO, 0, SEEK_CUR); try mmioSeek(mmIO, 0, SEEK_SET); ckRIFF.fccType := mmioStringToFOURCC('WAVE', 0); if (mmioDescend(mmIO, @ckRIFF, nil, MMIO_FINDRIFF) = MMSYSERR_NOERROR) then begin pWaveFormat := nil; if GetWaveFormat(ckRIFF) and GetWaveData(ckRIFF) then Result := True else if Assigned(pWaveFormat) then ReallocMem(pWaveFormat, 0); end finally mmioSeek(mmIO, OrgPos, SEEK_SET); end; end; function GetStreamWaveAudioInfo(Stream: TStream; var pWaveFormat: PWaveFormatEx; var DataSize, DataOffset: DWORD): Boolean; var mmIO: HMMIO; begin Result := False; if Stream.Size <> 0 then begin mmIO := OpenStreamWaveAudio(Stream); if mmIO <> 0 then try Result := GetWaveAudioInfo(mmIO, pWaveFormat, DataSize, DataOffset); finally mmioClose(mmIO, MMIO_FHOPEN); end; end; end; Procedure EncodeWavToMP3(WaveFile, MP3File: string; BitRate: Integer); var beConfig: TBE_Config; dwSamples, dwSamplesMP3: LongWord; hbeStream: THBE_STREAM; error: BE_ERR; pBuffer: PSmallInt; pMP3Buffer: PByte; done: LongWord; dwWrite: LongWord; ToRead: LongWord; ToWrite: LongWord; // changed from THandle to TFileStream fs, ft: TFileStream; TotalSize: DWORD; // variables to hold the wave info necessary for encoding pWaveFormat: PWaveFormatEx; DataOffset, DataSize, InputSampleRate: DWORD; begin beConfig.dwConfig := BE_CONFIG_LAME; fs := TFileStream.Create(WaveFile, fmOpenRead or fmShareDenyWrite); ft := TFileStream.Create(MP3File, fmCreate or fmShareDenyWrite); try TotalSize := fs.Size; // obtain info from source wave file try if not GetStreamWaveAudioInfo(fs, pWaveFormat, DataSize, DataOffset) then raise Exception.Create ('Unable to obtain necessary info from wave file.'); if (pWaveFormat.nChannels <> 2) or (pWaveFormat.wBitsPerSample <> 16) then raise Exception.Create('Wave format must be 16bit Stereo.'); InputSampleRate := pWaveFormat.nSamplesPerSec; finally FreeMem(pWaveFormat); end; // Structure information beConfig.format.lhv1.dwStructVersion := 1; beConfig.format.lhv1.dwStructSize := SizeOf(beConfig); // Basic encoder setting beConfig.format.lhv1.dwSampleRate := InputSampleRate; beConfig.format.lhv1.dwReSampleRate := InputSampleRate; beConfig.format.lhv1.nMode := BE_MP3_MODE_STEREO; beConfig.format.lhv1.dwBitrate := BitRate; beConfig.format.lhv1.dwMaxBitrate := BitRate; beConfig.format.lhv1.nQuality := 4; beConfig.format.lhv1.dwMpegVersion := 1; // MPEG1 beConfig.format.lhv1.dwPsyModel := 0; beConfig.format.lhv1.dwEmphasis := 0; // Bit Stream Settings beConfig.format.lhv1.bPrivate := False; beConfig.format.lhv1.bCRC := True; beConfig.format.lhv1.bCopyright := True; beConfig.format.lhv1.bOriginal := True; // VBR Stuff // Have it write a VBRHeader, as recommended by Lame, even though it's CBR beConfig.format.lhv1.bWriteVBRHeader := True; beConfig.format.lhv1.bEnableVBR := False; beConfig.format.lhv1.nVBRQuality := 0; error := beInitStream(beConfig, dwSamples, dwSamplesMP3, hbeStream); if error = BE_ERR_SUCCESSFUL then begin pBuffer := AllocMem(dwSamples * 2); pMP3Buffer := AllocMem(dwSamplesMP3); try // Position the source file stream at the beginning of the PCM-data: done := DataOffset; fs.Seek(DataOffset, soFromBeginning); While (done < TotalSize) do begin if (done + dwSamples * 2 < TotalSize) then ToRead := dwSamples * 2 else begin ToRead := TotalSize - done; FillChar(pBuffer^, dwSamples * 2, 0); end; fs.Read(pBuffer^, ToRead); error := beEncodeChunk(hbeStream, ToRead div 2, pBuffer^, pMP3Buffer^, ToWrite); if error <> BE_ERR_SUCCESSFUL then begin beCloseStream(hbeStream); raise Exception.Create('Encoding Error'); end; ft.Write(pMP3Buffer^, ToWrite); done := done + ToRead; end; error := beDeinitStream(hbeStream, pMP3Buffer^, dwWrite); if error <> BE_ERR_SUCCESSFUL then begin beCloseStream(hbeStream); raise Exception.Create('Close Error'); end; if dwWrite <> 0 then begin ft.Write(pMP3Buffer^, dwWrite); end; error := beCloseStream(hbeStream); if error <> BE_ERR_SUCCESSFUL then begin raise Exception.Create('Close Error'); end; finally FreeMem(pBuffer); FreeMem(pMP3Buffer); end; end else begin Raise Exception.Create('InitStream failure'); end; finally fs.free; ft.free; end; beWriteVBRHeader(pAnsiChar(AnsiString(MP3File))); end; end.

No. I'd like to find out if this really works in all cases, first. Then I'll have to teach myself how to do PRs :).

What's the advantage? When do you use a class helper and when do you use a local accessor class, to me they both seem to serve the same purpose.

I might have introduced a bug in GR32_Resamplers, as it is, the left bound of the source rectangle is ignored. The fix is simple: Line 1778 needs to be SourceColor := @Src.Bits[ClusterY[0].Pos * Src.Width+SrcRect.Left]; //+SrcRect.Left was missing! and line 1806: SourceColor := @Src.Bits[ClusterY[Y].Pos * Src.Width+SrcRect.Left];//+SrcRect.Left was missing! Hope, you read this, Anders. If I don't hear from you, I'll create an issue on GitHub. Edit: I definitely intoduced it by changing the order of the loops, I checked against an old version. Instead of +SrcRect.Left one should probably use +MapXLoPos Renate

Correct and very clear. I like the introduction of the MappingTablePrecicion.. constants.

One weight in x-direction times another one in y-direction. Thanks for the explanation, now I understand the notation. That my posted "correction" can be safely ignored :). Sometimes I'm making it too complicated, sorry.